diff --git a/Makefile b/Makefile index bf72a2e..0f64ddf 100644 --- a/Makefile +++ b/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) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 9375c62..48f4a31 100644 --- a/fmt-c-writer.scm +++ b/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)) diff --git a/reader.scm b/reader.scm index 6ec4545..17ed66a 100644 --- a/reader.scm +++ b/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 ""). 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))) diff --git a/semen.scm b/semen.scm index 7b1c748..67c6e1c 100644 --- a/semen.scm +++ b/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 diff --git a/tests/Makefile b/tests/Makefile index 0f07326..414cc32 100644 --- a/tests/Makefile +++ b/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 diff --git a/tests/basic.scm b/tests/basic.scm index 0f588df..42ff15d 100644 --- a/tests/basic.scm +++ b/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")))) diff --git a/tests/reader.scm b/tests/reader.scm index c626c66..bb709e7 100644 --- a/tests/reader.scm +++ b/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\"") ) diff --git a/utils.module.scm b/utils.module.scm index 07d8538..8113c67 100644 --- a/utils.module.scm +++ b/utils.module.scm @@ -5,6 +5,8 @@ list-split list-join recons + set-form-line! + form-line with-directory ) "utils.scm") diff --git a/utils.scm b/utils.scm index c8154fc..7e51b09 100644 --- a/utils.scm +++ b/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))