alex-eg/sex
1
0
Fork 1
Code Issues 3 Pull Requests 1 Actions Packages Projects 1 Releases Wiki Activity

Implement our parser, . field access, comment preservation and line number tracking for source-level debugging #26

Merged
alex-eg merged 13 commits from our-parser into main 2026-09-15 19:43:14 +02:00
Conversation 3 Commits 13 Files Changed 30 +1312 -243
30 changed files with 1312 additions and 243 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
.github/workflows/build.yaml vendored
View File

@@ -15,11 +15,11 @@ jobs:
- uses: actions/checkout@v3
- name: Install chicken
run: |
wget -N https://code.call-cc.org/releases/5.4.0/chicken-5.4.0.tar.gz
tar zxf chicken-5.4.0.tar.gz
wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
tar zxf chicken-6.0.0.tar.gz
sudo apt install -y make
make -C chicken-5.4.0 PLATFORM=linux
sudo make -C chicken-5.4.0 PLATFORM=linux install
make -C chicken-6.0.0 PLATFORM=linux
sudo make -C chicken-6.0.0 PLATFORM=linux install
- name: Install dependencies
# FIXME: [project-local deps]: use venv or something
# run: make deps

8
Makefile
View File

@@ -31,8 +31,8 @@ utils.o: utils.module.scm utils.scm
sex-macros.o: sex-macros.module.scm sex-macros.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
reader.o: reader.module.scm reader.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader
reader.o: reader.module.scm reader.scm utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
@@ -58,7 +58,7 @@ sextest:
$(MAKE) -C ./tools/sextest sextest
cp ./tools/sextest/sextest .
SEX_TEST_PROGRAMS = hello-world lists
SEX_TEST_PROGRAMS = hello-world lists comments unicode
pkulev commented 2026-09-14 23:40:08 +02:00
Review
Copy Link

comments is listed here, but tests/sex-programs/comments.sex is not in the tree. make run-tests dies on (open-input-file) … comments.sex after hello-world, so unicode never runs either. Add the file or drop it from SEX_TEST_PROGRAMS.

`comments` is listed here, but `tests/sex-programs/comments.sex` is not in the tree. `make run-tests` dies on `(open-input-file) … comments.sex` after hello-world, so unicode never runs either. Add the file or drop it from `SEX_TEST_PROGRAMS`.
alex-eg commented 2026-09-15 00:09:20 +02:00
Review
Copy Link

Oops

Oops
run-tests: sexc sex-tests sextest
./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)
@@ -69,4 +69,4 @@ clean:
rm -f *.link
rm -f sexc sex-tests sextest
.PHONY: clean run-tests
.PHONY: clean run-tests sex-tests sextest

14
Readme.org
View File

