support || | |= operators, since we now have our own parser

Shorter and doesn't imply existence of `end'

.github/workflows/build.yaml

@@ -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

Makefile

@@ -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
@@ -49,12 +49,24 @@ fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
 sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
 	$(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
 
+# Unit testing
 sex-tests:
-	$(MAKE) -C tests sex-tests
+	$(MAKE) -C ./tests sex-tests
 	cp ./tests/sex-tests ./
 
+sextest:
+	$(MAKE) -C ./tools/sextest sextest
+	cp ./tools/sextest/sextest .
+
+SEX_TEST_PROGRAMS = hello-world lists comments unicode
+
+run-tests: sexc sex-tests sextest
+	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)
+
 clean:
 	rm -f $(OBJ) main.o
 	rm -f *.import.scm
 	rm -f *.link
-	rm -f sexc sex-tests
+	rm -f sexc sex-tests sextest
+
+.PHONY: clean run-tests sex-tests sextest

Readme.org

@@ -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
 

dependencies.txt

@@ -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

example/list.sex

@@ -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)

fmt-c-writer.module.scm

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

fmt-c-writer.scm

@@ -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
+;;; 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))
 
-(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 ")
+                       " ")))
+
+;;; 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)
+     (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)))

reader.scm

@@ -1,62 +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 (read-bracket port)
-  (let loop ((c (read-char port))
-             (str (string)))
-    (cond ((char=? c #\])
-           (cons '¤
-                 (with-input-from-string str
-                   (fn (port-map identity read)))))
-          ((char=? c #\[)
-           (loop port (conc )))
-          (else
-           (loop (read-char port)
-                 (conc str c))))))
-
-(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)))

semen.scm

@@ -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

sex-fmt-c.scm

@@ -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)

sex-mode.el

@@ -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"

sex-modules.scm

@@ -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)))
 

sexc.scm

@@ -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,7 +183,14 @@
          (return #f))
        (load-persistent-module-paths)
 
-       (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)
@@ -163,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)))))))

tests/Makefile

@@ -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

tests/args.scm

@@ -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 '())))

tests/basic.scm

@@ -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   "))))

tests/codegen.scm

@@ -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"
+    (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"))))

tests/line-directives.scm

@@ -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)))))))

tests/reader.scm

@@ -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\"")
 )

tests/run.scm

@@ -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)

tests/sex-programs/comments.sex

@@ -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))

tests/sex-programs/hello-world.sex

