diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 90b3486..563ef6b 100644 --- a/.github/workflows/build.yaml +++ b/.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 diff --git a/Makefile b/Makefile index bf72a2e..a8a55c5 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 unicode run-tests: sexc sex-tests sextest ./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) @@ -69,4 +69,4 @@ clean: rm -f *.link rm -f sexc sex-tests sextest -.PHONY: clean run-tests +.PHONY: clean run-tests sex-tests sextest diff --git a/Readme.org b/Readme.org index fc041b4..ada2d65 100644 --- a/Readme.org +++ b/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 diff --git a/dependencies.txt b/dependencies.txt index e341eb9..fbd17eb 100644 --- a/dependencies.txt +++ b/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 diff --git a/example/list.sex b/example/list.sex index 8355f73..809ad68 100644 --- a/example/list.sex +++ b/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) diff --git a/fmt-c-writer.module.scm b/fmt-c-writer.module.scm index e7e57fe..5500894 100644 --- a/fmt-c-writer.module.scm +++ b/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") diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 9375c62..6733687 100644 --- a/fmt-c-writer.scm +++ b/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))) diff --git a/reader.scm b/reader.scm index 6ec4545..e902114 100644 --- a/reader.scm +++ b/reader.scm @@ -1,49 +1,284 @@ +;;; Sex reader +;;; +;;; A hand-written tokenizer + recursive-descent parser that replaces +;;; CHICKEN's built-in `read'. We need our own reader because the +;;; features Sex requires cannot be expressed on top of `read': +;;; - [ ... ] array/pointer sugar, read as (¤ ...) +;;; - a leading `.' rewritten to the symbol `dot-access' +;;; - `;' comments preserved as (comment "...") forms, so they can be +;;; re-emitted into the generated C (keeping the source mapping) +;;; It also records the source location of every form it reads (see +;;; utils' form-source), so the C writer can emit #line directives. + (import scheme + (scheme base) ; make-parameter (chicken base) - (chicken io) (chicken pathname) - (chicken port) - (chicken read-syntax) - (chicken string) - (chicken syntax) - brev-separate - fmt) + utils) -(import-syntax utils) +;;; Sentinels for structural tokens +(define close-paren (list '%close-paren)) +(define close-bracket (list '%close-bracket)) +(define dot-token (list '%dot)) -(define (read-forms acc) - (let ((r (read-with-source-info (current-input-port)))) - (if (eof-object? r) (reverse acc) - (read-forms (cons r acc))))) +;;; Current source line. Tracked as characters are consumed +(define current-line (make-parameter 1)) +(define (get-ch port) + (let ((c (read-char port))) + (when (and (char? c) (char=? c #\newline)) + (current-line (+ 1 (current-line)))) + c)) + +(define (peek port) + (peek-char port)) + +;;; Record where a form started. Called with the line of the opening +;;; delimiter, sampled before it is consumed +(define (stamp form line) + (when (pair? form) + (set-form-source! form (current-source-file) line)) + form) + +(define (delimiter? c) + (or (eof-object? c) + (char-whitespace? c) + (memv c '(#\( #\) #\[ #\] #\" #\; #\' #\` #\,)))) + +;;; Skip whitespace. `;' comments are NOT skipped here: they are read +;;; as (comment "...") forms by the tokenizer. Block comments (#| |#) +;;; and datum comments (#;) are discarded in the tokenizer's `#' +;;; dispatch, since `#' also introduces real data (#t, #f, #\c, #(...)) +(define (skip-whitespace port) + (let ((c (peek port))) + (cond + ((eof-object? c) #t) + ((char-whitespace? c) (get-ch port) (skip-whitespace port)) + (else #t)))) + +;;; A `;' comment, read as (comment ""). The leading `;' +;;; is consumed; the newline is left in the stream so line tracking and +;;; the surrounding parser see it normally +(define (read-comment port) + (get-ch port) ; consume the leading ; + (let loop ((chars (list))) + (let ((c (peek port))) + (if (or (eof-object? c) (char=? c #\newline)) + (list 'comment (list->string (reverse chars))) + (begin (get-ch port) + (loop (cons c chars))))))) + +;;; Read the next token: a datum, one of the structural sentinels +;;; (close-paren / close-bracket / dot-token), or the eof-object +(define (next-token port) + (skip-whitespace port) + (let ((c (peek port))) + (cond + ((eof-object? c) c) + ((char=? c #\() + (let ((line (current-line))) + (get-ch port) + (stamp (read-list port close-paren) line))) + ((char=? c #\[) + (let ((line (current-line))) + (get-ch port) + (stamp (cons '¤ (read-list port close-bracket)) line))) + ((char=? c #\)) (get-ch port) close-paren) + ((char=? c #\]) (get-ch port) close-bracket) + ((char=? c #\;) + (let ((line (current-line))) + (stamp (read-comment port) line))) + ((char=? c #\") (read-string-lit port)) + ((char=? c #\') (get-ch port) (list 'quote (read-datum port))) + ((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port))) + ((char=? c #\,) + (get-ch port) + (if (eqv? (peek port) #\@) + (begin (get-ch port) (list 'unquote-splicing (read-datum port))) + (list 'unquote (read-datum port)))) + ((char=? c #\#) (get-ch port) (read-hash port)) + (else (read-atom port))))) + +;;; Like next-token, but a full datum is required: the structural +;;; sentinels and eof are errors here (e.g. after a quote or `.') +(define (read-datum port) + (let ((tok (next-token port))) + (cond + ((eof-object? tok) (error "Unexpected end of input")) + ((eq? tok close-paren) (error "Unexpected )")) + ((eq? tok close-bracket) (error "Unexpected ]")) + ((eq? tok dot-token) (error "Unexpected .")) + (else tok)))) + +;;; Read list elements up to close-paren or close-bracket, +;;; honoring dotted-pair notation (a b . c) +(define (read-list port closer) + (let loop ((acc (list))) + (let ((tok (next-token port))) + (cond + ((eof-object? tok) (error "Unexpected end of input inside list")) + ((eq? tok close-paren) + (if (eq? closer close-paren) + (reverse acc) + (error "Unmatched closing bracket"))) + ((eq? tok close-bracket) + (if (eq? closer close-bracket) + (reverse acc) + (error "Unmatched closing bracket"))) + ((eq? tok dot-token) + (if (null? acc) + ;; Leading `.': the member/method access operator. It reads + ;; as an ordinary `dot-access' symbol in first position. + (loop (cons 'dot-access acc)) + ;; Otherwise: ordinary dotted-pair notation (a b . c). + (let ((tail (read-datum port)) + (end (next-token port))) + (unless (eq? end closer) + (error "Malformed dotted list")) + (append-reverse acc tail)))) + (else (loop (cons tok acc))))))) + +;;; Append the reversed list `rev' in front of `tail', producing a +;;; possibly-improper list (used for dotted pairs) +(define (append-reverse rev tail) + (if (null? rev) + tail + (append-reverse (cdr rev) (cons (car rev) tail)))) + +;;; A bare atom: symbol or number, or the dot token when it is exactly "." +(define (read-atom port) + (let loop ((chars (list))) + (let ((c (peek port))) + (if (delimiter? c) + (finish-atom (list->string (reverse chars))) + (begin (get-ch port) (loop (cons c chars))))))) + +(define (finish-atom s) + (cond + ((string=? s ".") dot-token) + ((string->number s) => identity) + (else (string->symbol s)))) + +;;; #-dispatch: booleans, characters, vectors, block/datum comments +(define (read-hash port) + (let ((c (get-ch port))) + (cond + ((eof-object? c) (error "Unexpected end of input after #")) + ((or (char=? c #\t) (char=? c #\T)) (read-bool port #t)) + ((or (char=? c #\f) (char=? c #\F)) (read-bool port #f)) + ((char=? c #\\) (read-char-lit port)) + ((char=? c #\() (list->vector (read-list port close-paren))) + ((char=? c #\|) (skip-block-comment port 1) (next-token port)) + ((char=? c #\;) (read-datum port) (next-token port)) ; datum comment + (else (error "Unsupported # syntax" c))))) + +;;; #t / #true / #f / #false. `val' is the boolean; consume any +;;; trailing name characters and validate +(define (read-bool port val) + (let ((rest (read-atom-string port))) + (cond + ((string=? rest "") val) + ((and val (string=? rest "rue")) val) + ((and (not val) (string=? rest "alse")) val) + (else (error "Malformed boolean literal" rest))))) + +(define (read-atom-string port) + (let loop ((chars (list))) + (let ((c (peek port))) + (if (delimiter? c) + (list->string (reverse chars)) + (begin (get-ch port) (loop (cons c chars))))))) + +(define named-chars + '(("space" . #\space) ("newline" . #\newline) ("tab" . #\tab) + ("return" . #\return) ("nul" . #\nul) ("null" . #\nul) + ("delete" . #\delete) ("escape" . #\escape) ("alarm" . #\alarm) + ("backspace" . #\backspace))) + +(define (read-char-lit port) + (let ((first (get-ch port))) + (when (eof-object? first) + (error "Unexpected end of input in character literal")) + (if (char-alphabetic? first) + (let ((rest (read-atom-string port))) + (if (string=? rest "") + first + (let ((name (string-append (string first) rest))) + (cond + ((assoc name named-chars) => cdr) + (else (error "Unknown character name" name)))))) + first))) + +;;; String literal with escape processing, matching the common escapes +;;; the previous reader (CHICKEN `read') interpreted +(define (read-string-lit port) + (get-ch port) ; consume opening quote + (let loop ((chars (list))) + (let ((c (get-ch port))) + (cond + ((eof-object? c) (error "Unterminated string literal")) + ((char=? c #\") (list->string (reverse chars))) + ((char=? c #\\) (loop (cons (read-escape port) chars))) + (else (loop (cons c chars))))))) + +(define (read-escape port) + (let ((c (get-ch port))) + (cond + ((eof-object? c) (error "Unterminated string literal")) + ((char=? c #\n) #\newline) + ((char=? c #\t) #\tab) + ((char=? c #\r) #\return) + ((char=? c #\a) #\alarm) + ((char=? c #\b) #\backspace) + ((char=? c #\f) (integer->char 12)) + ((char=? c #\v) (integer->char 11)) + ((char=? c #\0) #\nul) + (else c)))) ; \" \\ and anything else: literal + +(define (skip-block-comment port depth) + (if (= depth 0) + #t + (let ((c (get-ch port))) + (cond + ((eof-object? c) (error "Unterminated block comment")) + ((and (char=? c #\|) (eqv? (peek port) #\#)) + (get-ch port) (skip-block-comment port (- depth 1))) + ((and (char=? c #\#) (eqv? (peek port) #\|)) + (get-ch port) (skip-block-comment port (+ depth 1))) + (else (skip-block-comment port depth)))))) + +;;; Read every top-level form from `port'. Locations are recorded by +;;; next-token, for every form rather than only these +(define (parse-all port) + (parameterize ((current-line 1)) + (let loop ((acc (list))) + (skip-whitespace port) + (let ((tok (next-token port))) + (cond + ((eof-object? tok) (reverse acc)) + ((or (eq? tok close-paren) + (eq? tok close-bracket)) + (error "Unmatched closing bracket at top level")) + ((eq? tok dot-token) + (error "Unexpected . at top level")) + (else + (loop (cons tok acc)))))))) + +;;; Entry point: read all forms from a file, or from the current input +;;; port when the source is 'stdin (define (read-from-file file) - (with-directory file - (with-input-from-file (pathname-strip-directory file) - (fn (read-forms (list)))))) - -(define open-bracket-counter (make-parameter 0)) + ;; Resolve the name before with-directory moves us, so an imported + ;; module's forms carry that module's path rather than the importer's + (let ((source-file (to-absolute-pathname file))) + (with-directory file + (with-input-from-file (pathname-strip-directory file) + (lambda () + (parameterize ((current-source-file source-file)) + (parse-all (current-input-port)))))))) (define (read-raw-forms input-source) - (let ((bracket-end (gensym))) - (set-read-syntax! - #\] - (lambda (port) - (when (= 0 (open-bracket-counter)) - (error "Unmatched closing bracket")) - (open-bracket-counter (- (open-bracket-counter) 1)) - bracket-end)) - - (set-read-syntax! - #\[ - (lambda (port) - (open-bracket-counter (+ (open-bracket-counter) 1)) - (let loop ((r (read port)) - (acc (list))) - (if (eq? r bracket-end) - (cons '¤ (reverse acc)) - (loop (read port) - (cons r acc))))))) (if (eq? input-source 'stdin) - (read-forms (list)) + (parameterize ((current-source-file "stdin")) + (parse-all (current-input-port))) (read-from-file input-source))) diff --git a/semen.scm b/semen.scm index 7b1c748..6bdfcc4 100644 --- a/semen.scm +++ b/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 diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index 6d69a09..127b2fc 100644 --- a/sex-fmt-c.scm +++ b/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) diff --git a/sex-mode.el b/sex-mode.el index 05c6ed7..b2197d0 100644 --- a/sex-mode.el +++ b/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" diff --git a/sex-modules.scm b/sex-modules.scm index 4720e62..5025629 100644 --- a/sex-modules.scm +++ b/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))) diff --git a/sexc.scm b/sexc.scm index 8da7052..46afcc0 100644 --- a/sexc.scm +++ b/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,9 +183,14 @@ (return #f)) (load-persistent-module-paths) - (if (eq? input 'stdin) - (sex-fmt-current-file "stdin") - (sex-fmt-current-file (to-absolute-pathname input))) + ;; The file name in a #line directive now comes from the form's + ;; own recorded location, so imported modules report themselves + ;; rather than the unit that imported them + (sex-line-directives (line-directives-arg args)) + (when (and (get-arg args 'emit-c #f) + (not (get-arg args 'line-directives #f))) + (sex-line-directives 'none)) + (let* ((raw-forms (append prelude (read-raw-forms input))) (sex-forms (semantic-process-forms raw-forms input))) (if (or (get-arg args 'macro-expand #f) @@ -165,4 +198,4 @@ ;; Emit processed and macro-expanded sex code, or emit C code (emit-c-or-sex sex-forms output args) ;; Compile file! - (compile-to-file sex-forms output args))))))) + (compile-to-file sex-forms output args cc-args))))))) diff --git a/tests/Makefile b/tests/Makefile index 0f07326..0251aaa 100644 --- a/tests/Makefile +++ b/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 diff --git a/tests/args.scm b/tests/args.scm new file mode 100644 index 0000000..c4ced0f --- /dev/null +++ b/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 '()))) diff --git a/tests/basic.scm b/tests/basic.scm index 0f588df..29fc1b3 100644 --- a/tests/basic.scm +++ b/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 ")))) diff --git a/tests/codegen.scm b/tests/codegen.scm new file mode 100644 index 0000000..e278d3a --- /dev/null +++ b/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")))) diff --git a/tests/line-directives.scm b/tests/line-directives.scm new file mode 100644 index 0000000..db74cd4 --- /dev/null +++ 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))))))) 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/tests/run.scm b/tests/run.scm index 2ea0e53..1256079 100644 --- a/tests/run.scm +++ 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) diff --git a/tests/sex-programs/comments.sex b/tests/sex-programs/comments.sex new file mode 100644 index 0000000..1b9df8b --- /dev/null +++ b/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)) diff --git a/tests/sex-programs/list-macros.sex b/tests/sex-programs/list-macros.sex index 8355f73..809ad68 100644 --- a/tests/sex-programs/list-macros.sex +++ b/tests/sex-programs/list-macros.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) diff --git a/tests/sex-programs/unicode.sex b/tests/sex-programs/unicode.sex new file mode 100644 index 0000000..93fa7d3 --- /dev/null +++ b/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)) diff --git a/tests/sexc.module.scm b/tests/sexc.module.scm index a0be047..320e689 100644 --- a/tests/sexc.module.scm +++ b/tests/sexc.module.scm @@ -1 +1,3 @@ -(module sexc (main) "../sexc.scm") +(module sexc + * + "../sexc.scm") diff --git a/tools/sextest/Makefile b/tools/sextest/Makefile index 02f977a..96fe0ee 100644 --- a/tools/sextest/Makefile +++ b/tools/sextest/Makefile @@ -1,5 +1,23 @@ CHICKEN_C = csc CSC_FLAGS += -K prefix -static +MODULE_FLAGS = -emit-all-import-libraries -module-registration -c -sextest: sextest.scm - $(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest +ROOT = ../.. + +# sextest reuses sexc's reader (and its utils dependency) instead of +# duplicating the S-expression reader. The module wrappers here include +# the shared sources from the project root. + +sextest: sextest.scm reader.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest -link reader,utils + +utils.o: utils.module.scm $(ROOT)/utils.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils + +reader.o: reader.module.scm $(ROOT)/reader.scm utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils + +clean: + rm -f *.o *.import.scm *.link sextest + +.PHONY: clean diff --git a/tools/sextest/reader.module.scm b/tools/sextest/reader.module.scm new file mode 100644 index 0000000..2037c32 --- /dev/null +++ b/tools/sextest/reader.module.scm @@ -0,0 +1,3 @@ +(module reader (read-from-file + read-raw-forms) + "../../reader.scm") diff --git a/tools/sextest/sextest.scm b/tools/sextest/sextest.scm index d49a62b..1ee4c75 100644 --- a/tools/sextest/sextest.scm +++ b/tools/sextest/sextest.scm @@ -7,72 +7,11 @@ (chicken port) (chicken process) (chicken process-context) - (chicken read-syntax) - (chicken syntax) fmt getopt-long + reader ; read-raw-forms, shared with sexc srfi-1) -(define-syntax prog1 - (syntax-rules () - ((prog1 form . forms) - (let ((res form)) - (begin . forms) - res)))) - -(define-syntax with-directory - (syntax-rules () - ((with-directory path form . forms) - (let ((current-dir (current-directory))) - (set-working-directory path) - (prog1 - (begin form . forms) - (change-directory current-dir)))))) - -(define (set-working-directory file) - (change-directory - (normalize-pathname - (if (absolute-pathname? file) - (pathname-directory file) - (make-absolute-pathname - (current-directory) - (pathname-directory file)))))) - -;;; TODO: use sexc reader code i.e. link with sex reader -(define open-bracket-counter (make-parameter 0)) - -(define (read-raw-forms input-source) - (let ((bracket-end (gensym))) - (set-read-syntax! - #\] - (lambda (port) - (when (= 0 (open-bracket-counter)) - (error "Unmatched closing bracket")) - (open-bracket-counter (- (open-bracket-counter) 1)) - bracket-end)) - - (set-read-syntax! - #\[ - (lambda (port) - (open-bracket-counter (+ (open-bracket-counter) 1)) - (let loop ((r (read port)) - (acc (list))) - (if (eq? r bracket-end) - (cons '¤ (reverse acc)) - (loop (read port) - (cons r acc))))))) - (read-from-file input-source)) - -(define (read-from-file file) - (with-directory file - (with-input-from-file (pathname-strip-directory file) - (fn (read-forms (list)))))) - -(define (read-forms acc) - (let ((r (read-with-source-info (current-input-port)))) - (if (eof-object? r) (reverse acc) - (read-forms (cons r acc))))) - (define (print-help) (fmt #t "Usage: sextest [options] filename" nl "Options:" nl @@ -99,27 +38,25 @@ (get-environment-variable "SEXC") "sexc")) (compiled-file (create-temporary-file))) - (call-with-values - (fn - (process compiler - (append (list "-o" compiled-file) - flags))) - (lambda (out-port in-port pid) - (with-output-to-port in-port - (fn (map (fn (fmt #t x)) src))) - (close-output-port in-port) - - (call-with-values - (fn (process-wait pid)) - (lambda (pid exited retcode) - (if (= 0 retcode) - compiled-file - #f))))))) + ;; `process' returns one record; `process-input-port' is named from + ;; the child's side, so it is the port we write to. + (let* ((proc (process compiler (append (list "-o" compiled-file) flags))) + (sexc-stdin (process-input-port proc))) + (with-output-to-port sexc-stdin + (fn (map (fn (fmt #t x)) src))) + (close-output-port sexc-stdin) + (call-with-values + (fn (process-wait proc)) + (lambda (pid exited retcode) + (if (= 0 retcode) + compiled-file + #f)))))) (define (run-and-check file in out ret) - (call-with-values - (fn (process file)) - (lambda (out-port in-port pid) + (let* ((proc (process file)) + (out-port (process-output-port proc)) ; the program's stdout + (in-port (process-input-port proc))) ; the program's stdin + (let () (when in (with-output-to-port in-port (fn (map (fn (fmt #t x)) @@ -139,7 +76,7 @@ ;; TODO: what if the program hangs ;; we need some kind of timeout mechanism (fn - (process-wait pid)) + (process-wait proc)) (lambda (pid exited retcode) retcode)))) (and @@ -198,7 +135,7 @@ (print-help) (exit 1)) (unless - (foldl and + (foldl (lambda (a b) (and a b)) #t (map (fn (process-test-file (assoc 'sexc args) x)) (cdr (assoc '@ args)))) diff --git a/tools/sextest/utils.module.scm b/tools/sextest/utils.module.scm new file mode 100644 index 0000000..0eeeae1 --- /dev/null +++ b/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") diff --git a/utils.module.scm b/utils.module.scm index 07d8538..f577477 100644 --- a/utils.module.scm +++ b/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") diff --git a/utils.scm b/utils.scm index c8154fc..430bdb3 100644 --- a/utils.scm +++ b/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 "")) + +(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)