@@ -4,8 +4,8 @@
#+ATTR_HTML: :width 300px
[[sex.png][file:./sex.png]]
Sex is a S-expressions language. Sex is written in Chicken, which is a
[[https://call-cc.org][R5RS Scheme]].
Sex is a S-expressions language. Sex is written in Chicken, which is an
[[https://call-cc.org][R7RS Scheme]].
Sex is statically typed, compiled general purpose language.
* Compilation
@@ -49,6 +49,12 @@ directory. Sex uses C under the hood, the default C compiler is ~cc~,
but you can pass any using ~--c-compiler~ option, or by setting
~SEX_CC~ environment variable.
Everything after ~--~ is handed to the C compiler exactly as written:
#+begin_src shell
sexc example/sdl3-triangle.sex -o triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
#+end_src
** Example
An example of Sex source:
#+begin_src scheme
@@ -122,7 +128,7 @@ return Sex code.
#+begin_src scheme
(pub defmacro (check-sdl-return call message ret-code)
`(if (< 0 ,call)
(begin
(do
(puts ,message)
(return ,ret-code))))
@@ -135,7 +141,7 @@ return Sex code.
#+begin_src scheme
(pub fn init () int
(if (< 0 (SDL_Init SDL_INIT_VIDEO))
(begin (puts "Failed to initialize SDL") (return 1)))
(do (puts "Failed to initialize SDL") (return 1)))
...)
#+end_src

2
dependencies.txt
View File

@@ -1 +1 @@
fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable
fmt getopt-long brev-separate test srfi-1 srfi-13 srfi-69 matchable

2
example/list.sex
View File

@@ -39,7 +39,7 @@
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
(let ((list-var-2 (cat list-var '-2)))
`(begin
`(do
(var ,list-var-2 (* ,list-type) ,list-var)
(var ,elt-var ,elt-type (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)

2
fmt-c-writer.module.scm
View File

@@ -1,3 +1,3 @@
(module fmt-c-writer (emit-c
sex-fmt-current-file)
sex-line-directives)
"fmt-c-writer.scm")

251
fmt-c-writer.scm
View File

@@ -2,20 +2,97 @@
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken string)
(chicken syntax)
brev-separate
brev-separate ; fn, flatten
fmt
sex-fmt-c
matchable
regex
(chicken irregex) ; unkebabify
srfi-1 ; lists
srfi-13 ; strings
srfi-39 ; parameters
tree
utils)
;;; egg `tree' not ported to CHICKEN 6 yet
(define (tree-map f tree)
(cond ((null? tree) (list))
((pair? tree) (cons (tree-map f (car tree))
(tree-map f (cdr tree))))
(else (f tree))))
;;; How much #line information to emit:
;;;
;;; statement -- before every statement.
;;; toplevel -- one directive per toplevel form.
;;; none -- none at all, for reading -C output by eye.
(define sex-line-directives (make-parameter 'statement))
(define (anchor-statements?)
(eq? (sex-line-directives) 'statement))
(define (line-directive src)
;; `%line' is fmt-c's #line directive. cpp-line concatenates its
;; second argument verbatim, so the file name arrives already quoted.
`(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))
(define (walk-body stmts)
"Walk a statement list, re-anchoring each statement that has a known
source location. Only statement positions may be walked this way: a
#line inside an expression is a C syntax error."
(if (anchor-statements?)
(append-map (lambda (s)
(let ((src (form-source s)))
(if src
(list (line-directive src) (walk-expr s))
(list (walk-expr s)))))
(pack-comments stmts))
(map walk-expr (pack-comments stmts))))
(define (walk-stmt s)
"A statement in a slot that holds exactly one form -- an `if' arm.
Splicing is not possible there, since c-if reads anything past the arm
as an `else if' chain, so the anchor and the statement are wrapped in
`%begin': a statement sequence that emits no braces of its own (the
surrounding c-block supplies them)."
(let ((src (and (pair? s) (anchor-statements?) (form-source s))))
(if src
`(%begin ,(line-directive src) ,(walk-expr s))
(walk-expr s))))
;;; A `;' comment reads as a form, so one written inside a construct
pkulev commented 2026-09-14 23:40:08 +02:00
Outdated
Review
Copy Link

This is strictly test stmt test stmt …. A ; comment is a list element, so it is treated as an arm and shifts the rest.

(if 1
    ; comment
    (puts "then")
    (puts "else"))

became if (1) { /* comment*/ } else if (puts("then")) { puts("else"); }. Same class of bug as stripping comments from fn headers — those accessors would otherwise shift too.

This is strictly `test stmt test stmt …`. A `;` comment is a list element, so it is treated as an arm and shifts the rest. ```scheme (if 1 ; comment (puts "then") (puts "else")) ``` became `if (1) { /* comment*/ } else if (puts("then")) { puts("else"); }`. Same class of bug as stripping comments from fn headers — those accessors would otherwise shift too.
;;; with positional slots lands in a slot and shifts everything after
;;; it. So take the positional slots by skipping comments, and hand
;;; the comments back to be emitted just before the statement
(define (take-slots forms n)
"Three values: the comment forms skipped over, the next N non-comment
forms, and what remains."
(let loop ((fs forms) (n n) (comments (list)) (slots (list)))
(cond ((or (= n 0) (null? fs))
(values (reverse comments) (reverse slots) fs))
((comment-form? (car fs))
(loop (cdr fs) n (cons (car fs) comments) slots))
(else
(loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))
;;; `%begin' is a statement sequence that emits no braces of its own, so
;;; the comments simply precede the statement.
(define (with-comments comments form)
(if (null? comments)
form
`(%begin ,@(map walk-expr comments) ,form)))
(define (walk-if-clauses clauses)
"(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
(let loop ((cs clauses) (acc (list)))
(cond ((null? cs) (reverse acc))
((null? (cdr cs)) ; trailing else statement
(reverse (cons (walk-stmt (car cs)) acc)))
(else (loop (cddr cs)
(cons (walk-stmt (cadr cs))
(cons (walk-expr (car cs)) acc)))))))
(define (unkebabify sym)
(case sym
((-) sym)
@@ -24,20 +101,25 @@
((-=) sym)
(else
(string->symbol
(string-substitute "-(?!>)" "_"
(symbol->string sym) #t)))))
(irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))
(define (atom-to-fmt-c atom)
(case atom
((fn) '%fun)
((prototype) '%prototype)
((begin) '%block-begin)
((do) '%block-begin)
((define) '%define)
((pointer) '%pointer)
((array) '%array)
((attribute) '%attribute)
((¤) 'vector-ref)
((include) '%include)
;; a `|' inside a symbol has to be escaped to be written in
;; a Scheme source, so we just rename it in fmt-c compatible
;; way
((|\||) 'bit-or)
((|\|\||) '%or)
((|\|=|) 'bit-or=)
;; uh things we do for c89 compatibility
((bool) 'int)
((true) 1)
@@ -53,22 +135,48 @@
(car type)
type))
pkulev commented 2026-09-14 23:40:08 +02:00
Outdated
Review
Copy Link

Still only c-or / c-bit-or / c-bit-or=. After the new reader, (| B A R) and (|| 0 1) are those symbols, not these names. sexc -C of the #16 sample emitted \|\\||(B, A, R) and cc rejected it. c-bit-or still works (1 | 2 | 4).

Still only `c-or` / `c-bit-or` / `c-bit-or=`. After the new reader, `(| B A R)` and `(|| 0 1)` are those symbols, not these names. `sexc -C` of the #16 sample emitted `\|\\||(B, A, R)` and `cc` rejected it. `c-bit-or` still works (`1 | 2 | 4`).
(define (make-field-access form)
(assert
(= 2 (length form)) "Wrong field access format")
(unkebabify
(string->symbol
(fmt #f (cadr form) (car form)))))
(define (comment-form? f)
(and (pair? f) (eq? (car f) 'comment)))
;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
(define (strip-comment-marker text)
(string-trim-both (string-trim text #\;)))
(define (walk-comment texts)
(list '%comment
(string-append " "
(string-intersperse (map strip-comment-marker texts)
"\n ")
pkulev commented 2026-09-14 23:40:08 +02:00
Outdated
Review
Copy Link

Same positional trap: a ; between init / test / step binds to the wrong slot. Observed:

for (int i = 0; /* between*/; i < 1) {
    ++i;
    puts("x");
}

c-apply also joins args with ", ", so (printf "%d" ; c\n x) becomes printf("%d", /* c */, x) — extra comma, and cc fails on the #16 sample.

Same positional trap: a `;` between `init` / `test` / `step` binds to the wrong slot. Observed: ```c for (int i = 0; /* between*/; i < 1) { ++i; puts("x"); } ``` `c-apply` also joins args with `", "`, so `(printf "%d" ; c\n x)` becomes `printf("%d", /* c */, x)` — extra comma, and `cc` fails on the #16 sample.
" ")))
;;; Merge multiple lines of /* */ into single block
(define (pack-comments forms)
(let loop ((fs forms) (acc (list)))
(cond
((null? fs) (reverse acc))
((comment-form? (car fs))
(let ((first (car fs)))
(let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
(if (and (pair? rest)
(comment-form? (car rest))
line
(equal? (form-file first) (form-file (car rest)))
(eqv? (form-line (car rest)) (+ line 1)))
(gather (cdr rest)
(append texts (cdr (car rest)))
(form-line (car rest)))
(loop rest
(cons (if (eq? texts (cdr first))
first ; a run of one, left alone
(copy-form-source! first (cons 'comment texts)))
acc))))))
(else (loop (cdr fs) (cons (car fs) acc))))))
(define (walk-generic-toplevel form)
(cond ((atom? form) (atom-to-fmt-c form))
((list? form) (map walk-generic-toplevel form))
(else (error "Malformed form " form))))
(define (field-access-form? form)
(and (symbol? (car form))
(char=? #\. (string-ref (symbol->string (car form)) 0))))
(define (walk-expr form)
(match form
((? vector?)
@@ -76,19 +184,62 @@
(walk-expr (vector->list form))))
((? atom?)
(atom-to-fmt-c form))
((? field-access-form?)
(make-field-access form))
;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
(('comment . text) (walk-comment text))
;; (dot-access obj field ...) -> obj.field... member access. `%.'
;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
(('dot-access . rest) (cons '%. (map walk-expr rest)))
(('var . _) (walk-var form))
(('cast expr type) (list '%cast
(walk-type type)
(walk-expr expr)))
;; An expression has no room for a statement, so a comment in a
;; cast is dropped rather than relocated.
(('cast . rest)
pkulev commented 2026-09-15 18:11:50 +02:00
Outdated
Review
Copy Link

This is the remaining #16 hole. After the new reader, (| B A R) is the symbol |, not c-bit-or. sexc -C of the issue sample still emits \|\\||(B, A, R) and cc rejects it. Same for ||. The (string->symbol ".") cond in c-expr/sexp is the pattern; c-bit-or can stay as an alias.

This is the remaining #16 hole. After the new reader, `(| B A R)` is the symbol `|`, not `c-bit-or`. `sexc -C` of the issue sample still emits `\|\\||(B, A, R)` and `cc` rejects it. Same for `||`. The `(string->symbol ".")` cond in `c-expr/sexp` is the pattern; `c-bit-or` can stay as an alias.
(let-values (((comments slots _) (take-slots rest 2)))
(list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
(('enum . _) (walk-enum form))
;; | is problematic... And c-or/bit-or/etc are actually
;; procedures, so we have to call the procedure itself
(('c-or . rest) (apply c-or (map walk-expr rest)))
(('c-bit-or . rest) (apply c-bit-or (map walk-expr rest)))
(('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest)))
(else (map walk-expr form))))
;; Statement positions. These are the only places a #line may go,
;; and each is spliced or wrapped according to what the
;; corresponding fmt-c procedure accepts.
(('do . stmts) (cons '%block-begin (walk-body stmts)))
(('if . clauses)
(with-comments (filter comment-form? clauses)
(cons 'if (walk-if-clauses (remove comment-form? clauses)))))
(('while . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'while (walk-expr (car slots)) (walk-body body)))))
(('for . rest)
(let-values (((comments slots body) (take-slots rest 3)))
(with-comments comments
(cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
(walk-expr (caddr slots))
(walk-body body)))))
;; No anchor *between* switch clauses: c-switch requires every clause
;; to be a case/default form and errors on anything else. The clause
;; bodies are anchored from inside, which is what a debugger steps
;; onto -- a `case' label is not a statement.
;; A comment between clauses has to go too: c-switch requires every
;; clause to be a case/default form and errors on anything else.
(('switch . rest)
(let-values (((comments slots clauses) (take-slots rest 1)))
(with-comments (append comments (filter comment-form? clauses))
(cons* 'switch (walk-expr (car slots))
(map walk-expr (remove comment-form? clauses))))))
(('case . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'case (walk-expr (car slots)) (walk-body body)))))
(('case/fallthrough . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
(('default . body) (cons 'default (walk-body body)))
;; Drop comments so they will not generate additional comma
(else (map walk-expr (remove comment-form? form)))))
(define (walk-var form)
;; (var a int) -> (%var int a)
@@ -96,14 +247,16 @@
;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
;; note: [...] is actually (¤ ...) after reading
;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
`(%var
,(walk-type (third form))
,(atom-to-fmt-c (second form))
.
,(if (null? (drop form 3))
(list)
(walk-expr (drop form 3))) ; optional init expression
))
;; Likewise a declaration: drop any comment rather than shift the
;; name and type apart.
(let ((form (cons (car form) (remove comment-form? (cdr form)))))
`(%var
,(walk-type (third form))
,(atom-to-fmt-c (second form))
.
,(if (null? (drop form 3))
(list)
(walk-expr (drop form 3)))))) ; optional init expression
(define (walk-type form)
;; int -> int
@@ -158,7 +311,7 @@
,(atom-to-fmt-c name)
,(walk-arglist args)
.
,(walk-expr maybe-body)))))
,(walk-body maybe-body)))))
;;; TODO: isn't there a better way?
(define (is-probably-type form)
@@ -184,7 +337,7 @@
((var . type) (append (list (walk-type (maybe-unwrap-type type)))
(list (walk-type var))))))
form))
(remove comment-form? form)))
(define (walk-function form)
;; (fn ret-type name arglist body) -> normal function
@@ -197,7 +350,7 @@
(map (fn
(let ((type (walk-type (last x))))
(cons type (map atom-to-fmt-c (drop-right x 1)))))
fields))
(remove comment-form? fields)))
(define (walk-struct form)
(match form
@@ -251,6 +404,7 @@
(define (process-toplevel-form form)
(match form
(('comment . text) (walk-comment text))
(('fn . _) (list 'static (walk-function form)))
(('var . _) (list 'static (walk-var form)))
(('extern . rest) (walk-extern rest))
@@ -261,23 +415,14 @@
(('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
(else (walk-expr form))))
(define (get-line-num form)
(let ((num (get-line-number form)))
(if (string? num)
(last (string-split num ":"))
#f)))
(define sex-fmt-current-file (make-parameter "/dev/null"))
(define sex-fmt-line-num (make-parameter 0))
(define (line-directive-string)
(fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
(define (emit-c sex-forms)
(for-each (lambda (form)
(let ((start-line (get-line-num form)))
(when start-line
(sex-fmt-line-num start-line)
(fmt #t (line-directive-string) nl)))
;; Forms the reader did not produce -- the prelude, and
;; anything a macro built that we could not attribute --
;; have no location and get no directive.
(let ((src (and (not (eq? (sex-line-directives) 'none))
(form-source form))))
(when src
(fmt #t (c-expr (line-directive src)))))
(fmt #t (c-expr (process-toplevel-form form)) nl))
sex-forms))
(pack-comments sex-forms)))

309
reader.scm
View File

@@ -1,49 +1,284 @@
;;; Sex reader
;;;
;;; A hand-written tokenizer + recursive-descent parser that replaces
;;; CHICKEN's built-in `read'. We need our own reader because the
;;; features Sex requires cannot be expressed on top of `read':
;;; - [ ... ] array/pointer sugar, read as (¤ ...)
;;; - a leading `.' rewritten to the symbol `dot-access'
;;; - `;' comments preserved as (comment "...") forms, so they can be
;;; re-emitted into the generated C (keeping the source mapping)
;;; It also records the source location of every form it reads (see
;;; utils' form-source), so the C writer can emit #line directives.
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken io)
(chicken pathname)
(chicken port)
(chicken read-syntax)
(chicken string)
(chicken syntax)
brev-separate
fmt)
utils)
(import-syntax utils)
;;; Sentinels for structural tokens
(define close-paren (list '%close-paren))
(define close-bracket (list '%close-bracket))
(define dot-token (list '%dot))
(define (read-forms acc)
(let ((r (read-with-source-info (current-input-port))))
(if (eof-object? r) (reverse acc)
(read-forms (cons r acc)))))
;;; Current source line. Tracked as characters are consumed
(define current-line (make-parameter 1))
(define (get-ch port)
(let ((c (read-char port)))
(when (and (char? c) (char=? c #\newline))
(current-line (+ 1 (current-line))))
c))
(define (peek port)
(peek-char port))
;;; Record where a form started. Called with the line of the opening
;;; delimiter, sampled before it is consumed
(define (stamp form line)
(when (pair? form)
(set-form-source! form (current-source-file) line))
form)
(define (delimiter? c)
(or (eof-object? c)
(char-whitespace? c)
(memv c '(#\( #\) #\[ #\] #\" #\; #\' #\` #\,))))
;;; Skip whitespace. `;' comments are NOT skipped here: they are read
;;; as (comment "...") forms by the tokenizer. Block comments (#| |#)
;;; and datum comments (#;) are discarded in the tokenizer's `#'
;;; dispatch, since `#' also introduces real data (#t, #f, #\c, #(...))
(define (skip-whitespace port)
(let ((c (peek port)))
(cond
((eof-object? c) #t)
((char-whitespace? c) (get-ch port) (skip-whitespace port))
(else #t))))
;;; A `;' comment, read as (comment "<rest of line>"). The leading `;'
;;; is consumed; the newline is left in the stream so line tracking and
;;; the surrounding parser see it normally
(define (read-comment port)
(get-ch port) ; consume the leading ;
(let loop ((chars (list)))
(let ((c (peek port)))
(if (or (eof-object? c) (char=? c #\newline))
(list 'comment (list->string (reverse chars)))
(begin (get-ch port)
(loop (cons c chars)))))))
;;; Read the next token: a datum, one of the structural sentinels
;;; (close-paren / close-bracket / dot-token), or the eof-object
(define (next-token port)
(skip-whitespace port)
(let ((c (peek port)))
(cond
((eof-object? c) c)
((char=? c #\()
(let ((line (current-line)))
(get-ch port)
(stamp (read-list port close-paren) line)))
((char=? c #\[)
(let ((line (current-line)))
(get-ch port)
(stamp (cons '¤ (read-list port close-bracket)) line)))
((char=? c #\)) (get-ch port) close-paren)
((char=? c #\]) (get-ch port) close-bracket)
((char=? c #\;)
(let ((line (current-line)))
(stamp (read-comment port) line)))
((char=? c #\") (read-string-lit port))
((char=? c #\') (get-ch port) (list 'quote (read-datum port)))
((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port)))
((char=? c #\,)
(get-ch port)
(if (eqv? (peek port) #\@)
(begin (get-ch port) (list 'unquote-splicing (read-datum port)))
(list 'unquote (read-datum port))))
((char=? c #\#) (get-ch port) (read-hash port))
(else (read-atom port)))))
;;; Like next-token, but a full datum is required: the structural
;;; sentinels and eof are errors here (e.g. after a quote or `.')
(define (read-datum port)
(let ((tok (next-token port)))
(cond
((eof-object? tok) (error "Unexpected end of input"))
((eq? tok close-paren) (error "Unexpected )"))
((eq? tok close-bracket) (error "Unexpected ]"))
((eq? tok dot-token) (error "Unexpected ."))
(else tok))))
;;; Read list elements up to close-paren or close-bracket,
;;; honoring dotted-pair notation (a b . c)
(define (read-list port closer)
(let loop ((acc (list)))
(let ((tok (next-token port)))
(cond
((eof-object? tok) (error "Unexpected end of input inside list"))
((eq? tok close-paren)
(if (eq? closer close-paren)
(reverse acc)
(error "Unmatched closing bracket")))
((eq? tok close-bracket)
(if (eq? closer close-bracket)
(reverse acc)
(error "Unmatched closing bracket")))
((eq? tok dot-token)
(if (null? acc)
;; Leading `.': the member/method access operator. It reads
;; as an ordinary `dot-access' symbol in first position.
(loop (cons 'dot-access acc))
;; Otherwise: ordinary dotted-pair notation (a b . c).
(let ((tail (read-datum port))
(end (next-token port)))
(unless (eq? end closer)
(error "Malformed dotted list"))
(append-reverse acc tail))))
(else (loop (cons tok acc)))))))
;;; Append the reversed list `rev' in front of `tail', producing a
;;; possibly-improper list (used for dotted pairs)
(define (append-reverse rev tail)
(if (null? rev)
tail
(append-reverse (cdr rev) (cons (car rev) tail))))
;;; A bare atom: symbol or number, or the dot token when it is exactly "."
(define (read-atom port)
(let loop ((chars (list)))
(let ((c (peek port)))
(if (delimiter? c)
(finish-atom (list->string (reverse chars)))
(begin (get-ch port) (loop (cons c chars)))))))
(define (finish-atom s)
(cond
((string=? s ".") dot-token)
((string->number s) => identity)
(else (string->symbol s))))
;;; #-dispatch: booleans, characters, vectors, block/datum comments
(define (read-hash port)
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unexpected end of input after #"))
((or (char=? c #\t) (char=? c #\T)) (read-bool port #t))
((or (char=? c #\f) (char=? c #\F)) (read-bool port #f))
((char=? c #\\) (read-char-lit port))
((char=? c #\() (list->vector (read-list port close-paren)))
((char=? c #\|) (skip-block-comment port 1) (next-token port))
((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
(else (error "Unsupported # syntax" c)))))
;;; #t / #true / #f / #false. `val' is the boolean; consume any
;;; trailing name characters and validate
(define (read-bool port val)
(let ((rest (read-atom-string port)))
(cond
((string=? rest "") val)
((and val (string=? rest "rue")) val)
((and (not val) (string=? rest "alse")) val)
(else (error "Malformed boolean literal" rest)))))
(define (read-atom-string port)
(let loop ((chars (list)))
(let ((c (peek port)))
(if (delimiter? c)
(list->string (reverse chars))
(begin (get-ch port) (loop (cons c chars)))))))
(define named-chars
'(("space" . #\space) ("newline" . #\newline) ("tab" . #\tab)
("return" . #\return) ("nul" . #\nul) ("null" . #\nul)
("delete" . #\delete) ("escape" . #\escape) ("alarm" . #\alarm)
("backspace" . #\backspace)))
(define (read-char-lit port)
(let ((first (get-ch port)))
(when (eof-object? first)
(error "Unexpected end of input in character literal"))
(if (char-alphabetic? first)
(let ((rest (read-atom-string port)))
(if (string=? rest "")
first
(let ((name (string-append (string first) rest)))
(cond
((assoc name named-chars) => cdr)
(else (error "Unknown character name" name))))))
first)))
;;; String literal with escape processing, matching the common escapes
;;; the previous reader (CHICKEN `read') interpreted
(define (read-string-lit port)
(get-ch port) ; consume opening quote
(let loop ((chars (list)))
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated string literal"))
((char=? c #\") (list->string (reverse chars)))
((char=? c #\\) (loop (cons (read-escape port) chars)))
(else (loop (cons c chars)))))))
(define (read-escape port)
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated string literal"))
((char=? c #\n) #\newline)
((char=? c #\t) #\tab)
((char=? c #\r) #\return)
((char=? c #\a) #\alarm)
((char=? c #\b) #\backspace)
((char=? c #\f) (integer->char 12))
((char=? c #\v) (integer->char 11))
((char=? c #\0) #\nul)
(else c)))) ; \" \\ and anything else: literal
(define (skip-block-comment port depth)
(if (= depth 0)
#t
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated block comment"))
((and (char=? c #\|) (eqv? (peek port) #\#))
(get-ch port) (skip-block-comment port (- depth 1)))
((and (char=? c #\#) (eqv? (peek port) #\|))
(get-ch port) (skip-block-comment port (+ depth 1)))
(else (skip-block-comment port depth))))))
;;; Read every top-level form from `port'. Locations are recorded by
;;; next-token, for every form rather than only these
(define (parse-all port)
(parameterize ((current-line 1))
(let loop ((acc (list)))
(skip-whitespace port)
(let ((tok (next-token port)))
(cond
((eof-object? tok) (reverse acc))
((or (eq? tok close-paren)
(eq? tok close-bracket))
(error "Unmatched closing bracket at top level"))
((eq? tok dot-token)
(error "Unexpected . at top level"))
(else
(loop (cons tok acc))))))))
;;; Entry point: read all forms from a file, or from the current input
;;; port when the source is 'stdin
(define (read-from-file file)
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list))))))
(define open-bracket-counter (make-parameter 0))
;; Resolve the name before with-directory moves us, so an imported
;; module's forms carry that module's path rather than the importer's
(let ((source-file (to-absolute-pathname file)))
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(lambda ()
(parameterize ((current-source-file source-file))
(parse-all (current-input-port))))))))
(define (read-raw-forms input-source)
(let ((bracket-end (gensym)))
(set-read-syntax!
#\]
(lambda (port)
(when (= 0 (open-bracket-counter))
(error "Unmatched closing bracket"))
(open-bracket-counter (- (open-bracket-counter) 1))
bracket-end))
(set-read-syntax!
#\[
(lambda (port)
(open-bracket-counter (+ (open-bracket-counter) 1))
(let loop ((r (read port))
(acc (list)))
(if (eq? r bracket-end)
(cons '¤ (reverse acc))
(loop (read port)
(cons r acc)))))))
(if (eq? input-source 'stdin)
(read-forms (list))
(parameterize ((current-source-file "stdin"))
(parse-all (current-input-port)))
(read-from-file input-source)))

46
semen.scm
View File

@@ -47,10 +47,15 @@
;;
;; Single form we just cons to the top of rest-forms, but multiple
;; forms have to be appended to the rest-forms.
(let ((res (apply-macro macro-form)))
(let ((res (apply-macro macro-form))
(src (form-source macro-form)))
;; An expansion is fresh structure with no location of its own. Give
;; it the call site's, the way cpp attributes a macro body to where
;; the macro was used
(if (list? (car res))
(append res rest-forms)
(cons res rest-forms))))
(append (map (lambda (f) (stamp-form-source! f src)) res)
rest-forms)
(cons (stamp-form-source! res src) rest-forms))))
(define (match-sex-form sex-form acc)
(match sex-form
@@ -68,6 +73,7 @@
('extern 'var . _)) (process-global-var sex-form acc))
(('include _) (cons sex-form acc))
(('define . _) (cons sex-form acc))
(('comment . _) (cons sex-form acc))
(('import . modules)
(process-imports (get-modules-public-forms modules) acc))
@@ -77,7 +83,7 @@
((or ('typedef new-type target)
('pub 'typedef new-type target))
(process-typedef new-type target acc))
(process-typedef sex-form new-type target acc))
(else (assert #f (fmt #f "Unknown top level form " sex-form)))))
@@ -133,13 +139,34 @@
;;; Typdef
(define (process-typedef new-type target acc)
(cons `(typedef ,target ,new-type) acc))
(define (process-typedef form new-type target acc)
(cons (copy-form-source! form `(typedef ,target ,new-type)) acc))
;;; Fn processing
(define (process-fn sex-fn acc)
(let* ((expanded (macro-expand sex-fn))
(define (comment-form? f)
(and (pair? f) (eq? (car f) 'comment)))
(define (strip-fn-header-comments fn-form)
;; Remove comment forms from the function header
;; ([pub|extern] fn name arglist rettype) so the positional accessors
;; below are not shifted. Comments in the body are left in place as
;; ordinary statements and preserved into the generated C.
(let ((header-count (if (memq (car fn-form) '(pub extern)) 5 4)))
;; This always rebuilds the list, so the location has to be carried
;; over explicitly -- otherwise every function loses it
(copy-form-source!
fn-form
(let loop ((form fn-form) (kept 0) (acc (list)))
(cond
((null? form) (reverse acc))
((= kept header-count) (append (reverse acc) form))
((comment-form? (car form)) (loop (cdr form) kept acc))
(else (loop (cdr form) (+ kept 1) (cons (car form) acc))))))))
(define (process-fn sex-fn-raw acc)
(let* ((sex-fn (strip-fn-header-comments sex-fn-raw))
(expanded (macro-expand sex-fn))
(env (make-hash-table))
(processed
(walk-form
@@ -175,7 +202,8 @@
(('lambda ret-type arglist captures . body)
;; Captures are ignored for now, but
;; we'll need them for TODO: closures support
(process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
(process-fn (copy-form-source! form `(fn ,ret-type ,name ,arglist ,@body))
(list)))
(else (assert #f (fmt #f "Malformed lambda " form)))))
;;; Structs

63
sex-fmt-c.scm
View File

@@ -33,6 +33,7 @@
(import
scheme
(scheme base) ; string->utf8, bytevector accessors
(chicken base)
fmt
srfi-1
@@ -138,7 +139,31 @@
(case n
((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
((11) "\\v") ((12) "\\f") ((13) "\\r")
(else (string-append "\\x" (number->string (char->integer c) 16)))))))
(else (c-octal-escapes c))))))
;; A character outside printable ASCII, as one three-digit octal escape
;; per UTF-8 byte.
;;
;; MODIFIED FROM UPSTREAM fmt-c, which emits "\x" plus the hex of the
;; character. C's \x escape consumes *every* following hex digit, so
;; "\xc3\xa91" is a single out-of-range value rather than two bytes
;; followed by a '1'. Under CHICKEN 6 a character is a codepoint rather
;; than a byte, so the hex form additionally emits "\xe9" for a lone
;; "e-acute" -- not valid UTF-8 -- and "\x65e5" for anything above the
;; Latin-1 range, which does not compile at all. Octal escapes are
;; capped at three digits, so they always self-terminate.
(define (c-octal-escapes c)
(let* ((bytes (string->utf8 (string c)))
(len (bytevector-length bytes)))
(let loop ((i 0) (acc '()))
(if (= i len)
(apply string-append (reverse acc))
(loop (+ i 1)
(cons (let ((oct (number->string (bytevector-u8-ref bytes i) 8)))
(string-append "\\"
(make-string (- 3 (string-length oct)) #\0)
oct))
acc))))))
(define (c-format-number x)
(if (and (integer? x) (exact? x))
@@ -762,8 +787,32 @@
(fmt-join c-expr name ", ")
(c-expr name))))))
;; MODIFIED FROM UPSTREAM fmt-c: parenthesise a binary operand.
;;
;; A cast binds tighter than every binary operator, so upstream's
;; unparenthesised (cat "(" type ")" expr) silently casts only the
;; first operand: (cast (* 2 (sizeof GLfloat)) (* void)) came out as
;; `(void *)2 * sizeof(GLfloat)'. Unary operands -- &x, *p, -n,
;; sizeof, calls, identifiers, literals -- are already
;; unary-expressions and are left alone, so this changes nothing that
;; was previously correct.
(define c-binary-operators
'(+ - * / % << >> < > <= >= == != & ^ && %and %or
= *= /= %= &= ^= <<= >>=))
(define (c-binary-expression? expr)
(and (pair? expr)
(memq (car expr) c-binary-operators)
(pair? (cdr expr))
(pair? (cddr expr)))) ; two or more operands
(define (c-cast type expr)
(cat "(" (c-type type) ")" (c-expr expr)))
(cat "(" (c-type type) ")"
(if (c-binary-expression? expr)
;; c-with-op stops the operand from parenthesising itself
;; a second time inside the parens we just added.
(cat "(" (c-with-op 'paren (c-expr expr)) ")")
(c-expr expr))))
(define (c-typedef type alias . o)
(c-wrap-stmt
@@ -820,8 +869,7 @@
(define (c-label name)
(lambda (st)
(let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
((cat fl indent name ":" fl) st))))
((cat name ":" fl) st)))
(define c-break
(c-wrap-stmt (dsp "break")))
@@ -837,7 +885,12 @@
(define (c-switch val . clauses)
(c-reset-newline
(lambda (st)
((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
;; MODIFIED FROM UPSTREAM fmt-c: c-expr on the scrutinee.
;; Upstream passes `val' straight to cat, which only works when
;; it is an atom -- anything else (a member access, a call) is
;; displayed as a raw s-expression instead of being rendered.
;; c-while and c-for already do (c-in-test (c-expr check)).
((cat "switch (" (c-in-expr (c-expr val)) ")" (c-open-brace st)
(c-indent/switch st)
(c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
(c-current-indent-string st) (c-close-brace st) fl)

2
sex-mode.el
View File

@@ -51,7 +51,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
;; Keywords
(list (concat "("
(regexp-opt '(
"begin"
"do"
"case"
"default"
"do"

4
sex-modules.scm
View File

@@ -71,9 +71,9 @@
((fn) ; replace with prototype
;; fn type name (arg-list) (body)
;; 1 2 3 4 - we need first 4
(cons (take (cdr form) 4) acc))
(cons (copy-form-source! form (take (cdr form) 4)) acc))
((define defmacro import include struct typedef union var)
(cons (cdr form) acc))
(cons (copy-form-source! form (cdr form)) acc))
(else (error "Pub what? " (cadr form)))))
(else acc)))

81
sexc.scm
View File

@@ -1,4 +1,5 @@
(import scheme
(scheme base) ; call/cc
brev-separate
(chicken base)
(chicken file)
@@ -15,8 +16,6 @@
reader
semen
srfi-1 ; list routines
srfi-13
tree
utils)
;;; Main function facilities
@@ -50,7 +49,14 @@
(pad padding) "If -E or -m options are provided, defaults to stdout")
(required #f)
(value #t)
(single-char #\o)))))
(single-char #\o))
(line-directives
,(fmt #f "How much #line information to emit: statement (default)," nl
(pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
(pad padding) "land on the right source line; `none' is for reading -C" nl
(pad padding) "output by eye")
(required #f)
(value #t)))))
(define (print-help)
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
@@ -66,11 +72,30 @@
(if arg (cdr arg)
default)))
;;; Everything before the first `--' is ours to parse, everything after
;;; is handed to the C compiler verbatim
(define (separator? a)
(string=? a "--"))
(define (args-before-separator argv)
(take-while (complement separator?) argv))
(define (args-after-separator argv)
(let ((tail (drop-while (complement separator?) argv)))
(if (null? tail)
(list)
(cdr tail))))
(define (get-rest-args args)
(cdr (assoc '@ args)))
(define (get-c-compiler-args args)
(filter (fn (string-prefix? "-" x)) (get-rest-args args)))
(define (line-directives-arg args)
(let ((v (get-arg args 'line-directives "statement")))
(cond ((equal? v "statement") 'statement)
((equal? v "toplevel") 'toplevel)
((equal? v "none") 'none)
(else (error "--line-directives must be statement, toplevel or none, got" v)))))
(define (get-input-file args)
(let ((rest-args (get-rest-args args)))
@@ -91,26 +116,27 @@
(map pp sex-forms)
(emit-c sex-forms)))))
(define (compile-to-file sex-forms output args)
(define (compile-to-file sex-forms output args cc-args)
(let ((compiler (or (get-arg args 'c-compiler #f)
(get-env-var "SEX_CC")
"cc"))
(out-file (if (eq? output 'default)
"a.out"
output)))
(call-with-values
(lambda ()
(process compiler (append (list "-o" out-file "-x" "c")
(if (get-arg args 'compile-object #f)
(list "-c")
(list))
(list "-") ; read stdin
(get-c-compiler-args args))))
(lambda (out-port in-port pid)
(with-output-to-port in-port
(lambda () (emit-c sex-forms)))
(close-output-port in-port)
(process-wait pid)))))
;; `process' hands back one record. Its port accessors are named
;; from the *child's* point of view, so `process-input-port' is the
;; port we write to: the C compiler's stdin.
(let* ((proc (process compiler (append (list "-o" out-file "-x" "c")
(if (get-arg args 'compile-object #f)
(list "-c")
(list))
(list "-") ; read stdin
cc-args)))
(cc-stdin (process-input-port proc)))
(with-output-to-port cc-stdin
(lambda () (emit-c sex-forms)))
(close-output-port cc-stdin)
(process-wait proc))))
(define (semantic-process-forms raw-forms input-source)
(if (eq? input-source 'stdin)
@@ -131,7 +157,9 @@
(typedef i64 int64-t)))
(define (main)
(let* ((raw-args (command-line-arguments))
(let* ((argv (command-line-arguments))
(raw-args (args-before-separator argv))
(cc-args (args-after-separator argv))
(args (getopt-long raw-args
opts-grammar))
(output (get-arg args 'output 'default))
@@ -155,9 +183,14 @@
(return #f))
(load-persistent-module-paths)
(if (eq? input 'stdin)
(sex-fmt-current-file "stdin")
(sex-fmt-current-file (to-absolute-pathname input)))
;; The file name in a #line directive now comes from the form's
;; own recorded location, so imported modules report themselves
;; rather than the unit that imported them
(sex-line-directives (line-directives-arg args))
(when (and (get-arg args 'emit-c #f)
(not (get-arg args 'line-directives #f)))
(sex-line-directives 'none))
(let* ((raw-forms (append prelude (read-raw-forms input)))
(sex-forms (semantic-process-forms raw-forms input)))
(if (or (get-arg args 'macro-expand #f)
@@ -165,4 +198,4 @@
;; Emit processed and macro-expanded sex code, or emit C code
(emit-c-or-sex sex-forms output args)
;; Compile file!
(compile-to-file sex-forms output args)))))))
(compile-to-file sex-forms output args cc-args)))))))

8
tests/Makefile
View File

@@ -6,7 +6,7 @@ MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
SEX_OBJ = $(MODULES:%=%.o)
TESTS = basic semen reader fmt-c-writer utils
TESTS = basic semen reader fmt-c-writer utils line-directives codegen args
TEST_SRCS = $(TESTS:%=%.scm)
sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
@@ -20,8 +20,8 @@ utils.o: utils.module.scm ../utils.scm
sex-macros.o: sex-macros.module.scm ../sex-macros.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
reader.o: reader.module.scm ../reader.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader
reader.o: reader.module.scm ../reader.scm utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
@@ -39,7 +39,7 @@ sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o re
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils
clean:
rm -f $(OBJ)
rm -f $(SEX_OBJ)
rm -f *.import.scm
rm -f *.link
rm -f sex-tests

55
tests/args.scm Normal file
View File

@@ -0,0 +1,55 @@
;;; Splitting the command line at `--'.
;;;
;;; getopt-long cannot do this: it consumes the separator and merges
;;; everything after it into `@' alongside the input file. So sexc
;;; splits the raw argv first, and only the head is parsed as options.
;;; Everything else reaches the C compiler exactly as written --
;;; including the words that do not start with a dash, which a previous
;;; leading-dash heuristic used to drop.
(import sexc)
(define full '("foo.sex" "-o" "bar" "--" "-framework" "OpenGL" "-Wall"))
(test-group "argument separator"
(test "options and input file stay with sexc"
'("foo.sex" "-o" "bar")
(args-before-separator full))
(test "the tail reaches the compiler verbatim"
'("-framework" "OpenGL" "-Wall")
(args-after-separator full))
;; The case that motivated this: `OpenGL' has no leading dash and was
;; silently dropped, leaving `-framework' to swallow whatever flag
;; came next.
(test "a word without a dash survives"
'("-framework" "OpenGL")
(args-after-separator '("x.sex" "--" "-framework" "OpenGL")))
(test "no separator means nothing for the compiler"
'()
(args-after-separator '("foo.sex" "-o" "bar")))
(test "no separator leaves every argument with sexc"
'("foo.sex" "-o" "bar")
(args-before-separator '("foo.sex" "-o" "bar")))
(test "a trailing separator is allowed"
'()
(args-after-separator '("foo.sex" "--")))
(test "a leading separator leaves no input file"
'()
(args-before-separator '("--" "-lm")))
;; Only the first `--' separates; a later one is an ordinary compiler
;; argument (ld takes several).
(test "only the first separator counts"
'("-Wl,--as-needed" "--" "-lm")
(args-after-separator '("x.sex" "--" "-Wl,--as-needed" "--" "-lm")))
(test "an empty command line is handled"
'()
(args-before-separator '())))

26
tests/basic.scm
View File

@@ -13,10 +13,18 @@
(test '_this_->_member_ (unkebabify '-this-->-member-))
(test '__->>> (unkebabify '--->>>))
;; Non-ASCII identifiers must survive intact. The `regex' egg's
;; string-substitute drops one trailing character per multi-byte
;; character, which renames things silently -- the C still compiles,
;; just under a different name than was written.
(test 'naïve_count (unkebabify 'naïve-count))
(test 'aï_b (unkebabify 'aï-b))
(test 'ïï (unkebabify 'ïï))
;; atom-to-fmt-c
(test '%fun (atom-to-fmt-c 'fn))
(test '%prototype (atom-to-fmt-c 'prototype))
(test '%block-begin (atom-to-fmt-c 'begin))
(test '%block-begin (atom-to-fmt-c 'do))
(test '%define (atom-to-fmt-c 'define))
(test '%pointer (atom-to-fmt-c 'pointer))
(test '%array (atom-to-fmt-c 'array))
@@ -28,6 +36,16 @@
(test 1 (atom-to-fmt-c 'true))
(test 0 (atom-to-fmt-c 'false))
;; make-field-access
(test 'a.b (make-field-access '(.b a)))
(test 'a.b.c (make-field-access '(.c a.b))))
;; dot-access -> %. member-access directive (kebab-converted operands)
(test '(%. a b) (walk-expr '(dot-access a b)))
(test '(%. a b c) (walk-expr '(dot-access a b c)))
(test '(%. a_b c) (walk-expr '(dot-access a-b c)))
;; comment -> %comment directive (rendered as /* ... */)
;; The reader eats only the `;' that introduced the line, so ";;; Foo"
;; arrives as ";; Foo"; and c-comment puts nothing between /* */ and
;; the text. Both are handled on the way out.
(test '(%comment " hi ") (walk-expr '(comment " hi")))
(test '(%comment " hi ") (process-toplevel-form '(comment " hi")))
(test '(%comment " Foo ") (walk-expr '(comment ";; Foo")))
(test '(%comment " Foo ") (walk-expr '(comment ";;; Foo "))))

156
tests/codegen.scm Normal file
View File

@@ -0,0 +1,156 @@
;;; Codegen details that are easy to get subtly wrong, and that the
;;; walk-* unit tests cannot see: they check the intermediate form we
;;; hand to fmt-c, not the C that fmt-c renders from it.
;;;
;;; Both cases below were found by writing an OpenGL example, not by
;;; the existing suite, because both need an operand shape that no
;;; earlier test program happened to use.
(import (chicken port)
(chicken string)
srfi-13
fmt-c-writer
reader
semen
utils)
(define (sex->c source)
"Compile SOURCE, a string of Sex, and return the generated C."
(let ((forms (with-input-from-string source
(lambda ()
(parameterize ((current-source-file "codegen.sex"))
(parse-all (current-input-port)))))))
(with-output-to-string
(lambda ()
(parameterize ((sex-line-directives 'none))
(emit-c (semen-process forms)))))))
(define (emits? source fragment)
(and (string-contains (sex->c source) fragment) #t))
(define (in-fn body)
(string-append "(fn f ((a int) (b int)) void " body ")"))
(test-group "codegen"
;; c-switch handed its scrutinee straight to `cat', which only works
;; when it is an atom. Anything else was displayed as a raw
;; s-expression: `switch ((%. e type))'.
(test-group "switch scrutinee"
(test-assert "member access"
(emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))"
"switch (e.type)"))
(test-assert "call"
(emits? (in-fn "(switch (g a) (case 1 (h)))")
"switch (g(a))"))
(test-assert "arithmetic"
(emits? (in-fn "(switch (+ a b) (case 1 (h)))")
"switch (a + b)")))
;; A cast binds tighter than every binary operator, so an operand
;; that is itself a binary expression has to be parenthesised --
;; otherwise the cast silently applies to the first operand only.
(test-group "cast precedence"
(test-assert "binary operand is parenthesised"
(emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))")
"(void *)(2 * sizeof(int))"))
(test-assert "subtraction operand is parenthesised"
(emits? (in-fn "(var f float (cast (- a b) float))")
"(float)(a - b)"))
;; ...but exactly once. The operand used to parenthesise itself
;; again inside the parens the cast had just added.
(test-assert "and not parenthesised twice"
(not (emits? (in-fn "(var f float (cast (- a b) float))")
"(float)((a - b))")))
;; Unary operands are already unary-expressions and must be left
;; alone, or every existing cast in the tree gains noise.
(test-assert "identifier is left bare"
(emits? (in-fn "(var f float (cast a float))")
"(float)a"))
(test-assert "address-of is left bare"
(emits? (in-fn "(var p (* int) (cast (& a) (* int)))")
"(int *)&a"))
(test-assert "sizeof is left bare"
(emits? (in-fn "(var n int (cast (sizeof int) int))")
"(int)sizeof(int)")))
;; A comment among a call's arguments used to become an argument,
;; and c-apply put a comma on each side of it -- which does not
;; compile. It is dropped, as in any other expression context.
(test-group "comments among arguments"
pkulev commented 2026-09-15 18:11:50 +02:00
Review
Copy Link

These tests are why the suite is green while the #16 sample still fails: they pin comments and casts, but not (| B A R) → B | A | R or (|| a b) → a || b. A couple of emits? cases here would have caught it.

These tests are why the suite is green while the #16 sample still fails: they pin comments and casts, but not `(| B A R)` → `B | A | R` or `(|| a b)` → `a || b`. A couple of `emits?` cases here would have caught it.
(test-assert "no stray comma"
(not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
(test-assert "the arguments survive"
(emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
;; The reader leaves the `;'s that introduced each line, and a run of
;; comment lines arrives as one form per line.
(test-group "comment rendering"
(test-assert "the markers are stripped"
(emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
(test-assert "so none survive into the C"
(not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
(test-assert "consecutive lines are packed into one comment"
(emits? "(fn f () void\n ;; first\n ;; second\n (g))"
"/* first\n second */"))
;; Packing compares locations rather than just looking for adjacent
;; comment forms, so a blank line still separates them.
(test-assert "a blank line keeps them apart"
(emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
;; A `;' comment is a form, so one written inside a construct with
;; positional slots used to land in a slot and shift everything after
;; it -- silently. In an `if' the comment became the then-arm and the
;; then-arm became an `else if' condition, and it still compiled.
;; Comments are now taken out of the slots and emitted just before the
;; statement; comments in a body stay where they were written.
(test-group "comments in positional slots"
(test-assert "an if arm is not shifted"
(not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
(test-assert "and both arms survive"
(emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
(test-assert "the comment survives too"
(emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
(test-assert "a for header is not shifted"
(emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
"for (int i = 0; i < 2; ++i)"))
(test-assert "a while condition is not shifted"
(emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
(test-assert "a var is not shifted"
(emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
(test-assert "a cast is not shifted"
(emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
;; Bodies are a statement sequence, so comments there stay put.
(test-assert "a comment in a body stays in the body"
(emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
"while (a < b) {")))
;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
;; no |symbol| syntax for them to collide with -- but fmt-c cannot
;; dispatch on a symbol whose name it cannot write in Scheme source,
;; so they used to fall through to the function-call path and emit
;; `|\||(a, b)'. The writer renames them to heads fmt-c spells with
;; a string.
(test-group "bitwise and logical operators"
(test-assert "bit-or"
(emits? (in-fn "(var x int (| a b))") "int x = a | b"))
(test-assert "logical or"
(emits? (in-fn "(var x int (|| a b))") "int x = a || b"))
(test-assert "or-assign"
(emits? (in-fn "(|= a b)") "a |= b"))
(test-assert "bit-and"
(emits? (in-fn "(var x int (& a b))") "int x = a & b"))
(test-assert "logical and"
(emits? (in-fn "(var x int (&& a b))") "int x = a && b"))
;; Precedence too: the operator reaches fmt-c as a string it looks
;; up, not as a symbol in its table
(test-assert "parenthesised where C needs it"
(emits? (in-fn "(var x int (& (| a b) a))") "(a | b) & a"))
(test-assert "and left alone where it does not"
(emits? (in-fn "(var x int (| a (& a b)))") "int x = a | a & b"))
;; The spelling from before they could be written directly
(test-assert "c-or is still accepted"
(emits? (in-fn "(var x int (c-or a b))") "a || b"))
(test-assert "c-bit-or is still accepted"
(emits? (in-fn "(var x int (c-bit-or a b))") "a | b"))))

242
tests/line-directives.scm Normal file
View File

@@ -0,0 +1,242 @@
;;; Source-line mapping.
;;;
;;; Every construct in the generated C must be attributed, through
;;; #line directives, to the source line of the Sex form it came from.
;;; That mapping is the whole basis of source-level debugging.
;;;
;;; It cannot be left to the C compiler's implicit line counting,
;;; because a Sex form and its C rendering may or may not occupy the
;;; same number of lines. A call written across four lines renders as
;;; one C line; a one-line `for' renders as a braced block of
;;; four. Either way every following line drifts, and the drift
;;; accumulates over a function body.
;;;
;;; The tests below pin one construct per statement kind. Each carries
;;; a unique numeric marker chosen so that it lands on the first C line
;;; that construct emits; the marker is then located in the fixture (to
;;; get the true source line) and in the C output (to get the line the
;;; directives claim). The two must agree.
(import (chicken port)
(chicken string)
srfi-1
srfi-13
fmt-c-writer
reader
semen
utils)
;;; ------------------------------------------------------------------
;;; Fixture. Line numbers are in the trailing comments; keep them
;;; correct when editing. Markers are distinct 3-digit integers, and no
;;; other literal in the fixture contains one as a substring.
(define fixture-lines
'("(include stdio.h)" ; 1
"" ; 2
"(struct pt" ; 3 multi-line toplevel
" ((x int)" ; 4
" (y int)))" ; 5
"" ; 6
"(enum color (red green blue))" ; 7
"" ; 8
"(typedef byte u8)" ; 9
"" ; 10
"(define MAXN 101)" ; 11
"" ; 12
"(var gvar int 102)" ; 13
"" ; 14
"(extern var evar int)" ; 15
"" ; 16
"(fn helper ((a int)) int)" ; 17 prototype
"" ; 18
"(pub fn main () int" ; 19
" (var mvar int 103)" ; 20
" (var p (struct pt))" ; 21
" (var arr [int 4])" ; 22
" (= (. p x) 104)" ; 23
" (+= mvar 105)" ; 24
" (++ mvar)" ; 25
" (= [arr 0] 106)" ; 26
" (putchar (+ 107" ; 27 form spanning 3 lines,
" mvar" ; 28 emitted as one C line:
" 0))" ; 29 everything after drifts
" (var aftercall int 108)" ; 30
" (if (< mvar 109)" ; 31
" (putchar 110))" ; 32
" (if (< mvar 111)" ; 33
" (putchar 112)" ; 34
" (putchar 113))" ; 35
" (while (< mvar 114)" ; 36
" (++ mvar))" ; 37
" (for (var i int 115)" ; 38
" (< i 116)" ; 39
" (++ i)" ; 40
" (continue))" ; 41
" (switch 117" ; 42
" (case 118" ; 43
" (putchar 119)" ; 44
" (break))" ; 45
" (default" ; 46
" (putchar 120)))" ; 47
" (do" ; 48
" (var bvar int 121)" ; 49
" (putchar bvar))" ; 50
" (goto done)" ; 51
" (: done)" ; 52
" (var svar u64 (sizeof (struct pt)))" ; 53
" (var cvar int (cast mvar int))" ; 54
" (return 122))" ; 55
))
(define fixture (string-intersperse fixture-lines "\n"))
;;; ------------------------------------------------------------------
;;; Pipeline and #line accounting
(define (compile-to-c source)
"Run reader -> semen -> writer on SOURCE, returning the generated C.
parse-all is called directly rather than through read-raw-forms so the
fixture can be given a file name: a location is (file . line), and the
file is what makes an imported module report itself rather than the unit
that imported it."
(let ((forms (with-input-from-string source
(lambda ()
(parameterize ((current-source-file "fixture.sex"))
(parse-all (current-input-port)))))))
(with-output-to-string
(lambda () (emit-c (semen-process forms))))))
(define (split-lines s)
(let loop ((i 0) (start 0) (acc (list)))
(cond
((= i (string-length s))
(reverse (if (> i start) (cons (substring s start i) acc) acc)))
((char=? (string-ref s i) #\newline)
(loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
(else (loop (+ i 1) start acc)))))
(define (directive-line text)
"The N of a `#line N \"file\"' directive, or #f if TEXT is not one."
(let ((t (string-trim text)))
(and (string-prefix? "#line " t)
(string->number (car (string-split (substring t 6) " "))))))
(define (directive-file text)
"The file name of a `#line N \"file\"' directive, or #f."
(let ((t (string-trim text)))
(and (string-prefix? "#line " t)
(let ((parts (string-split (substring t 6) " ")))
(and (pair? (cdr parts)) (cadr parts))))))
(define (attributed-lines c-source)
"Pair every non-directive C line with the source line it is
attributed to. `#line N' says the *next* physical line is N; each line
after that is one more. Lines before the first directive get #f."
(let loop ((lines (split-lines c-source)) (cur #f) (acc (list)))
(if (null? lines)
(reverse acc)
(cond
((directive-line (car lines))
=> (lambda (n) (loop (cdr lines) n acc)))
(else
(loop (cdr lines)
(and cur (+ cur 1))
(cons (cons (car lines) cur) acc)))))))
(define (sex-line token)
"1-based fixture line containing TOKEN."
(let loop ((lines fixture-lines) (n 1))
(cond ((null? lines) #f)
((string-contains (car lines) token) n)
(else (loop (cdr lines) (+ n 1))))))
(define (claimed-line attributed token)
"The source line the generated C attributes TOKEN to."
(let ((hit (find (lambda (p) (string-contains (car p) token)) attributed)))
(and hit (cdr hit))))
;;; ------------------------------------------------------------------
(define c-out (compile-to-c fixture))
(define attributed (attributed-lines c-out))
;;; MAPS checks a construct found under the same token on both sides.
;;; MAPS/TOKENS is for constructs that are spelled differently in Sex
;;; and in C (`(break)' -> `break;', `(: done)' -> `done:').
(define-syntax maps
(syntax-rules ()
((maps name token)
(test name (sex-line token) (claimed-line attributed token)))))
(define-syntax maps/tokens
(syntax-rules ()
((maps/tokens name sex-token c-token)
(test name (sex-line sex-token) (claimed-line attributed c-token)))))
(test-group "line-directives"
;; Toplevel forms
(test-group "toplevel"
(maps/tokens "include" "(include stdio.h)" "#include")
(maps/tokens "struct" "(struct pt" "struct pt {")
(maps/tokens "enum" "(enum color" "enum color {")
(maps/tokens "typedef" "(typedef byte u8)" "typedef u8 byte;")
(maps "define" "101")
(maps "global var" "102")
(maps/tokens "extern var" "(extern var evar" "extern int evar")
(maps/tokens "prototype" "(fn helper" "int helper (int a)")
(maps/tokens "function" "(pub fn main" "int main (void)"))
;; Declarations and expression statements
(test-group "statements"
(maps "var decl" "103")
(maps "member assignment" "104")
(maps "compound assignment" "105")
(maps/tokens "increment" "(++ mvar)" "++mvar;")
(maps "array assignment" "106")
;; The point of the whole exercise: a call spread over three source
;; lines collapses to one C line, so the statement after it must be
;; re-anchored or it is reported two lines too early. The call
;; itself anchors to the line it *starts* on, which is where a
;; debugger should report it.
(maps "multi-line call" "107")
(maps "statement after it" "108"))
;; Control flow
(test-group "control flow"
(maps "if" "109")
(maps "if body" "110")
(maps "if/else" "111")
(maps "then branch" "112")
(maps "else branch" "113")
(maps "while" "114")
(maps "for" "115")
(maps/tokens "continue" "(continue)" "continue;")
(maps "switch" "117")
;; The `case 118:' label line itself is deliberately not pinned.
;; c-switch requires every clause to be a case/default form and
;; rejects anything else, so no anchor can be placed between
;; clauses. The clause *bodies* are anchored from inside, which is
;; what matters -- a label is not a statement a debugger stops on.
(maps "case body" "119")
(maps/tokens "break" "(break)" "break;")
(maps "default body" "120")
(maps "block" "121")
(maps/tokens "goto" "(goto done)" "goto done;")
(maps/tokens "label" "(: done)" "done:")
(maps "return" "122"))
;; Expressions that are their own statement
(test-group "expressions"
(maps/tokens "sizeof" "(var svar" "sizeof")
(maps/tokens "cast" "(var cvar" "(int)mvar"))
;; A location is (file . line); every directive must name the file the
;; form was read from.
(test-group "file name"
(test "every directive names the fixture"
(list "\"fixture.sex\"")
(delete-duplicates
(filter values (map directive-file (split-lines c-out)))))))

23
tests/reader.scm
View File

@@ -15,4 +15,27 @@
(reader-test '((¤)) "[]")
(reader-test '((¤ (¤))) "[[]]")
(reader-test '((¤ (¤ const char))) "[[const char]]")
;; leading `.' becomes the dot-access operator
(reader-test '((dot-access obj field)) "(. obj field)")
(reader-test '((dot-access obj method a b)) "(. obj method a b)")
(reader-test '((dot-access a b)) "(. a b)")
;; nested leading dot
(reader-test '((foo (dot-access a b))) "(foo (. a b))")
;; dotted pairs are preserved (only a *leading* dot is special)
(reader-test '((a . b)) "(a . b)")
(reader-test '((a b . c)) "(a b . c)")
(reader-test '((quote (a . b))) "'(a . b)")
;; a `.'-prefixed symbol is an ordinary symbol, not dot-access
(reader-test '((.field obj)) "(.field obj)")
;; `;' comments are preserved as (comment "...") forms
(reader-test '((comment " hi")) "; hi")
(reader-test '((comment ";; Prototypes")) ";;; Prototypes")
(reader-test '((foo (comment " c") bar)) "(foo ; c\n bar)")
;; a trailing top-level comment is its own form
(reader-test '((a b) (comment " t")) "(a b) ; t")
;; a `;' inside a string is not a comment
(reader-test '("a;b") "\"a;b\"")
)

3
tests/run.scm
View File

@@ -6,6 +6,9 @@
(include "reader.scm")
(include "fmt-c-writer.scm")
(include "utils.scm")
(include "line-directives.scm")
(include "codegen.scm")
(include "args.scm")
;;; Should be the last in the test suite
(test-exit)

13
tests/sex-programs/comments.sex Normal file
View File

@@ -0,0 +1,13 @@
(input)
(output "start" "end")
(return 0)
;;; A top-level comment, preserved into the generated C.
(include stdio.h)
;; Another top-level comment, right before the function.
(pub fn main () int
;; a comment in statement position
(puts "start")
(puts "end") ; a trailing comment after a statement
(return 0))

2
tests/sex-programs/list-macros.sex
View File

@@ -39,7 +39,7 @@
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
(let ((list-var-2 (cat list-var '-2)))
`(begin
`(do
(var ,list-var-2 (* ,list-type) ,list-var)
(var ,elt-var ,elt-type (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)

24
tests/sex-programs/unicode.sex Normal file
View File

@@ -0,0 +1,24 @@
(input)
(output "café 日本語 🍺" "café1" "naïve: 3")
(return 0)
;;; Non-ASCII string literals and identifiers.
;;;
;;; Two things are pinned here. First, a character outside printable
;;; ASCII must reach the C compiler as the UTF-8 bytes it was written
;;; as. Octal escapes are used because C's \x escape swallows every
;;; following hex digit: "café1" is the case that catches it, since a
;;; hex escape would run "\xc3\xa9" into the "1" and produce a value out
;;; of range for a char. Second, a kebab-case identifier containing
;;; non-ASCII characters must survive unkebabify intact -- getting this
;;; wrong truncates the name silently, and the program still compiles
;;; and runs, just under a different name than the one written.
(include stdio.h)
(pub fn main () int
(puts "café 日本語 🍺")
(puts "café1")
(var naïve-count int 3)
(printf "naïve: %d\n" naïve-count)
(return 0))

4
tests/sexc.module.scm
View File

@@ -1 +1,3 @@
(module sexc (main) "../sexc.scm")
(module sexc
*
"../sexc.scm")

22
tools/sextest/Makefile
View File

@@ -1,5 +1,23 @@
CHICKEN_C = csc
CSC_FLAGS += -K prefix -static
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
sextest: sextest.scm
$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest
ROOT = ../..
# sextest reuses sexc's reader (and its utils dependency) instead of
# duplicating the S-expression reader. The module wrappers here include
# the shared sources from the project root.
sextest: sextest.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest -link reader,utils
utils.o: utils.module.scm $(ROOT)/utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
reader.o: reader.module.scm $(ROOT)/reader.scm utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
clean:
rm -f *.o *.import.scm *.link sextest
.PHONY: clean

3
tools/sextest/reader.module.scm Normal file
View File

@@ -0,0 +1,3 @@
(module reader (read-from-file
read-raw-forms)
"../../reader.scm")

103
tools/sextest/sextest.scm
View File

@@ -7,72 +7,11 @@
(chicken port)
(chicken process)
(chicken process-context)
(chicken read-syntax)
(chicken syntax)
fmt
getopt-long
reader ; read-raw-forms, shared with sexc
srfi-1)
(define-syntax prog1
(syntax-rules ()
((prog1 form . forms)
(let ((res form))
(begin . forms)
res))))
(define-syntax with-directory
(syntax-rules ()
((with-directory path form . forms)
(let ((current-dir (current-directory)))
(set-working-directory path)
(prog1
(begin form . forms)
(change-directory current-dir))))))
(define (set-working-directory file)
(change-directory
(normalize-pathname
(if (absolute-pathname? file)
(pathname-directory file)
(make-absolute-pathname
(current-directory)
(pathname-directory file))))))
;;; TODO: use sexc reader code i.e. link with sex reader
(define open-bracket-counter (make-parameter 0))
(define (read-raw-forms input-source)
(let ((bracket-end (gensym)))
(set-read-syntax!
#\]
(lambda (port)
(when (= 0 (open-bracket-counter))
(error "Unmatched closing bracket"))
(open-bracket-counter (- (open-bracket-counter) 1))
bracket-end))
(set-read-syntax!
#\[
(lambda (port)
(open-bracket-counter (+ (open-bracket-counter) 1))
(let loop ((r (read port))
(acc (list)))
(if (eq? r bracket-end)
(cons '¤ (reverse acc))
(loop (read port)
(cons r acc)))))))
(read-from-file input-source))
(define (read-from-file file)
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list))))))
(define (read-forms acc)
(let ((r (read-with-source-info (current-input-port))))
(if (eof-object? r) (reverse acc)
(read-forms (cons r acc)))))
(define (print-help)
(fmt #t "Usage: sextest [options] filename" nl
"Options:" nl
@@ -99,27 +38,25 @@
(get-environment-variable "SEXC")
"sexc"))
(compiled-file (create-temporary-file)))
(call-with-values
(fn
(process compiler
(append (list "-o" compiled-file)
flags)))
(lambda (out-port in-port pid)
(with-output-to-port in-port
(fn (map (fn (fmt #t x)) src)))
(close-output-port in-port)
(call-with-values
(fn (process-wait pid))
(lambda (pid exited retcode)
(if (= 0 retcode)
compiled-file
#f)))))))
;; `process' returns one record; `process-input-port' is named from
;; the child's side, so it is the port we write to.
(let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
(sexc-stdin (process-input-port proc)))
(with-output-to-port sexc-stdin
(fn (map (fn (fmt #t x)) src)))
(close-output-port sexc-stdin)
(call-with-values
(fn (process-wait proc))
(lambda (pid exited retcode)
(if (= 0 retcode)
compiled-file
#f))))))
(define (run-and-check file in out ret)
(call-with-values
(fn (process file))
(lambda (out-port in-port pid)
(let* ((proc (process file))
(out-port (process-output-port proc)) ; the program's stdout
(in-port (process-input-port proc))) ; the program's stdin
(let ()
(when in
(with-output-to-port in-port
(fn (map (fn (fmt #t x))
@@ -139,7 +76,7 @@
;; TODO: what if the program hangs
;; we need some kind of timeout mechanism
(fn
(process-wait pid))
(process-wait proc))
(lambda (pid exited retcode)
retcode))))
(and
@@ -198,7 +135,7 @@
(print-help)
(exit 1))
(unless
(foldl and
(foldl (lambda (a b) (and a b))
#t
(map (fn (process-test-file (assoc 'sexc args) x))
(cdr (assoc '@ args))))

17
tools/sextest/utils.module.scm Normal file
View File

@@ -0,0 +1,17 @@
(module utils
(get-env-var
set-working-directory
to-absolute-pathname
list-split
list-join
recons
current-source-file
set-form-source!
form-source
form-file
form-line
copy-form-source!
stamp-form-source!
with-directory
)
"../../utils.scm")

7
utils.module.scm
View File

@@ -5,6 +5,13 @@
list-split
list-join
recons
current-source-file
set-form-source!
form-source
form-file
form-line
copy-form-source!
stamp-form-source!
with-directory
)
"utils.scm")

55
utils.scm
View File

@@ -1,9 +1,11 @@
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken pathname)
(chicken process-context)
srfi-1)
srfi-1
srfi-69)
(define-syntax prog1
(syntax-rules ()
@@ -63,4 +65,53 @@
(if (and (eq? new-car (car old-cons))
(eq? new-cdr (cdr old-cons)))
old-cons
(cons new-car new-cdr)))
;; A rebuilt cell is still the same source form, so it keeps the
;; same location
(copy-form-source! old-cons (cons new-car new-cdr))))
;;; Source-location map.
;;; Our hand-written reader records the source location of each form
;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's
;;; read-with-source-info / get-line-number, which only works when forms
;;; are produced by the built-in `read'.
;;;
;;; A location is (file . line). The file matters because imported
;;; modules paste their public forms into the current unit: those forms
;;; originate in another file and must be reported as such
(define +form-sources+ (make-hash-table eq?))
;;; The file `parse-all' is currently reading. Bound by the reader
(define current-source-file (make-parameter "<unknown>"))
(define (set-form-source! form file line)
(hash-table-set! +form-sources+ form (cons file line)))
(define (form-source form)
(hash-table-ref/default +form-sources+ form #f))
(define (form-file form)
(let ((src (form-source form)))
(and src (car src))))
(define (form-line form)
(let ((src (form-source form)))
(and src (cdr src))))
(define (copy-form-source! from to)
"Give TO the location of FROM, if FROM has one. Returns TO, so it can
wrap a form-building expression."
(let ((src (form-source from)))
(when (and src (pair? to))
(hash-table-set! +form-sources+ to src)))
to)
(define (stamp-form-source! form src)
"Give FORM and every subform that has none the location SRC. Used for
macro expansions, which inherit the location of the call site the way a
cpp macro does. Forms that already have a location keep it."
(when (and src (pair? form))
(unless (form-source form)
(hash-table-set! +form-sources+ form src))
(stamp-form-source! (car form) src)
(stamp-form-source! (cdr form) src))
form)