@@ -0,0 +1,13 @@
+(input "Sextest")
+(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
+(return 255)
+
+(include stdio.h)
+
+(pub fn main ((argc int) (argv  [* const char])) int
+  (puts "Hello from Sex!")
+  (var name [char 512])
+  (puts "What is your name?")
+  (scanf "%s" (cast (& name) (* char)))
+  (printf "Hello, %s!\n" name)
+  (return 255))

tests/sex-programs/list-macros.sex

@@ -0,0 +1,48 @@
+(pub defmacro (list-T type)
+  (let ((list-type (cat 'list- type)))
+    `(struct ,list-type
+       ((value ,type)
+        (next (* struct ,list-type))))))
+
+(pub defmacro (make-list-T type is-public?)
+  (let ((list-type (list 'struct (cat 'list- type)))
+        (fn-name (cat 'make-list- type)))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
+      (var list (* ,list-type) (cast  (malloc (sizeof ,list-type)) (* ,list-type)))
+      (= (-> list next) NULL)
+      (return list))))
+
+(pub defmacro (add-value-list-T type is-public?)
+  (let ((list-type (list 'struct (cat 'list- type)))
+        (fn-name (cat 'add-value-list- type)))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
+      (while (!= (-> list next) NULL)
+        (= list (-> list next)))
+      (= (-> list next) (,(cat 'make-list- type)))
+      (= (-> list value) value))))
+
+(pub defmacro (length-list-T type is-public?)
+  (let ((fn-name (cat 'length-list- type))
+        (list-type (list 'struct (cat 'list- type))))
+    `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
+      (var n size-t 0)
+      (while (!= (-> list next) NULL)
+        (= list (-> list next))
+        (++ n))
+      (return n))))
+
+(pub defmacro (is-empty-list-T type is-public?)
+  `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
+    ((list ,(list '* 'struct (cat 'list- type))))
+    bool
+    (return (== (-> list next) NULL))))
+
+(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
+  (let ((list-var-2 (cat list-var '-2)))
+    `(do
+      (var ,list-var-2 (* ,list-type) ,list-var)
+      (var ,elt-var ,elt-type (-> ,list-var-2 value))
+      (while (!= (-> ,list-var-2 next) NULL)
+        ,what-do
+        (= ,list-var-2 (-> ,list-var-2 next))
+        (= ,elt-var (-> ,list-var-2 value))))))

tests/sex-programs/lists.sex

@@ -0,0 +1,50 @@
+(input)
+(output "Size of the list: 0"
+        "Size of the list: 2"
+        "3 4 "
+        "Size of the list: 2")
+(return 0)
+
+(include stdlib.h)
+(include stddef.h)
+(include stdio.h)
+
+(import list-macros)
+
+(struct foo
+  ((a-field float)
+   (b int)
+   (c (* const char))
+   (not (fn ((val bool)) bool))))
+
+(var f (struct foo))
+
+(list-T int)
+(make-list-T int #f)
+(add-value-list-T int #f)
+(length-list-T int #f)
+(is-empty-list-T int #f)
+
+(extern fn puk ((a int) (b float)) void)
+(pub fn baz () bool
+  (return true))
+
+(extern var i int)
+(var j int)
+(pub var k int)
+
+(pub fn main () int
+     (var l (* struct list-int) (make-list-int))
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (add-value-list-int l 3)
+     (add-value-list-int l 4)
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (list-for-each (struct list-int) l int v
+       (printf "%d " v))
+     (printf "\n")
+     (printf "Size of the list: %lu\n" (length-list-int l))
+     (return 0))
+
+(pub fn print-list ((l (* const struct list-int))) void
+     (list-for-each (const struct list-int) l int v (printf "%d " v))
+     (printf "\n"))

tests/sex-programs/unicode.sex

@@ -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))

tests/sexc.module.scm

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

tools/sextest/Makefile

@@ -0,0 +1,23 @@
+CHICKEN_C = csc
+CSC_FLAGS += -K prefix -static
+MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
+
+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

tools/sextest/README.org

@@ -0,0 +1,26 @@
+* Sextest
+A tool for testing Sex compiler by using test programs.
+The tools compiles test programs, then runs with provided
+input, checking the output and return code.
+
+* Test format
+The test program is just a regular Sex program, which may contain
+additional toplevel forms, to define compilation parameters, input to
+the program, and expected output and return code. Default value for
+compilation, input and output is an empty strings. For the return code
+it is 0.
+
+* Example
+some-test.sex:
+#+begin_src
+(compilation "-- -O2")
+(input "")
+(output "Hello world!")
+(return 123)
+
+(include stdio.h)
+
+(pub fn main () int
+  (puts "Hello World!")
+  (return 123))
+#+end_src

tools/sextest/hello-sextest.sex

@@ -0,0 +1,13 @@
+(input "Sextest")
+(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
+(return 255)
+
+(include stdio.h)
+
+(pub fn main ((argc int) (argv  [* const char])) int
+  (puts "Hello from Sex!")
+  (var name [char 512])
+  (puts "What is your name?")
+  (scanf "%s" (cast (& name) (* char)))
+  (printf "Hello, %s!\n" name)
+  (return 255))

tools/sextest/reader.module.scm

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

tools/sextest/sextest.scm

@@ -0,0 +1,148 @@
+(import scheme
+        brev-separate
+        (chicken base)
+        (chicken file)
+        (chicken io)
+        (chicken pathname)
+        (chicken port)
+        (chicken process)
+        (chicken process-context)
+        fmt
+        getopt-long
+        reader                          ; read-raw-forms, shared with sexc
+        srfi-1)
+
+(define (print-help)
+  (fmt #t "Usage: sextest [options] filename" nl
+       "Options:" nl
+       (usage opts-grammar) nl))
+
+(define (process-file target-path)
+  (let ((contents (read-raw-forms target-path)))
+    (foldl (lambda (acc elt)
+             (case (car elt)
+               ((compilation input output return)
+                (cons
+                 (append (car acc) (list elt))
+                 (cdr acc)))
+               (else
+                (cons
+                 (car acc)
+                 (append (cdr acc) (list elt))))))
+           (cons (list) (list))
+           contents)))
+
+(define (compile src flags sexc)
+  (let ((compiler (or
+                   (and sexc (cdr sexc))
+                   (get-environment-variable "SEXC")
+                   "sexc"))
+        (compiled-file (create-temporary-file)))
+    ;; `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)
+  (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))
+                   (cdr in))))
+        (close-output-port in-port))
+      (let ((out-lines
+             (with-input-from-port out-port
+               (fn
+                (let loop ((line (read-line))
+                           (lines (list)))
+                  (if (eof-object? line)
+                      (reverse lines)
+                      (loop (read-line)
+                            (cons line lines)))))))
+            (ret-code
+             (call-with-values
+                 ;; TODO: what if the program hangs
+                 ;; we need some kind of timeout mechanism
+                 (fn
+                  (process-wait proc))
+               (lambda (pid exited retcode)
+                 retcode))))
+        (and
+         (if (not (= ret-code (cadr ret)))
+             (begin
+               (fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
+               #f)
+             #t)
+
+         (if (not (equal? out-lines (cdr out)))
+             (begin
+               (fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
+               #f)
+             #t))))))
+
+(define opts-grammar
+  `((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
+                (pad 26) "environment variable, ot if it's empty, to sexc" nl )
+          (required #f)
+          (value #t))
+    (help "Show this help"
+          (required #f)
+          (value #f)
+          (single-char #\h))))
+
+(define (process-test-file sexc path)
+  (set-environment-variable! "SEX_MODULE_PATH"
+                             (normalize-pathname (make-absolute-pathname
+                                                  (current-directory)
+                                                  (pathname-directory path))))
+  (let* ((settings-and-src (process-file path))
+         (settings (car settings-and-src))
+         (src (cdr settings-and-src))
+         (compiled-file (compile src (assoc 'compile settings) sexc)))
+    (if (not compiled-file)
+        (begin (fmt #t "Failed to compile " path nl)
+               #f)
+        (if (run-and-check
+             compiled-file
+             (assoc 'input settings)
+             (assoc 'output settings)
+             (assoc 'return settings))
+            (begin (fmt #t ".")
+                   #t)
+            (begin (fmt #t ",")
+                   #f)))))
+
+(define (main)
+  (let ((args (getopt-long (command-line-arguments)
+                           opts-grammar)))
+    (when (assoc 'help args)
+      (print-help)
+      (exit 0))
+    (when (null? (cdr (assoc '@ args)))
+      (fmt #t "Missing target file" nl)
+      (print-help)
+      (exit 1))
+    (unless
+        (foldl (lambda (a b) (and a b))
+               #t
+               (map (fn (process-test-file (assoc 'sexc args) x))
+                    (cdr (assoc '@ args))))
+      ;; TODO: add more verbose and human readable output and reporting
+      (fmt #t nl)
+      (exit 2))
+    (fmt #t nl)
+    (exit 0)))
+
+(main)

tools/sextest/utils.module.scm

@@ -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")

utils.module.scm

@@ -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")

utils.scm

@@ -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)