From 196694f18e05428d3add6164da3c937ee92912fe Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 17 Feb 2026 16:11:56 +0300 Subject: [PATCH 1/4] modularize sex Also rename macros to sex-macros, module-system to sex-modules for clarity, uniformity, and to avoid name clashes with Chicken's units/modules named "macros" and "modules" --- .gitignore | 2 + Makefile | 63 ++- fmt-c-writer.module.scm | 3 + fmt-c-writer.scm | 30 +- fmt-c.scm | 959 --------------------------------- main.scm | 3 +- reader.module.scm | 3 + sex-reader.scm => reader.scm | 45 +- semen.module.scm | 2 + semen.scm | 106 ++-- sex-fmt-c.scm | 985 ++++++++++++++++++++++++++++++++++ sex-macros.module.scm | 8 + sex-macros.scm | 12 +- sex-modules.module.scm | 5 + sex-modules.scm | 31 +- sexc.module.scm | 1 + sexc.scm | 36 +- tests/Makefile | 44 ++ tests/basic.scm | 2 + tests/fmt-c-writer.module.scm | 3 + tests/reader.module.scm | 3 + tests/reader.scm | 3 +- tests/run.scm | 6 - tests/semen.module.scm | 2 + tests/semen.scm | 11 +- tests/sex-macros.module.scm | 3 + tests/sex-modules.module.scm | 3 + tests/sexc.module.scm | 1 + tests/utils.module.scm | 3 + tests/utils.scm | 2 + utils.macros.scm | 16 - utils.module.scm | 10 + utils.scm | 22 +- 33 files changed, 1295 insertions(+), 1133 deletions(-) create mode 100644 fmt-c-writer.module.scm delete mode 100644 fmt-c.scm create mode 100644 reader.module.scm rename sex-reader.scm => reader.scm (58%) create mode 100644 semen.module.scm create mode 100644 sex-fmt-c.scm create mode 100644 sex-macros.module.scm create mode 100644 sex-modules.module.scm create mode 100644 sexc.module.scm create mode 100644 tests/fmt-c-writer.module.scm create mode 100644 tests/reader.module.scm create mode 100644 tests/semen.module.scm create mode 100644 tests/sex-macros.module.scm create mode 100644 tests/sex-modules.module.scm create mode 100644 tests/sexc.module.scm create mode 100644 tests/utils.module.scm create mode 100644 utils.module.scm diff --git a/.gitignore b/.gitignore index b53963d..dbdf980 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ *.o +*.import.scm +*.link sexc sex-tests diff --git a/Makefile b/Makefile index 50cd21a..dbe895a 100644 --- a/Makefile +++ b/Makefile @@ -1,21 +1,60 @@ CHICKEN_C = csc -CSC_FLAGS += -K prefix +CSC_FLAGS += -K prefix -static +# What and why: +# -emit-all-import-libraries: Emit import-libraries for all defined modules. +# Used to generate .import.scm files so compiler would know how to use the modules. +# Without it, csc fails with "cannot import from undefined module" error. +# -module-registration: Always generate module registration code, even when +# import libraries are emitted. Enables us to import from our modules at run time. +# Used in macros, where we inject `(import (only sex-macros cat))' before the macro body. +# Without it, sexc compiles scuccessfully, but is unable to process macros, failing with +# "during expansion of (import ...) - cannot import from undefined module: sex-macros" +# error. +# -c: Stop after compilation to object files. This one is obvious. -MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils +MODULE_FLAGS = -emit-all-import-libraries -module-registration -c + +# Order matters, since module check correctness on compilation +MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc OBJ = $(MODULES:%=%.o) -sexc: main.o $(OBJ) - $(CHICKEN_C) $(CSC_FLAGS) $^ -o $@ +sexc: $(OBJ) main.scm + $(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc + # otherwise csc hangs, probably because it tries to compile to sexc.o first + mv sexc-tmp sexc -main.o: main.scm - $(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ +#------------------------------------------------------------------ -%.o: %.scm - $(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@ +utils.o: utils.module.scm utils.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils -sex-tests: $(OBJ) tests/*.scm - cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o - $(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests +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 + +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 + +semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils + +sex-fmt-c.o: sex-fmt-c.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c + +fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils + +sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils + +sex-tests: + $(MAKE) -C tests sex-tests + cp ./tests/sex-tests ./ clean: - rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o + rm -f $(OBJ) main.o + rm -f *.import.scm + rm -f *.link + rm -f sexc sex-tests diff --git a/fmt-c-writer.module.scm b/fmt-c-writer.module.scm new file mode 100644 index 0000000..e7e57fe --- /dev/null +++ b/fmt-c-writer.module.scm @@ -0,0 +1,3 @@ +(module fmt-c-writer (emit-c + sex-fmt-current-file) + "fmt-c-writer.scm") diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index c799f52..9375c62 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -1,20 +1,20 @@ ;;; Sex fmt-c output writer -(declare (unit fmt-c-writer) - (uses fmt-c - semen - utils)) - -(import (chicken string) - (chicken syntax) - brev-separate - fmt - matchable - regex - srfi-1 ; lists - srfi-13 ; strings - srfi-39 ; parameters - tree) +(import + scheme + (chicken base) + (chicken string) + (chicken syntax) + brev-separate + fmt + sex-fmt-c + matchable + regex + srfi-1 ; lists + srfi-13 ; strings + srfi-39 ; parameters + tree + utils) (define (unkebabify sym) (case sym diff --git a/fmt-c.scm b/fmt-c.scm deleted file mode 100644 index 7828762..0000000 --- a/fmt-c.scm +++ /dev/null @@ -1,959 +0,0 @@ -;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code -;; -;; Copyright (c) 2007 Alex Shinn. All rights reserved. -;; BSD-style license: http://synthcode.com/license.txt - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; additional state information - -(declare (unit fmt-c)) - -(import fmt - srfi-1 - srfi-13) - -(define (fmt-in-macro? st) (fmt-ref st 'in-macro?)) -(define (fmt-macro-params st) (fmt-ref st 'macro-params)) -(define (fmt-expression? st) (fmt-ref st 'expression?)) -(define (fmt-return? st) (fmt-ref st 'return?)) -(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?)) -(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?)) -(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?)) -(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?)) -(define (fmt-indent-space st) (fmt-ref st 'indent-space)) -(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space)) -(define (fmt-op st) (fmt-ref st 'op 'stmt)) -(define (fmt-gen st) (fmt-ref st 'gen)) - -(define (c-in-expr proc) (fmt-let 'expression? #t proc)) -(define (c-in-stmt proc) (fmt-let 'expression? #f proc)) -(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc)) - -(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc))) -(define (c-with-op op proc) (fmt-let 'op op proc)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; be smart about operator precedence - -(define (c-op-precedence x) - (if (string? x) - (cond - ((or (string=? x ".") (string=? x "->")) 10) - ((or (string=? x "++") (string=? x "--")) 20) - ((string=? x "&") 55) - ((string=? x "|") 65) - ((string=? x "&&") 70) - ((string=? x "||") 75) - ((string=? x "|=") 85) - ((or (string=? x "+=") (string=? x "-=")) 85) - (else 95)) - (case x - ;;((|::|) 5) ; C++ - ((dot arrow post-decrement post-increment) 10) - ((**) 15) ; Perl - ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ -- - ((=~ !~) 25) ; Perl - ((* / %) 30) - ((+ -) 35) - ((<< >>) 40) - ((< > <= >=) 45) - ((lt gt le ge) 45) ; Perl - ((== !=) 50) - ((eq ne cmp) 50) ; Perl - ((&) 55) - ((^) 60) - ;;((|\||) 65) - ((&& %and) 70) - ((%or) 75) - ;;((|\|\||) 75) - ;;((.. ...) 77) ; Perl - ((?) 80) - ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -= - ((comma) 90) - ((=>) 90) ; Perl - ((not) 92) ; Perl - ((and) 93) ; Perl - ((or xor) 94) ; Perl - ((paren bracket) 100) - (else 95)))) - -(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y))) -(define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y))) - -(define (c-paren x) (cat "(" (c-expr x) ")")) - -(define (c-maybe-paren op x) - (lambda (st) - ((fmt-let 'op op - (if (and (c-op<= (fmt-op st) op) - (not (vector? st))) - (c-paren x) - x)) - st))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; default literals writer - -(define (c-control-operator? x) - (memq x '(if while switch repeat do for fun begin))) - -(define (c-literal? x) - (or (number? x) (string? x) (char? x) (boolean? x))) - -(define (char->c-char c) - (string-append "'" (c-escape-char c #\') "'")) - -(define (c-escape-char c quote-char) - (let ((n (char->integer c))) - (if (<= 32 n 126) - (if (or (eqv? c quote-char) (eqv? c #\\)) - (string #\\ c) - (string c)) - (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))))))) - -(define (c-format-number x) - (if (and (integer? x) (exact? x)) - (lambda (st) - ((case (fmt-radix st) - ((16) (cat "0x" (string-upcase (number->string x 16)))) - ((8) (cat "0" (number->string x 8))) - (else (dsp (number->string x)))) - st)) - (dsp (number->string x)))) - -(define (c-format-string x) - (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st))) - -(define (c-string-escaped x) - (let loop ((parts '()) (idx (string-length x))) - (cond ((string-index-right x c-needs-string-escape? 0 idx) - => (lambda (special-idx) - (loop (cons (c-escape-char (string-ref x special-idx) #\") - (cons (substring/shared x (+ special-idx 1) idx) - parts)) - special-idx))) - (else - (cons (substring/shared x 0 idx) parts))))) - -(define (c-needs-string-escape? c) - (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t)) - -(define (c-simple-literal x) - (c-wrap-stmt - (cond ((char? x) (dsp (char->c-char x))) - ((boolean? x) (dsp (if x "1" "0"))) - ((number? x) (c-format-number x)) - ((string? x) (c-format-string x)) - ((null? x) (dsp "NULL")) - ((eof-object? x) (dsp "EOF")) - (else (dsp (write-to-string x)))))) - -(define (c-literal x) - (lambda (st) - ((if (and (symbol? x) (memq x (or (fmt-macro-params st) '()))) - (c-paren (c-simple-literal x)) - (c-simple-literal x)) - st))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; default expression generator - -(define (c-expr/sexp x) - (if (procedure? x) - x - (lambda (st) - (cond - ((pair? x) - (case (car x) - ((if) ((apply c-if (cdr x)) st)) - ((for) ((apply c-for (cdr x)) st)) - ((while) ((apply c-while (cdr x)) st)) - ((switch) ((apply c-switch (cdr x)) st)) - ((case) ((apply c-case (cdr x)) st)) - ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st)) - ((default) ((apply c-default (cdr x)) st)) - ((break) (c-break st)) - ((continue) (c-continue st)) - ((return) ((apply c-return (cdr x)) st)) - ((goto) ((apply c-goto (cdr x)) st)) - ((typedef) ((apply c-typedef (cdr x)) st)) - ((struct union class) ((apply c-struct/aux x) st)) - ((enum) ((apply c-enum (cdr x)) st)) - ((inline auto restrict register volatile extern static) - ((cat (car x) " " (apply c-begin (cdr x))) st)) - ;; non C-keywords must have some character invalid in a C - ;; identifier to avoid conflicts - by default we prefix % - ((vector-ref) - ((c-wrap-stmt - (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) - st)) - ((vector-set!) - ((c= (c-in-expr - (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) - (c-expr (cadddr x))) - st)) - ((extern/C) ((apply c-extern/C (cdr x)) st)) - ((%apply) ((apply c-apply (cdr x)) st)) - ((%define) ((apply cpp-define (cdr x)) st)) - ((%include) ((apply cpp-include (cdr x)) st)) - ((%fun) ((apply c-fun (cdr x)) st)) - ((%cond) - (let lp ((ls (cdr x)) (res '())) - (if (null? ls) - ((apply c-if (reverse res)) st) - (lp (cdr ls) - (cons (if (pair? (cddar ls)) - (apply c-begin (cdar ls)) - (cadar ls)) - (cons (caar ls) res)))))) - ((%prototype) ((apply c-prototype (cdr x)) st)) - ((%var) ((apply c-var (cdr x)) st)) - ((%begin) ((apply c-begin (cdr x)) st)) - ((%attribute) ((apply c-attribute (cdr x)) st)) - ((%line) ((apply cpp-line (cdr x)) st)) - ((%pragma %error %warning) - ((apply cpp-generic (substring/shared (symbol->string (car x)) 1) - (cdr x)) st)) - ((%if %ifdef %ifndef %elif) - ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1) - (cdr x)) st)) - ((%endif) ((apply cpp-endif (cdr x)) st)) - ((%block-begin) ((apply c-braced-block #f (cdr x)) st)) - ((%block) ((apply c-braced-block (cdr x)) st)) - ((%comment) ((apply c-comment (cdr x)) st)) - ((:) ((apply c-label (cdr x)) st)) - ((%cast) ((apply c-cast (cdr x)) st)) - ((+ - & * / % ! ~ ^ && < > <= >= == != << >> - = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=| - ((apply c-op x) st)) - ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st)) - ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st)) - ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st)) - ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st)) - ((arithmetic-shift) ((apply c-op '<< (cdr x)) st)) - ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st)) - ((%and) ((apply c-op "&&" (cdr x)) st)) - ((%or) ((apply c-op "||" (cdr x)) st)) - ((%. %field) ((apply c-op "." (cdr x)) st)) - ((%->) ((apply c-op "->" (cdr x)) st)) - (else - (cond - ((eq? (car x) (string->symbol ".")) - ((apply c-op "." (cdr x)) st)) - ((eq? (car x) (string->symbol "->")) - ((apply c-op "->" (cdr x)) st)) - ((eq? (car x) (string->symbol "++")) - ((apply c-op "++" (cdr x)) st)) - ((eq? (car x) (string->symbol "--")) - ((apply c-op "--" (cdr x)) st)) - ((eq? (car x) (string->symbol "+=")) - ((apply c-op "+=" (cdr x)) st)) - ((eq? (car x) (string->symbol "-=")) - ((apply c-op "-=" (cdr x)) st)) - (else ((c-apply x) st)))))) - ((vector? x) - ((c-wrap-stmt - (fmt-try-fit - (fmt-let 'no-wrap? #t - (cat "{" (fmt-join c-expr (vector->list x) ", ") "}")) - (lambda (st) - (let* ((col (fmt-col st)) - (sep (string-append "," (make-nl-space col)))) - ((cat "{" (fmt-join c-expr (vector->list x) sep) - "}" nl) - st))))) - st)) - (else - ((c-literal x) st)))))) - -(define (c-apply ls) - (c-wrap-stmt - (c-with-op - 'paren - (cat (c-expr (car ls)) - (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", ")))) - (fmt-if - fmt-no-wrap? - (c-paren flat) - (c-paren - (fmt-try-fit - flat - (lambda (st) - (let* ((col (fmt-col st)) - (sep (string-append "," (make-nl-space col)))) - ((fmt-join c-expr (cdr ls) sep) st))))))))))) - -(define (c-expr x) - (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; comments, with Emacs-friendly escaping of nested comments - -(define (make-comment-writer st) - (let ((output (fmt-ref st 'writer))) - (lambda (str st) - (let ((lim (- (string-length str) 1))) - (let lp ((i 0) (st st)) - (let ((j (string-index str #\/ i))) - (if j - (let ((st (if (and (> j 0) - (eqv? #\* (string-ref str (- j 1)))) - (output - "\\/" - (output (substring/shared str i j) st)) - (output (substring/shared str i (+ j 1)) st)))) - (lp (+ j 1) - (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1)))) - (output "\\" st) - st))) - (output (substring/shared str i) st)))))))) - -(define (c-comment . args) - (lambda (st) - ((cat "/*" (fmt-let 'writer (make-comment-writer st) - (apply-cat args)) - "*/") - st))) - -(define (make-block-comment-writer st) - (let ((output (make-comment-writer st)) - (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* "))) - (lambda (str st) - (let ((lim (string-length str))) - (let lp ((i 0) (st st)) - (let ((j (string-index str #\newline i))) - (if j - (lp (+ j 1) - (output indent (output (substring/shared str i j) st))) - (output (substring/shared str i) st)))))))) - -(define (c-block-comment . args) - (lambda (st) - (let ((col (fmt-col st)) - (row (fmt-row st)) - (indent (c-current-indent-string st))) - ((cat "/* " - (fmt-let 'writer (make-block-comment-writer st) (apply-cat args)) - (lambda (st) - (cond - ((= row (fmt-row st)) ((dsp " */") st)) - ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st)) - (else ((cat fl indent " */") st))))) - st)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; preprocessor - -(define (make-cpp-writer st) - (let ((output (fmt-ref st 'writer))) - (lambda (str st) - (let lp ((i 0) (st st)) - (let ((j (string-index str #\newline i))) - (if j - (lp (+ j 1) - (output - nl-str - (output " \\" (output (substring/shared str i j) st)))) - (output (substring/shared str i) st))))))) - -(define (cpp-include file) - (if (string? file) - (cat fl "#include " (wrt file) fl) - (cat fl "#include <" file ">" fl))) - -(define (list-dot x) - (cond ((pair? x) (list-dot (cdr x))) - ((null? x) #f) - (else x))) - -(define (flatten-list ls) - (let lp ((ls ls) (res '())) - (cond ((pair? ls) (lp (cdr ls) (cons (car ls) res))) - ((null? ls) (reverse res)) - (else (reverse (cons ls res)))))) - -(define (replace-tree from to x) - (let replace ((x x)) - (cond ((eq? x from) to) - ((pair? x) (cons (replace (car x)) (replace (cdr x)))) - (else x)))) - -(define (cpp-define x . body) - (define (name-of x) (c-expr (if (pair? x) (cadr x) x))) - (lambda (st) - (let* ((body (cond - ((and (pair? x) (list-dot x)) - => (lambda (dot) - (if (eq? dot '...) - body - (replace-tree dot '__VA_ARGS__ body)))) - (else body))) - (params (map (lambda (x) (if (pair? x) (cadr x) x)) - (flatten-list (if (pair? x) (cdr x) '())))) - (tail - (if (pair? body) - (cat " " - (fmt-let 'writer (make-cpp-writer st) - (fmt-let 'macro-params params - ((if (or (not (pair? x)) - (and (null? (cdr body)) - (c-literal? (car body)))) - (lambda (x) x) - c-paren) - (c-in-expr (apply c-begin body)))))) - (lambda (x) x)))) - ((c-in-expr - (if (pair? x) - (cat fl "#define " (name-of (car x)) - (c-paren - (fmt-join/dot name-of - (lambda (dot) (dsp "...")) - (cdr x) - ", ")) - tail fl) - (cat fl "#define " (c-expr x) tail fl))) - st)))) - -(define (cpp-expr x) - (if (or (symbol? x) (string? x)) (dsp x) (c-expr x))) - -(define (cpp-if/aux name check . o) - (let* ((pass (and (pair? o) (car o))) - (comment (if (member name '("ifdef" "ifndef")) - (cat " " - (c-comment - " " (if (equal? name "ifndef") "! " "") - check " ")) - "")) - (endif (if pass (cat fl "#endif" comment) "")) - (tail (cond - ((and (pair? o) (pair? (cdr o))) - (if (pair? (cddr o)) - (apply cpp-elif (cdr o)) - (cat (cpp-else) (cadr o) endif))) - (else endif)))) - (lambda (st) - (let ((indent (c-current-indent-string st))) - ((cat fl "#" name " " (cpp-expr check) fl - (if pass (cat indent pass) "") fl - tail fl) - st))))) - -(define (cpp-if check . o) - (apply cpp-if/aux "if" check o)) -(define (cpp-ifdef check . o) - (apply cpp-if/aux "ifdef" check o)) -(define (cpp-ifndef check . o) - (apply cpp-if/aux "ifndef" check o)) -(define (cpp-elif check . o) - (apply cpp-if/aux "elif" check o)) -(define (cpp-else . o) - (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl)) -(define (cpp-endif . o) - (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl)) - -(define (cpp-wrap-header name . body) - (let ((name name)) ; consider auto-mangling - (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl)))) - -(define (cpp-line num . o) - (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl)) - -(define (cpp-generic name . ls) - (cat fl "#" name (apply-cat ls) fl)) - -(define (cpp-undef . args) (apply cpp-generic "undef" args)) -(define (cpp-pragma . args) (apply cpp-generic "pragma" args)) -(define (cpp-error . args) (apply cpp-generic "error" args)) -(define (cpp-warning . args) (apply cpp-generic "warning" args)) - -(define (cpp-stringify x) - (cat "#" x)) - -(define (cpp-sym-cat . args) - (fmt-join dsp args " ## ")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; general indentation and brace rules - -(define (c-current-indent-string st . o) - (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0))))) - -(define (c-indent st . o) - (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4) - (if (pair? o) (car o) 0)))))) - -(define (c-indent/switch st) - (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4))))) - -(define (c-open-brace st) - (if (fmt-newline-before-brace? st) - (begin - (fmt-set! st 'newline-before-brace? #t) - (cat "{" nl)) - (begin - (fmt-set! st 'newline-before-brace? #t) - (cat " {" nl)))) - -(define (c-close-brace st) - (dsp "}")) - -(define (c-wrap-stmt x) - (fmt-if fmt-expression? - (c-expr x) - (cat (c-in-expr (c-expr x)) ";" nl))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; code blocks - -(define (c-block . args) - (apply c-block/aux 0 args)) - -(define (c-block/aux offset header body0 . body) - (let ((inner (apply c-begin body0 body))) - (if (or (pair? body) - (not (or (c-literal? body0) - (and (pair? body0) - (not (c-control-operator? (car body0))))))) - (c-braced-block/aux offset header inner) - (lambda (st) - (if (fmt-braceless-bodies? st) - ((cat header fl (c-indent st offset) inner fl) st) - ((c-braced-block/aux offset header inner) st)))))) - -(define (c-braced-block . args) - (apply c-braced-block/aux 0 args)) - -(define (c-braced-block/aux offset header . body) - (lambda (st) - ((cat (if header header "") (c-open-brace st) (c-indent st offset) - (apply c-begin body) fl - (c-current-indent-string st offset) (c-close-brace st)) - st))) - -(define (c-begin . args) - (apply c-begin/aux #f args)) - -(define (c-begin/aux ret? body0 . body) - (if (null? body) - (c-expr body0) - (lambda (st) - (if (fmt-expression? st) - ((fmt-try-fit - (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", ")) - (lambda (st) - (let ((indent (c-current-indent-string st))) - ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st)))) - st) - (let ((orig-ret? (fmt-return? st))) - ((fmt-join/last c-expr - (lambda (x) (fmt-let 'return? orig-ret? (c-expr x))) - (cons body0 body) - (cat fl (c-current-indent-string st))) - (fmt-set! st 'return? (and ret? orig-ret?)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; data structures - -(define (c-struct/aux type x . o) - ;; can be just pointer to SUC, need to support such case: - ;; struct whatever * - body is just '*' - (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) - (body (if name (if (not (null? o)) (car o) '()) x)) - (o (if (null? o) o (cdr o)))) - (if (and (not (null? body)) - (not (eq? '* body))) - (c-wrap-stmt - (cat - (c-braced-block - (cat type (if (and name (not (equal? name ""))) (cat " " name) "")) - (cat - (c-in-stmt - (if (list? body) - (apply c-begin (map c-wrap-stmt (map c-field body))) - (c-wrap-stmt (c-expr body)))))) - (if (pair? o) (cat " " (apply c-begin o)) (dsp "")))) - (c-wrap-stmt - (cat type - (if (and name (not (equal? name ""))) - (cat " " name) - "") - (if (not (null? body)) - (cat body) - "")))))) - -(define (c-struct . args) (apply c-struct/aux "struct" args)) -(define (c-union . args) (apply c-struct/aux "union" args)) -(define (c-class . args) (apply c-struct/aux "class" args)) - -(define (c-enum x . o) - (define (c-enum-one x) - (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x))) - (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) - (vals (if name (car o) x))) - (c-wrap-stmt - (cat - (c-braced-block - (if name (cat "enum " name) (dsp "enum")) - (c-in-expr (apply c-begin (map c-enum-one vals)))))))) - -(define (c-attribute . args) - (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; basic control structures - -(define (c-while check . body) - (c-reset-newline - (if (null? body) - (cat "while (" (c-in-test (c-expr check)) ");") - (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")") - (c-in-stmt (apply c-begin body))) - fl)))) - -(define (c-for init check update . body) - (c-reset-newline - (cat - (c-block - (c-in-expr - (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; " - (c-expr update ) ")")) - (c-in-stmt (apply c-begin body))) - fl))) - -(define (c-param x) - (cond - ((procedure? x) x) - ((pair? x) (c-param-type (car x) (cadr x))) - (else (error "missing type" x)))) - -(define (c-field x) - (cond - ((procedure? x) x) - ((pair? x) - (if (list? (car x)) - (case (caar x) - ((union struct class) - (if (> (length x) 1) - (c-type (car x) - (cadr x)) - (c-type (car x)))) - (else (c-type (car x) (cadr x)))) - (c-type (car x) - (fmt-join c-expr (cdr x) ", ")))) - (else (error "missing type" x)))) - -(define (c-param-list ls) - (if (null? ls) - (c-type 'void) - (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))) - -(define (c-fun type name params . body) - (cat (c-block (c-in-expr (c-prototype type name params)) - (c-in-stmt (apply c-begin body))) - fl)) - -(define (c-prototype type name params . o) - (c-wrap-stmt - (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")" - (fmt-join/prefix c-expr o " ")))) - -(define (c-static x) (cat "static " (c-expr x))) -(define (c-const x) (cat "const " (c-expr x))) -(define (c-restrict x) (cat "restrict " (c-expr x))) -(define (c-volatile x) (cat "volatile " (c-expr x))) -(define (c-auto x) (cat "auto " (c-expr x))) -(define (c-inline x) (cat "inline " (c-expr x))) -(define (c-extern x) (cat "extern " (c-expr x))) -(define (c-extern/C . body) - (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl)) - -(define (c-type type . o) - (let ((name (and (pair? o) (car o)))) - (cond - ((pair? type) - (case (car type) - ((%fun) - (cat (c-type (cadr type) #f) - " (*" (or name "") ")(" - (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")")) - ((%array) - (let ((name (cat name "[" (if (pair? (cddr type)) - (c-expr (caddr type)) - "") - "]"))) - (c-type (cadr type) name))) - ((%pointer *) - (let ((name (cat "*" (if name (c-expr name) "")))) - (c-type (cadr type) - (if (and (pair? (cadr type)) (eq? '%array (caadr type))) - (c-paren name) - name)))) - ((enum) (apply c-enum name (cdr type))) - ((struct union class) - (cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) ""))) - (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) - ((not type) - (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st))) - (else - (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) - -(define (c-param-type type . o) - (let ((name (and (pair? o) (car o)))) - (cond - ((pair? type) - (case (car type) - ((%fun) - (cat (c-type (cadr type) #f) - " (*" (or name "") ")(" - (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")")) - ((%array) - (let ((name (cat name "[" (if (pair? (cddr type)) - (c-expr (caddr type)) - "") - "]"))) - (c-type (cadr type) name))) - ((%pointer *) - (let ((name (cat "*" (if name (c-expr name) "")))) - (c-type (cadr type) - (if (and (pair? (cadr type)) (eq? '%array (caadr type))) - (c-paren name) - name)))) - (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) - ((not type) - (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st))) - (else - (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) - -(define (c-var type name . init) - (c-wrap-stmt - (if (pair? init) - (cat (c-type type name) " = " (c-expr (car init))) - (c-type type (if (pair? name) - (fmt-join c-expr name ", ") - (c-expr name)))))) - -(define (c-cast type expr) - (cat "(" (c-type type) ")" (c-expr expr))) - -(define (c-typedef type alias . o) - (c-wrap-stmt - (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " ")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Generalized IF: allows multiple tail forms for if/else if/.../else -;; blocks. A final ELSE can be signified with a test of #t or 'else, -;; or by simply using an odd number of expressions (by which the -;; normal 2 or 3 clause IF forms are special cases). - -(define (c-if/stmt c p . rest) - (lambda (st) - (let ((indent (c-current-indent-string st))) - ((let lp ((c c) (p p) (ls rest)) - (if (or (eq? c 'else) (eq? c #t)) - (if (not (null? ls)) - (error "forms after else clause in IF" c p ls) - (cat (c-block/aux -1 " else" p) fl)) - (let ((tail (if (pair? ls) - (if (pair? (cdr ls)) - (lp (car ls) (cadr ls) (cddr ls)) - (lp 'else (car ls) '())) - fl))) - (cat (c-block/aux - (if (eq? ls rest) 0 -1) - (cat (if (eq? ls rest) (lambda (x) x) " else ") - "if (" (c-in-test (c-expr c)) ")") p) - tail)))) - st)))) - -(define (c-if/expr c p . rest) - (let lp ((c c) (p p) (ls rest)) - (cond - ((or (eq? c 'else) (eq? c #t)) - (if (not (null? ls)) - (error "forms after else clause in IF" c p ls) - (c-expr p))) - ((pair? ls) - (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : " - (if (pair? (cdr ls)) - (lp (car ls) (cadr ls) (cddr ls)) - (lp 'else (car ls) '())))) - (else - (c-or (c-in-test (c-expr c)) (c-expr p)))))) - -(define (c-if . args) - (fmt-if fmt-expression? - (apply c-if/expr args) - (apply c-if/stmt args))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; switch statements, automatic break handling - -(define (c-label name) - (lambda (st) - (let ((indent (make-space (max 0 (- (fmt-col st) 2))))) - ((cat fl indent name ":" fl) st)))) - -(define c-break - (c-wrap-stmt (dsp "break"))) -(define c-continue - (c-wrap-stmt (dsp "continue"))) -(define (c-return . result) - (if (pair? result) - (c-wrap-stmt (cat "return " (c-expr (car result)))) - (c-wrap-stmt (dsp "return")))) -(define (c-goto label) - (c-wrap-stmt (cat "goto " (c-expr label)))) - -(define (c-switch val . clauses) - (c-reset-newline - (lambda (st) - ((cat "switch (" (c-in-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) - st)))) - -(define (c-switch-clause/breaks x) - (lambda (st) - (let* ((break? - (and (car x) - (not (member (cadr x) '(case/fallthrough - default/fallthrough - else/fallthrough))))) - (explicit-case? (member (cadr x) '(case case/fallthrough))) - (indent (c-current-indent-string st)) - (indent-body (c-indent st)) - (sep (string-append ":" nl-str indent))) - ((cat (c-in-expr - (fmt-join/suffix - dsp - (cond - ((pair? (cadr x)) - (map (lambda (y) (cat (dsp "case ") (c-expr y))) - (cadr x))) - (explicit-case? - (map (lambda (y) (cat (dsp "case ") (c-expr y))) - (if (list? (caddr x)) - (caddr x) - (list (caddr x))))) - ((member (cadr x) - '(default else default/fallthrough else/fallthrough)) - (list (dsp "default"))) - (else - (error - "unknown switch clause, expected a list or default but got" - (cadr x)))) - sep)) - (make-space (or (fmt-indent-space st) 4)) - (fmt-join c-expr - (if explicit-case? (cdddr x) (cddr x)) - indent-body) - (if (and break? (not (fmt-return? st))) - (cat fl indent-body c-break) - "")) - st)))) - -(define (c-switch-clause x) - (if (procedure? x) x (c-switch-clause/breaks (cons #t x)))) -(define (c-switch-clause/no-break x) - (if (procedure? x) x (c-switch-clause/breaks (cons #f x)))) - -(define (c-case x . body) - (c-switch-clause (cons (if (pair? x) x (list x)) body))) -(define (c-case/fallthrough x . body) - (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body))) -(define (c-default . body) - (c-switch-clause/breaks (cons #t (cons 'else body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; operators - -(define (c-op op first . rest) - (if (null? rest) - (c-unary-op op first) - (apply c-binary-op op first rest))) - -(define (c-binary-op op . ls) - (define (lit-op? x) (or (c-literal? x) (symbol? x))) - (let ((str (display-to-string op))) - (c-wrap-stmt - (c-maybe-paren - op - (if (or (equal? str ".") (equal? str "->")) - (fmt-join c-expr ls str) - (let ((flat - (fmt-let 'no-wrap? #t - (lambda (st) - ((fmt-join c-expr - ls - (if (and (fmt-non-spaced-ops? st) - (every lit-op? ls)) - str - (string-append " " str " "))) - st))))) - (fmt-if - fmt-no-wrap? - flat - (fmt-try-fit - flat - (lambda (st) - ((fmt-join c-expr - ls - (cat nl (make-space (+ 2 (fmt-col st))) str " ")) - st)))))))))) - -(define (c-unary-op op x) - (c-wrap-stmt - (cat (display-to-string op) (c-maybe-paren op (c-expr x))))) - -;; some convenience definitions - -(define (c++ . args) (apply c-op "++" args)) -(define (c-- . args) (apply c-op "--" args)) -(define (c+ . args) (apply c-op '+ args)) -(define (c- . args) (apply c-op '- args)) -(define (c* . args) (apply c-op '* args)) -(define (c/ . args) (apply c-op '/ args)) -(define (c% . args) (apply c-op '% args)) -(define (c& . args) (apply c-op '& args)) -;; (define (|c\|| . args) (apply c-op '|\|| args)) -(define (c^ . args) (apply c-op '^ args)) -(define (c~ . args) (apply c-op '~ args)) -(define (c! . args) (apply c-op '! args)) -(define (c&& . args) (apply c-op '&& args)) -;; (define (|c\|\|| . args) (apply c-op '|\|\|| args)) -(define (c<< . args) (apply c-op '<< args)) -(define (c>> . args) (apply c-op '>> args)) -(define (c== . args) (apply c-op '== args)) -(define (c!= . args) (apply c-op '!= args)) -(define (c< . args) (apply c-op '< args)) -(define (c> . args) (apply c-op '> args)) -(define (c<= . args) (apply c-op '<= args)) -(define (c>= . args) (apply c-op '>= args)) -(define (c= . args) (apply c-op '= args)) -(define (c+= . args) (apply c-op "+=" args)) -(define (c-= . args) (apply c-op "-=" args)) -(define (c*= . args) (apply c-op '*= args)) -(define (c/= . args) (apply c-op '/= args)) -(define (c%= . args) (apply c-op '%= args)) -(define (c&= . args) (apply c-op '&= args)) -;; (define (|c\|=| . args) (apply c-op '|\|=| args)) -(define (c^= . args) (apply c-op '^= args)) -(define (c<<= . args) (apply c-op '<<= args)) -(define (c>>= . args) (apply c-op '>>= args)) - -(define (c. . args) (apply c-op "." args)) -(define (c-> . args) (apply c-op "->" args)) - -(define (c-bit-or . args) (apply c-op "|" args)) -(define (c-or . args) (apply c-op "||" args)) -(define (c-bit-or= . args) (apply c-op "|=" args)) - -(define (c++/post x) - (cat (c-maybe-paren 'post-increment (c-expr x)) "++")) -(define (c--/post x) - (cat (c-maybe-paren 'post-decrement (c-expr x)) "--")) diff --git a/main.scm b/main.scm index 103d240..3244f92 100644 --- a/main.scm +++ b/main.scm @@ -1,6 +1,5 @@ ;;; The purpose of this file is to compile it to the only ;;; .o that has main entry point. -(declare (uses sexc)) - +(import sexc) (main) diff --git a/reader.module.scm b/reader.module.scm new file mode 100644 index 0000000..43a312f --- /dev/null +++ b/reader.module.scm @@ -0,0 +1,3 @@ +(module reader (read-from-file + read-raw-forms) + "reader.scm") diff --git a/sex-reader.scm b/reader.scm similarity index 58% rename from sex-reader.scm rename to reader.scm index e68c075..9c53411 100644 --- a/sex-reader.scm +++ b/reader.scm @@ -1,8 +1,5 @@ -(declare (unit sex-reader)) - -(include "utils.macros.scm") - (import + scheme (chicken base) (chicken io) (chicken pathname) @@ -13,6 +10,8 @@ brev-separate fmt) +(import-syntax utils) + (define (read-forms acc) (let ((r (read-with-source-info (current-input-port)))) (if (eof-object? r) (reverse acc) @@ -20,8 +19,8 @@ (define (read-from-file file) (with-directory file - (with-input-from-file (pathname-strip-directory file) - (fn (read-forms (list)))))) + (with-input-from-file (pathname-strip-directory file) + (fn (read-forms (list)))))) (define (read-bracket port) (let loop ((c (read-char port)) @@ -40,24 +39,24 @@ (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) + (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))))))) + (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)) (read-from-file input-source))) diff --git a/semen.module.scm b/semen.module.scm new file mode 100644 index 0000000..7320815 --- /dev/null +++ b/semen.module.scm @@ -0,0 +1,2 @@ +(module semen () + "semen.scm") diff --git a/semen.scm b/semen.scm index 8912dc1..7b1c748 100644 --- a/semen.scm +++ b/semen.scm @@ -1,18 +1,22 @@ ;;; Sex semantic engine -(declare (unit semen) - (uses sex-macros - sex-modules - utils)) - (import + scheme + (chicken base) + (chicken keyword) (chicken string) + (chicken module) fmt - matchable ; pattern matching - srfi-1 ; list routines - srfi-69 ; hash tables + sex-macros + sex-modules + matchable ; pattern matching + srfi-1 ; list routines + srfi-69 ; hash tables + utils ) +(export/rename (process semen-process)) + ;;; for lambda extraction, docstring processing, macro expansion, ;;; injection of module headers, i.e. all things that rearrange code ;;; structurally, add or remove forms @@ -21,28 +25,28 @@ ;;; append their return to the resulting list. Each handler can return ;;; multiple forms, e.g. lambdas collected from a function may result ;;; in auxiliary structures and functions. -(define (semen-process raw-sex-forms) - (semen-process-rec raw-sex-forms (list))) +(define (process raw-sex-forms) + (process-rec raw-sex-forms (list))) -(define (semen-process-rec forms acc) +(define (process-rec forms acc) (cond ((null? forms) (reverse acc)) - ((sex-macro? (car forms)) - (semen-process-rec - (semen-apply-macro (car forms) (cdr forms)) + ((macro? (car forms)) + (process-rec + (macroexpand (car forms) (cdr forms)) acc)) (else - (semen-process-rec (cdr forms) - (match-sex-form (car forms) acc))))) + (process-rec (cdr forms) + (match-sex-form (car forms) acc))))) -(define (semen-apply-macro macro-form rest-forms) -;; We want to replace macro with its expansion. The problem is, -;; top-level macro can return either a single form, or a list of -;; forms, when it for example generates some aux -;; structures/functions/typedefs. -;; -;; Single form we just cons to the top of rest-forms, but multiple -;; forms have to be appended to the rest-forms. +(define (macroexpand macro-form rest-forms) + ;; We want to replace macro with its expansion. The problem is, + ;; top-level macro can return either a single form, or a list of + ;; forms, when it for example generates some aux + ;; structures/functions/typedefs. + ;; + ;; 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))) (if (list? (car res)) (append res rest-forms) @@ -66,7 +70,7 @@ (('define . _) (cons sex-form acc)) (('import . modules) - (semen-process-imports (get-public-forms modules) acc)) + (process-imports (get-modules-public-forms modules) acc)) ((or ('defmacro . rest) ('pub 'defmacro . rest)) (defmacro rest) acc) @@ -77,30 +81,30 @@ (else (assert #f (fmt #f "Unknown top level form " sex-form))))) -(define (semen-process-imports module-public-forms acc) +(define (process-imports module-public-forms acc) ;; Recursively process imports: register public macros, cons all ;; other public things to our acc (if (null? module-public-forms) acc (match (car module-public-forms) (('defmacro . rest) (defmacro rest) - (semen-process-imports (cdr module-public-forms) acc)) + (process-imports (cdr module-public-forms) acc)) (else - (semen-process-imports (cdr module-public-forms) - (cons (car module-public-forms) - acc)))))) + (process-imports (cdr module-public-forms) + (cons (car module-public-forms) + acc)))))) -(define (semen-macro-expand form) +(define (macro-expand form) "Walk the form recursively and expand all macros, until none is left." - (semen-walk-form + (walk-form form (lambda (subform env) - (if (sex-macro? subform) - (cons semen-walk-embed-result (semen-apply-macro subform (list))) + (if (macro? subform) + (cons walk-embed-result (macroexpand subform (list))) subform)) #f)) -;;; semen-walk-form and friends: form walker with various abilities. +;;; walk-form and friends: form walker with various abilities. ;;; By default, replaces walked form with walk-fn result But may ;;; perform additional operations depending of what the walk function ;;; has requested. @@ -108,21 +112,21 @@ ;;; For inspiration, see SBCL's walk.lisp and their template ;;; system. -(define semen-walk-embed-result (gensym) +(define walk-embed-result (gensym) ;; For cases when result is a list which must be embedded in the ;; form, e.g. when it returned from a macro ) -(define (semen-walk-form form walk-fn env) +(define (walk-form form walk-fn env) (if (atom? form) form (let ((new-form (walk-fn form env))) (cond ((not (eq? form new-form)) - (semen-walk-form new-form walk-fn env)) + (walk-form new-form walk-fn env)) (else - (let ((new-car (semen-walk-form (car new-form) walk-fn env)) - (new-cdr (semen-walk-form (cdr new-form) walk-fn env))) + (let ((new-car (walk-form (car new-form) walk-fn env)) + (new-cdr (walk-form (cdr new-form) walk-fn env))) (cond ((and (pair? new-car) - (eq? (car new-car) semen-walk-embed-result)) + (eq? (car new-car) walk-embed-result)) (append (cdr new-car) new-cdr)) (else (recons new-form new-car new-cdr))))))))) @@ -135,12 +139,12 @@ ;;; Fn processing (define (process-fn sex-fn acc) - (let* ((expanded (semen-macro-expand sex-fn)) + (let* ((expanded (macro-expand sex-fn)) (env (make-hash-table)) (processed - (semen-walk-form + (walk-form expanded - semen-fn-walker + fn-walker (begin (set! (hash-table-ref env :fn-name) (sex-fn-name expanded)) (set! (hash-table-ref env :lambda-counter) 0) @@ -150,23 +154,23 @@ (cons processed (append (hash-table-ref env :lambda-aux-code) acc)))) -(define (semen-fn-walker form env) +(define (fn-walker form env) (if (eq? 'lambda (car form)) - (let ((lambda-name (semen-make-lambda-name (hash-table-ref env :fn-name) - (hash-table-ref env :lambda-counter)))) + (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name) + (hash-table-ref env :lambda-counter)))) (set! (hash-table-ref env :lambda-aux-code) - (append (semen-make-aux-lambda-struct lambda-name form) + (append (make-aux-lambda-struct lambda-name form) (hash-table-ref env :lambda-aux-code))) (set! (hash-table-ref env :lambda-counter) (+ (hash-table-ref env :lambda-counter) 1)) lambda-name) - form)) + form)) -(define (semen-make-lambda-name enclosing-fn-name counter) +(define (make-lambda-name enclosing-fn-name counter) (string->symbol (fmt #f "__lambda_" counter "_" enclosing-fn-name))) -(define (semen-make-aux-lambda-struct name form) +(define (make-aux-lambda-struct name form) (match form (('lambda ret-type arglist captures . body) ;; Captures are ignored for now, but diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm new file mode 100644 index 0000000..4713c92 --- /dev/null +++ b/sex-fmt-c.scm @@ -0,0 +1,985 @@ +;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code +;; +;; Copyright (c) 2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; additional state information + +(module sex-fmt-c + ( + fmt-in-macro? fmt-expression? fmt-return? + fmt-newline-before-brace? fmt-braceless-bodies? + fmt-indent-space fmt-switch-indent-space fmt-op fmt-gen + c-in-expr c-in-stmt c-in-test + c-paren c-maybe-paren c-type c-literal? c-literal char->c-char + c-struct c-union c-class c-enum c-typedef c-cast + c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string + c-wrap-stmt c-open-brace c-close-brace + c-block c-braced-block c-begin + c-fun c-var c-prototype c-param c-param-list + c-while c-for c-if c-switch + c-case c-case/fallthrough c-default + c-break c-continue c-return c-goto c-label + c-static c-const c-extern c-volatile c-auto c-restrict c-inline + c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= ; |c\|| |c\|\|| + c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= ;++c --c ; |c\|=| + c++/post c--/post c. c-> + c-bit-or c-or c-bit-or= + cpp-if cpp-ifdef cpp-ifndef cpp-elif cpp-endif cpp-else cpp-undef + cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line + cpp-error cpp-warning cpp-stringify cpp-sym-cat + c-comment c-block-comment c-attribute) + + (import + scheme + (chicken base) + fmt + srfi-1 + srfi-13) + + (define (fmt-in-macro? st) (fmt-ref st 'in-macro?)) + (define (fmt-macro-params st) (fmt-ref st 'macro-params)) + (define (fmt-expression? st) (fmt-ref st 'expression?)) + (define (fmt-return? st) (fmt-ref st 'return?)) + (define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?)) + (define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?)) + (define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?)) + (define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?)) + (define (fmt-indent-space st) (fmt-ref st 'indent-space)) + (define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space)) + (define (fmt-op st) (fmt-ref st 'op 'stmt)) + (define (fmt-gen st) (fmt-ref st 'gen)) + + (define (c-in-expr proc) (fmt-let 'expression? #t proc)) + (define (c-in-stmt proc) (fmt-let 'expression? #f proc)) + (define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc)) + + (define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc))) + (define (c-with-op op proc) (fmt-let 'op op proc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; be smart about operator precedence + + (define (c-op-precedence x) + (if (string? x) + (cond + ((or (string=? x ".") (string=? x "->")) 10) + ((or (string=? x "++") (string=? x "--")) 20) + ((string=? x "&") 55) + ((string=? x "|") 65) + ((string=? x "&&") 70) + ((string=? x "||") 75) + ((string=? x "|=") 85) + ((or (string=? x "+=") (string=? x "-=")) 85) + (else 95)) + (case x + ;;((|::|) 5) ; C++ + ((dot arrow post-decrement post-increment) 10) + ((**) 15) ; Perl + ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ -- + ((=~ !~) 25) ; Perl + ((* / %) 30) + ((+ -) 35) + ((<< >>) 40) + ((< > <= >=) 45) + ((lt gt le ge) 45) ; Perl + ((== !=) 50) + ((eq ne cmp) 50) ; Perl + ((&) 55) + ((^) 60) + ;;((|\||) 65) + ((&& %and) 70) + ((%or) 75) + ;;((|\|\||) 75) + ;;((.. ...) 77) ; Perl + ((?) 80) + ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -= + ((comma) 90) + ((=>) 90) ; Perl + ((not) 92) ; Perl + ((and) 93) ; Perl + ((or xor) 94) ; Perl + ((paren bracket) 100) + (else 95)))) + + (define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y))) + (define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y))) + + (define (c-paren x) (cat "(" (c-expr x) ")")) + + (define (c-maybe-paren op x) + (lambda (st) + ((fmt-let 'op op + (if (and (c-op<= (fmt-op st) op) + (not (vector? st))) + (c-paren x) + x)) + st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; default literals writer + + (define (c-control-operator? x) + (memq x '(if while switch repeat do for fun begin))) + + (define (c-literal? x) + (or (number? x) (string? x) (char? x) (boolean? x))) + + (define (char->c-char c) + (string-append "'" (c-escape-char c #\') "'")) + + (define (c-escape-char c quote-char) + (let ((n (char->integer c))) + (if (<= 32 n 126) + (if (or (eqv? c quote-char) (eqv? c #\\)) + (string #\\ c) + (string c)) + (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))))))) + + (define (c-format-number x) + (if (and (integer? x) (exact? x)) + (lambda (st) + ((case (fmt-radix st) + ((16) (cat "0x" (string-upcase (number->string x 16)))) + ((8) (cat "0" (number->string x 8))) + (else (dsp (number->string x)))) + st)) + (dsp (number->string x)))) + + (define (c-format-string x) + (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st))) + + (define (c-string-escaped x) + (let loop ((parts '()) (idx (string-length x))) + (cond ((string-index-right x c-needs-string-escape? 0 idx) + => (lambda (special-idx) + (loop (cons (c-escape-char (string-ref x special-idx) #\") + (cons (substring/shared x (+ special-idx 1) idx) + parts)) + special-idx))) + (else + (cons (substring/shared x 0 idx) parts))))) + + (define (c-needs-string-escape? c) + (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t)) + + (define (c-simple-literal x) + (c-wrap-stmt + (cond ((char? x) (dsp (char->c-char x))) + ((boolean? x) (dsp (if x "1" "0"))) + ((number? x) (c-format-number x)) + ((string? x) (c-format-string x)) + ((null? x) (dsp "NULL")) + ((eof-object? x) (dsp "EOF")) + (else (dsp (write-to-string x)))))) + + (define (c-literal x) + (lambda (st) + ((if (and (symbol? x) (memq x (or (fmt-macro-params st) '()))) + (c-paren (c-simple-literal x)) + (c-simple-literal x)) + st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; default expression generator + + (define (c-expr/sexp x) + (if (procedure? x) + x + (lambda (st) + (cond + ((pair? x) + (case (car x) + ((if) ((apply c-if (cdr x)) st)) + ((for) ((apply c-for (cdr x)) st)) + ((while) ((apply c-while (cdr x)) st)) + ((switch) ((apply c-switch (cdr x)) st)) + ((case) ((apply c-case (cdr x)) st)) + ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st)) + ((default) ((apply c-default (cdr x)) st)) + ((break) (c-break st)) + ((continue) (c-continue st)) + ((return) ((apply c-return (cdr x)) st)) + ((goto) ((apply c-goto (cdr x)) st)) + ((typedef) ((apply c-typedef (cdr x)) st)) + ((struct union class) ((apply c-struct/aux x) st)) + ((enum) ((apply c-enum (cdr x)) st)) + ((inline auto restrict register volatile extern static) + ((cat (car x) " " (apply c-begin (cdr x))) st)) + ;; non C-keywords must have some character invalid in a C + ;; identifier to avoid conflicts - by default we prefix % + ((vector-ref) + ((c-wrap-stmt + (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) + st)) + ((vector-set!) + ((c= (c-in-expr + (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) + (c-expr (cadddr x))) + st)) + ((extern/C) ((apply c-extern/C (cdr x)) st)) + ((%apply) ((apply c-apply (cdr x)) st)) + ((%define) ((apply cpp-define (cdr x)) st)) + ((%include) ((apply cpp-include (cdr x)) st)) + ((%fun) ((apply c-fun (cdr x)) st)) + ((%cond) + (let lp ((ls (cdr x)) (res '())) + (if (null? ls) + ((apply c-if (reverse res)) st) + (lp (cdr ls) + (cons (if (pair? (cddar ls)) + (apply c-begin (cdar ls)) + (cadar ls)) + (cons (caar ls) res)))))) + ((%prototype) ((apply c-prototype (cdr x)) st)) + ((%var) ((apply c-var (cdr x)) st)) + ((%begin) ((apply c-begin (cdr x)) st)) + ((%attribute) ((apply c-attribute (cdr x)) st)) + ((%line) ((apply cpp-line (cdr x)) st)) + ((%pragma %error %warning) + ((apply cpp-generic (substring/shared (symbol->string (car x)) 1) + (cdr x)) st)) + ((%if %ifdef %ifndef %elif) + ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1) + (cdr x)) st)) + ((%endif) ((apply cpp-endif (cdr x)) st)) + ((%block-begin) ((apply c-braced-block #f (cdr x)) st)) + ((%block) ((apply c-braced-block (cdr x)) st)) + ((%comment) ((apply c-comment (cdr x)) st)) + ((:) ((apply c-label (cdr x)) st)) + ((%cast) ((apply c-cast (cdr x)) st)) + ((+ - & * / % ! ~ ^ && < > <= >= == != << >> + = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=| + ((apply c-op x) st)) + ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st)) + ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st)) + ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st)) + ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st)) + ((arithmetic-shift) ((apply c-op '<< (cdr x)) st)) + ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st)) + ((%and) ((apply c-op "&&" (cdr x)) st)) + ((%or) ((apply c-op "||" (cdr x)) st)) + ((%. %field) ((apply c-op "." (cdr x)) st)) + ((%->) ((apply c-op "->" (cdr x)) st)) + (else + (cond + ((eq? (car x) (string->symbol ".")) + ((apply c-op "." (cdr x)) st)) + ((eq? (car x) (string->symbol "->")) + ((apply c-op "->" (cdr x)) st)) + ((eq? (car x) (string->symbol "++")) + ((apply c-op "++" (cdr x)) st)) + ((eq? (car x) (string->symbol "--")) + ((apply c-op "--" (cdr x)) st)) + ((eq? (car x) (string->symbol "+=")) + ((apply c-op "+=" (cdr x)) st)) + ((eq? (car x) (string->symbol "-=")) + ((apply c-op "-=" (cdr x)) st)) + (else ((c-apply x) st)))))) + ((vector? x) + ((c-wrap-stmt + (fmt-try-fit + (fmt-let 'no-wrap? #t + (cat "{" (fmt-join c-expr (vector->list x) ", ") "}")) + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((cat "{" (fmt-join c-expr (vector->list x) sep) + "}" nl) + st))))) + st)) + (else + ((c-literal x) st)))))) + + (define (c-apply ls) + (c-wrap-stmt + (c-with-op + 'paren + (cat (c-expr (car ls)) + (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", ")))) + (fmt-if + fmt-no-wrap? + (c-paren flat) + (c-paren + (fmt-try-fit + flat + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((fmt-join c-expr (cdr ls) sep) st))))))))))) + + (define (c-expr x) + (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; comments, with Emacs-friendly escaping of nested comments + + (define (make-comment-writer st) + (let ((output (fmt-ref st 'writer))) + (lambda (str st) + (let ((lim (- (string-length str) 1))) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\/ i))) + (if j + (let ((st (if (and (> j 0) + (eqv? #\* (string-ref str (- j 1)))) + (output + "\\/" + (output (substring/shared str i j) st)) + (output (substring/shared str i (+ j 1)) st)))) + (lp (+ j 1) + (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1)))) + (output "\\" st) + st))) + (output (substring/shared str i) st)))))))) + + (define (c-comment . args) + (lambda (st) + ((cat "/*" (fmt-let 'writer (make-comment-writer st) + (apply-cat args)) + "*/") + st))) + + (define (make-block-comment-writer st) + (let ((output (make-comment-writer st)) + (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* "))) + (lambda (str st) + (let ((lim (string-length str))) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\newline i))) + (if j + (lp (+ j 1) + (output indent (output (substring/shared str i j) st))) + (output (substring/shared str i) st)))))))) + + (define (c-block-comment . args) + (lambda (st) + (let ((col (fmt-col st)) + (row (fmt-row st)) + (indent (c-current-indent-string st))) + ((cat "/* " + (fmt-let 'writer (make-block-comment-writer st) (apply-cat args)) + (lambda (st) + (cond + ((= row (fmt-row st)) ((dsp " */") st)) + ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st)) + (else ((cat fl indent " */") st))))) + st)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; preprocessor + + (define (make-cpp-writer st) + (let ((output (fmt-ref st 'writer))) + (lambda (str st) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\newline i))) + (if j + (lp (+ j 1) + (output + nl-str + (output " \\" (output (substring/shared str i j) st)))) + (output (substring/shared str i) st))))))) + + (define (cpp-include file) + (if (string? file) + (cat fl "#include " (wrt file) fl) + (cat fl "#include <" file ">" fl))) + + (define (list-dot x) + (cond ((pair? x) (list-dot (cdr x))) + ((null? x) #f) + (else x))) + + (define (flatten-list ls) + (let lp ((ls ls) (res '())) + (cond ((pair? ls) (lp (cdr ls) (cons (car ls) res))) + ((null? ls) (reverse res)) + (else (reverse (cons ls res)))))) + + (define (replace-tree from to x) + (let replace ((x x)) + (cond ((eq? x from) to) + ((pair? x) (cons (replace (car x)) (replace (cdr x)))) + (else x)))) + + (define (cpp-define x . body) + (define (name-of x) (c-expr (if (pair? x) (cadr x) x))) + (lambda (st) + (let* ((body (cond + ((and (pair? x) (list-dot x)) + => (lambda (dot) + (if (eq? dot '...) + body + (replace-tree dot '__VA_ARGS__ body)))) + (else body))) + (params (map (lambda (x) (if (pair? x) (cadr x) x)) + (flatten-list (if (pair? x) (cdr x) '())))) + (tail + (if (pair? body) + (cat " " + (fmt-let 'writer (make-cpp-writer st) + (fmt-let 'macro-params params + ((if (or (not (pair? x)) + (and (null? (cdr body)) + (c-literal? (car body)))) + (lambda (x) x) + c-paren) + (c-in-expr (apply c-begin body)))))) + (lambda (x) x)))) + ((c-in-expr + (if (pair? x) + (cat fl "#define " (name-of (car x)) + (c-paren + (fmt-join/dot name-of + (lambda (dot) (dsp "...")) + (cdr x) + ", ")) + tail fl) + (cat fl "#define " (c-expr x) tail fl))) + st)))) + + (define (cpp-expr x) + (if (or (symbol? x) (string? x)) (dsp x) (c-expr x))) + + (define (cpp-if/aux name check . o) + (let* ((pass (and (pair? o) (car o))) + (comment (if (member name '("ifdef" "ifndef")) + (cat " " + (c-comment + " " (if (equal? name "ifndef") "! " "") + check " ")) + "")) + (endif (if pass (cat fl "#endif" comment) "")) + (tail (cond + ((and (pair? o) (pair? (cdr o))) + (if (pair? (cddr o)) + (apply cpp-elif (cdr o)) + (cat (cpp-else) (cadr o) endif))) + (else endif)))) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((cat fl "#" name " " (cpp-expr check) fl + (if pass (cat indent pass) "") fl + tail fl) + st))))) + + (define (cpp-if check . o) + (apply cpp-if/aux "if" check o)) + (define (cpp-ifdef check . o) + (apply cpp-if/aux "ifdef" check o)) + (define (cpp-ifndef check . o) + (apply cpp-if/aux "ifndef" check o)) + (define (cpp-elif check . o) + (apply cpp-if/aux "elif" check o)) + (define (cpp-else . o) + (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl)) + (define (cpp-endif . o) + (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl)) + + (define (cpp-wrap-header name . body) + (let ((name name)) ; consider auto-mangling + (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl)))) + + (define (cpp-line num . o) + (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl)) + + (define (cpp-generic name . ls) + (cat fl "#" name (apply-cat ls) fl)) + + (define (cpp-undef . args) (apply cpp-generic "undef" args)) + (define (cpp-pragma . args) (apply cpp-generic "pragma" args)) + (define (cpp-error . args) (apply cpp-generic "error" args)) + (define (cpp-warning . args) (apply cpp-generic "warning" args)) + + (define (cpp-stringify x) + (cat "#" x)) + + (define (cpp-sym-cat . args) + (fmt-join dsp args " ## ")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; general indentation and brace rules + + (define (c-current-indent-string st . o) + (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0))))) + + (define (c-indent st . o) + (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4) + (if (pair? o) (car o) 0)))))) + + (define (c-indent/switch st) + (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4))))) + + (define (c-open-brace st) + (if (fmt-newline-before-brace? st) + (begin + (fmt-set! st 'newline-before-brace? #t) + (cat "{" nl)) + (begin + (fmt-set! st 'newline-before-brace? #t) + (cat " {" nl)))) + + (define (c-close-brace st) + (dsp "}")) + + (define (c-wrap-stmt x) + (fmt-if fmt-expression? + (c-expr x) + (cat (c-in-expr (c-expr x)) ";" nl))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; code blocks + + (define (c-block . args) + (apply c-block/aux 0 args)) + + (define (c-block/aux offset header body0 . body) + (let ((inner (apply c-begin body0 body))) + (if (or (pair? body) + (not (or (c-literal? body0) + (and (pair? body0) + (not (c-control-operator? (car body0))))))) + (c-braced-block/aux offset header inner) + (lambda (st) + (if (fmt-braceless-bodies? st) + ((cat header fl (c-indent st offset) inner fl) st) + ((c-braced-block/aux offset header inner) st)))))) + + (define (c-braced-block . args) + (apply c-braced-block/aux 0 args)) + + (define (c-braced-block/aux offset header . body) + (lambda (st) + ((cat (if header header "") (c-open-brace st) (c-indent st offset) + (apply c-begin body) fl + (c-current-indent-string st offset) (c-close-brace st)) + st))) + + (define (c-begin . args) + (apply c-begin/aux #f args)) + + (define (c-begin/aux ret? body0 . body) + (if (null? body) + (c-expr body0) + (lambda (st) + (if (fmt-expression? st) + ((fmt-try-fit + (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", ")) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st)))) + st) + (let ((orig-ret? (fmt-return? st))) + ((fmt-join/last c-expr + (lambda (x) (fmt-let 'return? orig-ret? (c-expr x))) + (cons body0 body) + (cat fl (c-current-indent-string st))) + (fmt-set! st 'return? (and ret? orig-ret?)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; data structures + + (define (c-struct/aux type x . o) + ;; can be just pointer to SUC, need to support such case: + ;; struct whatever * - body is just '*' + (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) + (body (if name (if (not (null? o)) (car o) '()) x)) + (o (if (null? o) o (cdr o)))) + (if (and (not (null? body)) + (not (eq? '* body))) + (c-wrap-stmt + (cat + (c-braced-block + (cat type (if (and name (not (equal? name ""))) (cat " " name) "")) + (cat + (c-in-stmt + (if (list? body) + (apply c-begin (map c-wrap-stmt (map c-field body))) + (c-wrap-stmt (c-expr body)))))) + (if (pair? o) (cat " " (apply c-begin o)) (dsp "")))) + (c-wrap-stmt + (cat type + (if (and name (not (equal? name ""))) + (cat " " name) + "") + (if (not (null? body)) + (cat body) + "")))))) + + (define (c-struct . args) (apply c-struct/aux "struct" args)) + (define (c-union . args) (apply c-struct/aux "union" args)) + (define (c-class . args) (apply c-struct/aux "class" args)) + + (define (c-enum x . o) + (define (c-enum-one x) + (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x))) + (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) + (vals (if name (car o) x))) + (c-wrap-stmt + (cat + (c-braced-block + (if name (cat "enum " name) (dsp "enum")) + (c-in-expr (apply c-begin (map c-enum-one vals)))))))) + + (define (c-attribute . args) + (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; basic control structures + + (define (c-while check . body) + (c-reset-newline + (if (null? body) + (cat "while (" (c-in-test (c-expr check)) ");") + (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")") + (c-in-stmt (apply c-begin body))) + fl)))) + + (define (c-for init check update . body) + (c-reset-newline + (cat + (c-block + (c-in-expr + (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; " + (c-expr update ) ")")) + (c-in-stmt (apply c-begin body))) + fl))) + + (define (c-param x) + (cond + ((procedure? x) x) + ((pair? x) (c-param-type (car x) (cadr x))) + (else (error "missing type" x)))) + + (define (c-field x) + (cond + ((procedure? x) x) + ((pair? x) + (if (list? (car x)) + (case (caar x) + ((union struct class) + (if (> (length x) 1) + (c-type (car x) + (cadr x)) + (c-type (car x)))) + (else (c-type (car x) (cadr x)))) + (c-type (car x) + (fmt-join c-expr (cdr x) ", ")))) + (else (error "missing type" x)))) + + (define (c-param-list ls) + (if (null? ls) + (c-type 'void) + (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))) + + (define (c-fun type name params . body) + (cat (c-block (c-in-expr (c-prototype type name params)) + (c-in-stmt (apply c-begin body))) + fl)) + + (define (c-prototype type name params . o) + (c-wrap-stmt + (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")" + (fmt-join/prefix c-expr o " ")))) + + (define (c-static x) (cat "static " (c-expr x))) + (define (c-const x) (cat "const " (c-expr x))) + (define (c-restrict x) (cat "restrict " (c-expr x))) + (define (c-volatile x) (cat "volatile " (c-expr x))) + (define (c-auto x) (cat "auto " (c-expr x))) + (define (c-inline x) (cat "inline " (c-expr x))) + (define (c-extern x) (cat "extern " (c-expr x))) + (define (c-extern/C . body) + (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl)) + + (define (c-type type . o) + (let ((name (and (pair? o) (car o)))) + (cond + ((pair? type) + (case (car type) + ((%fun) + (cat (c-type (cadr type) #f) + " (*" (or name "") ")(" + (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")")) + ((%array) + (let ((name (cat name "[" (if (pair? (cddr type)) + (c-expr (caddr type)) + "") + "]"))) + (c-type (cadr type) name))) + ((%pointer *) + (let ((name (cat "*" (if name (c-expr name) "")))) + (c-type (cadr type) + (if (and (pair? (cadr type)) (eq? '%array (caadr type))) + (c-paren name) + name)))) + ((enum) (apply c-enum name (cdr type))) + ((struct union class) + (cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) ""))) + (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) + ((not type) + (lambda (st) ((c-type 'int name) st))) + (else + (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) + + (define (c-param-type type . o) + (let ((name (and (pair? o) (car o)))) + (cond + ((pair? type) + (case (car type) + ((%fun) + (cat (c-type (cadr type) #f) + " (*" (or name "") ")(" + (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")")) + ((%array) + (let ((name (cat name "[" (if (pair? (cddr type)) + (c-expr (caddr type)) + "") + "]"))) + (c-type (cadr type) name))) + ((%pointer *) + (let ((name (cat "*" (if name (c-expr name) "")))) + (c-type (cadr type) + (if (and (pair? (cadr type)) (eq? '%array (caadr type))) + (c-paren name) + name)))) + (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) + ((not type) + (lambda (st) ((c-type 'int name) st))) + (else + (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) + + (define (c-var type name . init) + (c-wrap-stmt + (if (pair? init) + (cat (c-type type name) " = " (c-expr (car init))) + (c-type type (if (pair? name) + (fmt-join c-expr name ", ") + (c-expr name)))))) + + (define (c-cast type expr) + (cat "(" (c-type type) ")" (c-expr expr))) + + (define (c-typedef type alias . o) + (c-wrap-stmt + (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " ")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Generalized IF: allows multiple tail forms for if/else if/.../else + ;; blocks. A final ELSE can be signified with a test of #t or 'else, + ;; or by simply using an odd number of expressions (by which the + ;; normal 2 or 3 clause IF forms are special cases). + + (define (c-if/stmt c p . rest) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((let lp ((c c) (p p) (ls rest)) + (if (or (eq? c 'else) (eq? c #t)) + (if (not (null? ls)) + (error "forms after else clause in IF" c p ls) + (cat (c-block/aux -1 " else" p) fl)) + (let ((tail (if (pair? ls) + (if (pair? (cdr ls)) + (lp (car ls) (cadr ls) (cddr ls)) + (lp 'else (car ls) '())) + fl))) + (cat (c-block/aux + (if (eq? ls rest) 0 -1) + (cat (if (eq? ls rest) (lambda (x) x) " else ") + "if (" (c-in-test (c-expr c)) ")") p) + tail)))) + st)))) + + (define (c-if/expr c p . rest) + (let lp ((c c) (p p) (ls rest)) + (cond + ((or (eq? c 'else) (eq? c #t)) + (if (not (null? ls)) + (error "forms after else clause in IF" c p ls) + (c-expr p))) + ((pair? ls) + (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : " + (if (pair? (cdr ls)) + (lp (car ls) (cadr ls) (cddr ls)) + (lp 'else (car ls) '())))) + (else + (c-or (c-in-test (c-expr c)) (c-expr p)))))) + + (define (c-if . args) + (fmt-if fmt-expression? + (apply c-if/expr args) + (apply c-if/stmt args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; switch statements, automatic break handling + + (define (c-label name) + (lambda (st) + (let ((indent (make-space (max 0 (- (fmt-col st) 2))))) + ((cat fl indent name ":" fl) st)))) + + (define c-break + (c-wrap-stmt (dsp "break"))) + (define c-continue + (c-wrap-stmt (dsp "continue"))) + (define (c-return . result) + (if (pair? result) + (c-wrap-stmt (cat "return " (c-expr (car result)))) + (c-wrap-stmt (dsp "return")))) + (define (c-goto label) + (c-wrap-stmt (cat "goto " (c-expr label)))) + + (define (c-switch val . clauses) + (c-reset-newline + (lambda (st) + ((cat "switch (" (c-in-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) + st)))) + + (define (c-switch-clause/breaks x) + (lambda (st) + (let* ((break? + (and (car x) + (not (member (cadr x) '(case/fallthrough + default/fallthrough + else/fallthrough))))) + (explicit-case? (member (cadr x) '(case case/fallthrough))) + (indent (c-current-indent-string st)) + (indent-body (c-indent st)) + (sep (string-append ":" nl-str indent))) + ((cat (c-in-expr + (fmt-join/suffix + dsp + (cond + ((pair? (cadr x)) + (map (lambda (y) (cat (dsp "case ") (c-expr y))) + (cadr x))) + (explicit-case? + (map (lambda (y) (cat (dsp "case ") (c-expr y))) + (if (list? (caddr x)) + (caddr x) + (list (caddr x))))) + ((member (cadr x) + '(default else default/fallthrough else/fallthrough)) + (list (dsp "default"))) + (else + (error + "unknown switch clause, expected a list or default but got" + (cadr x)))) + sep)) + (make-space (or (fmt-indent-space st) 4)) + (fmt-join c-expr + (if explicit-case? (cdddr x) (cddr x)) + indent-body) + (if (and break? (not (fmt-return? st))) + (cat fl indent-body c-break) + "")) + st)))) + + (define (c-switch-clause x) + (if (procedure? x) x (c-switch-clause/breaks (cons #t x)))) + (define (c-switch-clause/no-break x) + (if (procedure? x) x (c-switch-clause/breaks (cons #f x)))) + + (define (c-case x . body) + (c-switch-clause (cons (if (pair? x) x (list x)) body))) + (define (c-case/fallthrough x . body) + (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body))) + (define (c-default . body) + (c-switch-clause/breaks (cons #t (cons 'else body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; operators + + (define (c-op op first . rest) + (if (null? rest) + (c-unary-op op first) + (apply c-binary-op op first rest))) + + (define (c-binary-op op . ls) + (define (lit-op? x) (or (c-literal? x) (symbol? x))) + (let ((str (display-to-string op))) + (c-wrap-stmt + (c-maybe-paren + op + (if (or (equal? str ".") (equal? str "->")) + (fmt-join c-expr ls str) + (let ((flat + (fmt-let 'no-wrap? #t + (lambda (st) + ((fmt-join c-expr + ls + (if (and (fmt-non-spaced-ops? st) + (every lit-op? ls)) + str + (string-append " " str " "))) + st))))) + (fmt-if + fmt-no-wrap? + flat + (fmt-try-fit + flat + (lambda (st) + ((fmt-join c-expr + ls + (cat nl (make-space (+ 2 (fmt-col st))) str " ")) + st)))))))))) + + (define (c-unary-op op x) + (c-wrap-stmt + (cat (display-to-string op) (c-maybe-paren op (c-expr x))))) + + ;; some convenience definitions + + (define (c++ . args) (apply c-op "++" args)) + (define (c-- . args) (apply c-op "--" args)) + (define (c+ . args) (apply c-op '+ args)) + (define (c- . args) (apply c-op '- args)) + (define (c* . args) (apply c-op '* args)) + (define (c/ . args) (apply c-op '/ args)) + (define (c% . args) (apply c-op '% args)) + (define (c& . args) (apply c-op '& args)) + ;; (define (|c\|| . args) (apply c-op '|\|| args)) + (define (c^ . args) (apply c-op '^ args)) + (define (c~ . args) (apply c-op '~ args)) + (define (c! . args) (apply c-op '! args)) + (define (c&& . args) (apply c-op '&& args)) + ;; (define (|c\|\|| . args) (apply c-op '|\|\|| args)) + (define (c<< . args) (apply c-op '<< args)) + (define (c>> . args) (apply c-op '>> args)) + (define (c== . args) (apply c-op '== args)) + (define (c!= . args) (apply c-op '!= args)) + (define (c< . args) (apply c-op '< args)) + (define (c> . args) (apply c-op '> args)) + (define (c<= . args) (apply c-op '<= args)) + (define (c>= . args) (apply c-op '>= args)) + (define (c= . args) (apply c-op '= args)) + (define (c+= . args) (apply c-op "+=" args)) + (define (c-= . args) (apply c-op "-=" args)) + (define (c*= . args) (apply c-op '*= args)) + (define (c/= . args) (apply c-op '/= args)) + (define (c%= . args) (apply c-op '%= args)) + (define (c&= . args) (apply c-op '&= args)) + ;; (define (|c\|=| . args) (apply c-op '|\|=| args)) + (define (c^= . args) (apply c-op '^= args)) + (define (c<<= . args) (apply c-op '<<= args)) + (define (c>>= . args) (apply c-op '>>= args)) + + (define (c. . args) (apply c-op "." args)) + (define (c-> . args) (apply c-op "->" args)) + + (define (c-bit-or . args) (apply c-op "|" args)) + (define (c-or . args) (apply c-op "||" args)) + (define (c-bit-or= . args) (apply c-op "|=" args)) + + (define (c++/post x) + (cat (c-maybe-paren 'post-increment (c-expr x)) "++")) + (define (c--/post x) + (cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))) diff --git a/sex-macros.module.scm b/sex-macros.module.scm new file mode 100644 index 0000000..f211ab7 --- /dev/null +++ b/sex-macros.module.scm @@ -0,0 +1,8 @@ +(module sex-macros + (register-macro + cat + get-macro + macro? + apply-macro + defmacro) + "sex-macros.scm") diff --git a/sex-macros.scm b/sex-macros.scm index 1faafea..8d1b104 100644 --- a/sex-macros.scm +++ b/sex-macros.scm @@ -1,11 +1,11 @@ -(declare (unit sex-macros)) - (import + scheme + (only fmt fmt) + (chicken base) (chicken plist) (chicken string)) (define (cat-syms s-1 s-2) - (import fmt) (fmt #f s-1 s-2)) (define (cat sym-1 sym-2) @@ -14,18 +14,20 @@ (define (register-macro name arglist body) (put! name 'sex-macro `(lambda ,arglist + (import scheme + (only sex-macros cat)) ,@body))) (define (get-macro name) (eval (get name 'sex-macro))) -(define (sex-macro? form) +(define (macro? form) (and (list? form) (symbol? (car form)) (get (car form) 'sex-macro))) (define (apply-macro form) - (assert (sex-macro? form) + (assert (macro? form) (fmt #f (car form) " is not a macro")) (apply (get-macro (car form)) (cdr form))) diff --git a/sex-modules.module.scm b/sex-modules.module.scm new file mode 100644 index 0000000..7b56569 --- /dev/null +++ b/sex-modules.module.scm @@ -0,0 +1,5 @@ +(module sex-modules + (get-modules-public-forms + load-persistent-module-paths + read-public-interface) + "sex-modules.scm") diff --git a/sex-modules.scm b/sex-modules.scm index 6aba12a..4720e62 100644 --- a/sex-modules.scm +++ b/sex-modules.scm @@ -1,21 +1,20 @@ -; Why `sex-modules`? Probably `modules` unit is reserved by chicken, -; things start to break. -(declare (unit sex-modules) - (uses sex-reader - utils)) - -(import brev-separate - (chicken file) - (chicken load) - (chicken pathname) - (chicken process-context) - (chicken string) - fmt - srfi-1) +(import + scheme + brev-separate + (chicken base) + (chicken file) + (chicken load) + (chicken pathname) + (chicken process-context) + (chicken string) + fmt + reader + srfi-1 + utils) (define +persistent-module-paths+ (list)) -(define (get-public-forms module-list) +(define (get-modules-public-forms module-list) ;; Module list is a list of symbols ;; How Sex handles modules: ;; For each module in a list, construct path, find module by path in @@ -69,7 +68,7 @@ (case (car form) ((pub) (case (cadr form) - ((fn) ; replace with prototype + ((fn) ; replace with prototype ;; fn type name (arg-list) (body) ;; 1 2 3 4 - we need first 4 (cons (take (cdr form) 4) acc)) diff --git a/sexc.module.scm b/sexc.module.scm new file mode 100644 index 0000000..d4cc041 --- /dev/null +++ b/sexc.module.scm @@ -0,0 +1 @@ +(module sexc (main) "sexc.scm") diff --git a/sexc.scm b/sexc.scm index 745cbfc..7deb677 100644 --- a/sexc.scm +++ b/sexc.scm @@ -1,12 +1,6 @@ -(declare (unit sexc) - (uses fmt-c-writer - sex-reader - utils - semen)) - -(include "utils.macros.scm") - -(import brev-separate +(import scheme + brev-separate + (chicken base) (chicken file) (chicken plist) (chicken pretty-print) @@ -14,10 +8,16 @@ (chicken process-context) (chicken port) fmt + fmt-c-writer getopt-long + sex-macros + sex-modules + reader + semen srfi-1 ; list routines srfi-13 - tree) + tree + utils) ;;; Main function facilities @@ -32,9 +32,9 @@ (value #f) (single-char #\c)) (emit-c "Emit C code" - (required #f) - (value #f) - (single-char #\C)) + (required #f) + (value #f) + (single-char #\C)) (public-interface "Get module's public interface" (required #f) (value #f)) @@ -86,10 +86,10 @@ (define (emit-c-or-sex sex-forms output args) (write-to-file-or-stdout output - (lambda () - (if (get-arg args 'macro-expand #f) - (map pp sex-forms) - (emit-c sex-forms))))) + (lambda () + (if (get-arg args 'macro-expand #f) + (map pp sex-forms) + (emit-c sex-forms))))) (define (compile-to-file sex-forms output args) (let ((compiler (or (get-arg args 'c-compiler #f) @@ -116,7 +116,7 @@ (if (eq? input-source 'stdin) (semen-process raw-forms) (with-directory input-source - (semen-process raw-forms)))) + (semen-process raw-forms)))) (define prelude '((include inttypes.h) diff --git a/tests/Makefile b/tests/Makefile index 8b13789..0f07326 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1 +1,45 @@ +CHICKEN_C = csc +CSC_FLAGS += -K prefix -static +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 +TEST_SRCS = $(TESTS:%=%.scm) + +sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ) + $(CHICKEN_C) $(CSC_FLAGS) run.scm -o sex-tests -link sexc + +#------------------------------------------------------------------ + +utils.o: utils.module.scm ../utils.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils + +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 + +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 + +semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils + +sex-fmt-c.o: ../sex-fmt-c.scm + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c + +fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils + +sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o + $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils + +clean: + rm -f $(OBJ) + rm -f *.import.scm + rm -f *.link + rm -f sex-tests diff --git a/tests/basic.scm b/tests/basic.scm index 8b0dfe9..0f588df 100644 --- a/tests/basic.scm +++ b/tests/basic.scm @@ -1,3 +1,5 @@ +(import fmt-c-writer) + (test-group "basic" ;; unkebabify diff --git a/tests/fmt-c-writer.module.scm b/tests/fmt-c-writer.module.scm new file mode 100644 index 0000000..5e8036e --- /dev/null +++ b/tests/fmt-c-writer.module.scm @@ -0,0 +1,3 @@ +(module fmt-c-writer + * + "../fmt-c-writer.scm") diff --git a/tests/reader.module.scm b/tests/reader.module.scm new file mode 100644 index 0000000..a4bc673 --- /dev/null +++ b/tests/reader.module.scm @@ -0,0 +1,3 @@ +(module reader + * + "../reader.scm") diff --git a/tests/reader.scm b/tests/reader.scm index 8edb836..c626c66 100644 --- a/tests/reader.scm +++ b/tests/reader.scm @@ -1,4 +1,5 @@ -(import (chicken port)) +(import (chicken port) + reader) (define-syntax reader-test (syntax-rules () diff --git a/tests/run.scm b/tests/run.scm index 2e09267..2ea0e53 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,10 +1,4 @@ -(declare (uses fmt-c-writer - semen)) - (import - (chicken process) - (chicken process-context) - srfi-1 test) (include "basic.scm") diff --git a/tests/semen.module.scm b/tests/semen.module.scm new file mode 100644 index 0000000..25e8734 --- /dev/null +++ b/tests/semen.module.scm @@ -0,0 +1,2 @@ +(module semen * + "../semen.scm") diff --git a/tests/semen.scm b/tests/semen.scm index 722776f..b5c4465 100644 --- a/tests/semen.scm +++ b/tests/semen.scm @@ -1,4 +1,5 @@ -(import srfi-69) +(import srfi-69 + semen) (define print-str-fn '(fn void print-str ((string s)) @@ -38,11 +39,11 @@ (define (form-identity form env) form) - (test 'a (semen-walk-form 'a form-identity (make-hash-table))) - (test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table))) + (test 'a (walk-form 'a form-identity (make-hash-table))) + (test '(a b c) (walk-form '(a b c) form-identity (make-hash-table))) - (test 'a (semen-macro-expand 'a)) - (test '(a b c) (semen-macro-expand '(a b c))) + (test 'a (macro-expand 'a)) + (test '(a b c) (macro-expand '(a b c))) (let ((sex-code-macro '((defmacro (x10 a) diff --git a/tests/sex-macros.module.scm b/tests/sex-macros.module.scm new file mode 100644 index 0000000..3b1fa16 --- /dev/null +++ b/tests/sex-macros.module.scm @@ -0,0 +1,3 @@ +(module sex-macros + * + "../sex-macros.scm") diff --git a/tests/sex-modules.module.scm b/tests/sex-modules.module.scm new file mode 100644 index 0000000..6994c79 --- /dev/null +++ b/tests/sex-modules.module.scm @@ -0,0 +1,3 @@ +(module sex-modules + * + "../sex-modules.scm") diff --git a/tests/sexc.module.scm b/tests/sexc.module.scm new file mode 100644 index 0000000..a0be047 --- /dev/null +++ b/tests/sexc.module.scm @@ -0,0 +1 @@ +(module sexc (main) "../sexc.scm") diff --git a/tests/utils.module.scm b/tests/utils.module.scm new file mode 100644 index 0000000..a8e64b8 --- /dev/null +++ b/tests/utils.module.scm @@ -0,0 +1,3 @@ +(module utils + * + "../utils.scm") diff --git a/tests/utils.scm b/tests/utils.scm index 6f9013f..504341a 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,3 +1,5 @@ +(import utils) + (test-group "utils" (test diff --git a/utils.macros.scm b/utils.macros.scm index 9e8f88f..bf2ed99 100644 --- a/utils.macros.scm +++ b/utils.macros.scm @@ -1,17 +1 @@ (import (chicken process-context)) - -(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)))))) diff --git a/utils.module.scm b/utils.module.scm new file mode 100644 index 0000000..07d8538 --- /dev/null +++ b/utils.module.scm @@ -0,0 +1,10 @@ +(module utils + (get-env-var + set-working-directory + to-absolute-pathname + list-split + list-join + recons + with-directory + ) + "utils.scm") diff --git a/utils.scm b/utils.scm index 57f90d3..c8154fc 100644 --- a/utils.scm +++ b/utils.scm @@ -1,12 +1,26 @@ -(declare (unit utils)) - -(include "utils.macros.scm") - (import + scheme + (chicken base) (chicken pathname) (chicken process-context) 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 (get-env-var name) (get-environment-variable name)) -- 2.52.0 From a951fd81b6df5ffd95f09c9cd895e4acc1f6ffc7 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 10 Mar 2026 19:36:33 +0300 Subject: [PATCH 2/4] remove utils.macros.scm as it is no longer needed --- utils.macros.scm | 1 - 1 file changed, 1 deletion(-) delete mode 100644 utils.macros.scm diff --git a/utils.macros.scm b/utils.macros.scm deleted file mode 100644 index bf2ed99..0000000 --- a/utils.macros.scm +++ /dev/null @@ -1 +0,0 @@ -(import (chicken process-context)) -- 2.52.0 From 24b3e719690993e8b912487909b3f1eb83ba1173 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 28 Apr 2026 14:27:15 +0300 Subject: [PATCH 3/4] update sex-mode.el - add switch and case indents - add begin and default highlighting as keywords --- sex-mode.el | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/sex-mode.el b/sex-mode.el index 8eb676e..05c6ed7 100644 --- a/sex-mode.el +++ b/sex-mode.el @@ -51,7 +51,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") ;; Keywords (list (concat "(" (regexp-opt '( + "begin" "case" + "default" "do" "if" "for" @@ -83,6 +85,8 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (put 'union 'lisp-indent-function 'defun) (put 'var 'lisp-indent-function 0) (put 'import 'lisp-indent-function 1) +(put 'switch 'lisp-indent-function 1) +(put 'case 'lisp-indent-function 1) ;;;###autoload (define-derived-mode sex-mode lisp-data-mode "Sex" -- 2.52.0 From b157315e3d6fdb8b769d3843d02396f6eb474736 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 29 Apr 2026 21:49:32 +0300 Subject: [PATCH 4/4] fix paren placing in fmt Prior to the fix, the Sex code `(while (!= EOF (= c (getc f))) ...)` expanded wrongly to `while (EOF != c = getc(f)) { ...`, instead of `while (EOF != (c = getc(f))) { ...` --- sex-fmt-c.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sex-fmt-c.scm b/sex-fmt-c.scm index 4713c92..6d69a09 100644 --- a/sex-fmt-c.scm +++ b/sex-fmt-c.scm @@ -112,7 +112,7 @@ (lambda (st) ((fmt-let 'op op (if (and (c-op<= (fmt-op st) op) - (not (vector? st))) + (not (vector? x))) (c-paren x) x)) st))) -- 2.52.0