replace Scheme read with our tokenizer and parser

Also implement . as field access operator and preserve ;-comments in
generated C

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
@@ -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
 
 run-tests: sexc sex-tests sextest
 	./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex)

fmt-c-writer.scm

@@ -53,22 +53,14 @@
       (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)))
 
 (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,8 +68,11 @@
       (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) (cons '%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)
@@ -184,7 +179,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 +192,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 +246,7 @@
 
 (define (process-toplevel-form form)
   (match form
+    (('comment . text) (cons '%comment text))
     (('fn . _) (list 'static (walk-function form)))
     (('var . _) (list 'static (walk-var form)))
     (('extern . rest) (walk-extern rest))
@@ -262,10 +258,9 @@
     (else (walk-expr form))))
 
 (define (get-line-num form)
-  (let ((num (get-line-number form)))
-    (if (string? num)
-        (last (string-split num ":"))
-        #f)))
+  ;; Source line recorded by our reader (see utils' form-line), or #f
+  ;; for forms the reader did not produce (prelude, macro expansions).
+  (form-line form))
 
 (define sex-fmt-current-file (make-parameter "/dev/null"))
 (define sex-fmt-line-num (make-parameter 0))

reader.scm

@@ -1,49 +1,265 @@
+;;; 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
   (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))
+
+(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 #\() (get-ch port) (read-list port close-paren))
+     ((char=? c #\[) (get-ch port) (cons '¤ (read-list port close-bracket)))
+     ((char=? c #\)) (get-ch port) close-paren)
+     ((char=? c #\]) (get-ch port) close-bracket)
+     ((char=? c #\;) (read-comment port))
+     ((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 ((line (current-line))
+            (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
+          (when (pair? tok)
+            (set-form-line! tok line))
+          (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))
+      (lambda () (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))
+      (parse-all (current-input-port))
       (read-from-file input-source)))

semen.scm

@@ -68,6 +68,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))
@@ -138,8 +139,25 @@
 
 ;;; 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)))
+    (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

tests/Makefile

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

tests/basic.scm

@@ -28,6 +28,11 @@
   (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 /* ... */)
+  (test '(%comment " hi") (walk-expr '(comment " hi")))
+  (test '(%comment " hi") (process-toplevel-form '(comment " hi"))))

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

utils.module.scm

@@ -5,6 +5,8 @@
      list-split
      list-join
      recons
+     set-form-line!
+     form-line
      with-directory
      )
   "utils.scm")

utils.scm

@@ -3,7 +3,8 @@
   (chicken base)
   (chicken pathname)
   (chicken process-context)
-  srfi-1)
+  srfi-1
+  srfi-69)
 
 (define-syntax prog1
   (syntax-rules ()
@@ -64,3 +65,18 @@
            (eq? new-cdr (cdr old-cons)))
       old-cons
       (cons new-car new-cdr)))
+
+;;; Source-location map.
+;;; Our hand-written reader records the source line 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'. The key survives
+;;; semantic processing because `recons' preserves the original cons
+;;; cell for forms it does not structurally change.
+(define +form-lines+ (make-hash-table eq?))
+
+(define (set-form-line! form line)
+  (hash-table-set! +form-lines+ form line))
+
+(define (form-line form)
+  (hash-table-ref/default +form-lines+ form #f))