diff --git a/.gitignore b/.gitignore index b53963d..3b07e5b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ *.o +*.import.scm sexc sex-tests diff --git a/Makefile b/Makefile index 50cd21a..2dca326 100644 --- a/Makefile +++ b/Makefile @@ -1,21 +1,24 @@ CHICKEN_C = csc CSC_FLAGS += -K prefix -MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils +# Order matters +MODULES = utils macros reader module-system semen sex-fmt-c fmt-c-writer sexc OBJ = $(MODULES:%=%.o) -sexc: main.o $(OBJ) +sexc: $(OBJ) main.o $(CHICKEN_C) $(CSC_FLAGS) $^ -o $@ main.o: main.scm $(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ %.o: %.scm - $(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@ + $(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%) 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 clean: - rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o + rm -f $(OBJ) main.o ./tests/sex-tests.o + rm -f $(IMPORTS) + rm -f sexc sex-tests diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index c799f52..b919956 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -1,283 +1,285 @@ ;;; Sex fmt-c output writer -(declare (unit fmt-c-writer) - (uses fmt-c - semen - utils)) +(module fmt-c-writer (emit-c + sex-fmt-current-file) + (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) -(import (chicken string) - (chicken syntax) - brev-separate - fmt - matchable - regex - srfi-1 ; lists - srfi-13 ; strings - srfi-39 ; parameters - tree) + (define (unkebabify sym) + (case sym + ((-) sym) + ((--) sym) + ((->) sym) + ((-=) sym) + (else + (string->symbol + (string-substitute "-(?!>)" "_" + (symbol->string sym) #t))))) -(define (unkebabify sym) - (case sym - ((-) sym) - ((--) sym) - ((->) sym) - ((-=) sym) - (else + (define (atom-to-fmt-c atom) + (case atom + ((fn) '%fun) + ((prototype) '%prototype) + ((begin) '%block-begin) + ((define) '%define) + ((pointer) '%pointer) + ((array) '%array) + ((attribute) '%attribute) + ((¤) 'vector-ref) + ((include) '%include) + ;; uh things we do for c89 compatibility + ((bool) 'int) + ((true) 1) + ((false) 0) + (else + (if (symbol? atom) + (unkebabify atom) + atom)))) + + (define (maybe-unwrap-type type) + (if (and (list? type) + (= 1 (length type))) + (car type) + type)) + + (define (make-field-access form) + (assert + (= 2 (length form)) "Wrong field access format") + (unkebabify (string->symbol - (string-substitute "-(?!>)" "_" - (symbol->string sym) #t))))) + (fmt #f (cadr form) (car form))))) -(define (atom-to-fmt-c atom) - (case atom - ((fn) '%fun) - ((prototype) '%prototype) - ((begin) '%block-begin) - ((define) '%define) - ((pointer) '%pointer) - ((array) '%array) - ((attribute) '%attribute) - ((¤) 'vector-ref) - ((include) '%include) - ;; uh things we do for c89 compatibility - ((bool) 'int) - ((true) 1) - ((false) 0) - (else - (if (symbol? atom) - (unkebabify atom) - atom)))) + (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 (maybe-unwrap-type type) - (if (and (list? type) - (= 1 (length type))) - (car type) - type)) + (define (field-access-form? form) + (and (symbol? (car form)) + (char=? #\. (string-ref (symbol->string (car form)) 0)))) -(define (make-field-access form) - (assert - (= 2 (length form)) "Wrong field access format") - (unkebabify - (string->symbol - (fmt #f (cadr form) (car form))))) + (define (walk-expr form) + (match form + ((? vector?) + (list->vector + (walk-expr (vector->list form)))) + ((? atom?) + (atom-to-fmt-c form)) + ((? field-access-form?) + (make-field-access form)) + (('var . _) (walk-var form)) + (('cast expr type) (list '%cast + (walk-type type) + (walk-expr expr))) + (('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)))) -(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 (walk-var form) + ;; (var a int) -> (%var int a) + ;; (var a (const int) 32) -> (%var (const int) a 32) + ;; (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 + )) -(define (field-access-form? form) - (and (symbol? (car form)) - (char=? #\. (string-ref (symbol->string (car form)) 0)))) + (define (walk-type form) + ;; int -> int + ;; (const int) -> const int + ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512) + ;; [float 8] -> (%array float 8) + ;; (* const char) -> (const char *) + ;; (const * const * const char) -> (const char * const * const) + ;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) + (match form + (('¤ . array-type) + (if (integer? (last array-type)) + ;; sized array + (let* ((type-list (drop-right array-type 1)) + (type (maybe-unwrap-type type-list)) + (size (last array-type))) + `(%array ,(walk-type type) + ,size)) + ;; sugar for pointer... Do we really need it? Guess why not, + ;; it's a strong semantic cue + `(%array ,(walk-type (maybe-unwrap-type array-type))))) + (('fn arglist ret-type) + `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) + (('fn . _) + (assert #f "Malformed function type form")) -(define (walk-expr form) - (match form - ((? vector?) - (list->vector - (walk-expr (vector->list form)))) - ((? atom?) - (atom-to-fmt-c form)) - ((? field-access-form?) - (make-field-access form)) - (('var . _) (walk-var form)) - (('cast expr type) (list '%cast - (walk-type type) - (walk-expr expr))) - (('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)))) + ;; Special case: nested structs/unions + ((or ('struct . _) + ('union . _)) (walk-struct form)) -(define (walk-var form) - ;; (var a int) -> (%var int a) - ;; (var a (const int) 32) -> (%var (const int) a 32) - ;; (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 - )) + (('enum . _) (walk-enum form)) + (else + (type-convert-to-c form)))) -(define (walk-type form) - ;; int -> int - ;; (const int) -> const int - ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512) - ;; [float 8] -> (%array float 8) - ;; (* const char) -> (const char *) - ;; (const * const * const char) -> (const char * const * const) - ;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) - (match form - (('¤ . array-type) - (if (integer? (last array-type)) - ;; sized array - (let* ((type-list (drop-right array-type 1)) - (type (maybe-unwrap-type type-list)) - (size (last array-type))) - `(%array ,(walk-type type) - ,size)) - ;; sugar for pointer... Do we really need it? Guess why not, - ;; it's a strong semantic cue - `(%array ,(walk-type (maybe-unwrap-type array-type))))) - (('fn arglist ret-type) - `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) - (('fn . _) - (assert #f "Malformed function type form")) + (define (type-convert-to-c type) + ;; Our pointers to C pointers + ;; int -> int + ;; * const char -> const char * + ;; const * const char -> const char * const + (if (atom? type) (atom-to-fmt-c type) + (flatten + (tree-map atom-to-fmt-c + (flatten + (list-join (reverse (list-split type '*)) + '(*))))))) - ;; Special case: nested structs/unions - ((or ('struct . _) - ('union . _)) (walk-struct form)) - - (('enum . _) (walk-enum form)) - (else - (type-convert-to-c form)))) - -(define (type-convert-to-c type) - ;; Our pointers to C pointers - ;; int -> int - ;; * const char -> const char * - ;; const * const char -> const char * const - (if (atom? type) (atom-to-fmt-c type) - (flatten - (tree-map atom-to-fmt-c - (flatten - (list-join (reverse (list-split type '*)) - '(*))))))) - -(define (walk-fn-def form) - (match form - (('fn name args ret-type . maybe-body) - `(%fun - ,(walk-type ret-type) - ,(atom-to-fmt-c name) - ,(walk-arglist args) - . - ,(walk-expr maybe-body))))) + (define (walk-fn-def form) + (match form + (('fn name args ret-type . maybe-body) + `(%fun + ,(walk-type ret-type) + ,(atom-to-fmt-c name) + ,(walk-arglist args) + . + ,(walk-expr maybe-body))))) ;;; TODO: isn't there a better way? -(define (is-probably-type form) - (case (car form) - ((¤ * const volatile struct union) #t) - (else #f))) + (define (is-probably-type form) + (case (car form) + ((¤ * const volatile struct union) #t) + (else #f))) -(define (walk-arglist form) - ;; E.g.: - ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) - ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) - (map (fn - (match x - (('¤ . _) (walk-type x)) + (define (walk-arglist form) + ;; E.g.: + ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) + ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) + (map (fn + (match x + (('¤ . _) (walk-type x)) - ;; yeah shitty, but I don't know yet how to determine if the - ;; first entry is part of the type and not an argument name - ;; :( - ((? is-probably-type) (walk-type x)) + ;; yeah shitty, but I don't know yet how to determine if the + ;; first entry is part of the type and not an argument name + ;; :( + ((? is-probably-type) (walk-type x)) - ;; 1 element args are always type - ((_) (walk-type x)) + ;; 1 element args are always type + ((_) (walk-type x)) - ((var . type) (append (list (walk-type (maybe-unwrap-type type))) - (list (walk-type var)))))) - form)) + ((var . type) (append (list (walk-type (maybe-unwrap-type type))) + (list (walk-type var)))))) + form)) -(define (walk-function form) - ;; (fn ret-type name arglist body) -> normal function - ;; (fn ret-type name arglist) -> prototype - (if (>= (length form) 5) - (walk-fn-def form) - (cons '%prototype (cdr (walk-fn-def form))))) + (define (walk-function form) + ;; (fn ret-type name arglist body) -> normal function + ;; (fn ret-type name arglist) -> prototype + (if (>= (length form) 5) + (walk-fn-def form) + (cons '%prototype (cdr (walk-fn-def form))))) -(define (process-struct-fields fields) - (map (fn - (let ((type (walk-type (last x)))) - (cons type (map atom-to-fmt-c (drop-right x 1))))) - fields)) + (define (process-struct-fields fields) + (map (fn + (let ((type (walk-type (last x)))) + (cons type (map atom-to-fmt-c (drop-right x 1))))) + fields)) -(define (walk-struct form) - (match form - ((type (fields ...) . attrs) ; anonymous struct - `(,type ,(process-struct-fields fields) - . ,(tree-map atom-to-fmt-c attrs))) - ((type name) ; simple 'struct whatever', like in variable def - `(,type ,(atom-to-fmt-c name))) - ((type name (fields ...) . attrs) - `(,type ,(atom-to-fmt-c name) - ,(process-struct-fields fields) - . ,(tree-map atom-to-fmt-c attrs))) - (else (error "Malformed aggregate definition " form)))) + (define (walk-struct form) + (match form + ((type (fields ...) . attrs) ; anonymous struct + `(,type ,(process-struct-fields fields) + . ,(tree-map atom-to-fmt-c attrs))) + ((type name) ; simple 'struct whatever', like in variable def + `(,type ,(atom-to-fmt-c name))) + ((type name (fields ...) . attrs) + `(,type ,(atom-to-fmt-c name) + ,(process-struct-fields fields) + . ,(tree-map atom-to-fmt-c attrs))) + (else (error "Malformed aggregate definition " form)))) -(define (walk-enum form) - (match form - (('enum (values ...)) - `(enum ,(map atom-to-fmt-c values))) - (('enum name (values ...)) - `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) + (define (walk-enum form) + (match form + (('enum (values ...)) + `(enum ,(map atom-to-fmt-c values))) + (('enum name (values ...)) + `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) -(define (walk-extern form) - (match form - (('fn . _) - ;; extern function?.. What - (list 'extern (walk-function form))) - (('var . _) - (list 'extern (walk-var form))) - (else (error "Extern what?")))) + (define (walk-extern form) + (match form + (('fn . _) + ;; extern function?.. What + (list 'extern (walk-function form))) + (('var . _) + (list 'extern (walk-var form))) + (else (error "Extern what?")))) -(define (walk-public form) - (match form - (('fn . _) - (walk-function form)) - (('var . _) - (walk-var form)) - ((or ('define . _) - ('defmacro . _) + (define (walk-public form) + (match form + (('fn . _) + (walk-function form)) + (('var . _) + (walk-var form)) + ((or ('define . _) + ('defmacro . _) - ('import . _) - ('include . _) + ('import . _) + ('include . _) - ('struct . _) - ('union . _) + ('struct . _) + ('union . _) - ('typedef . _)) - ;; ignore here, used in generating public interface - (process-toplevel-form form)) - (else - (error "Pub what?" (cadr form))))) + ('typedef . _)) + ;; ignore here, used in generating public interface + (process-toplevel-form form)) + (else + (error "Pub what?" (cadr form))))) -(define (process-toplevel-form form) - (match form - (('fn . _) (list 'static (walk-function form))) - (('var . _) (list 'static (walk-var form))) - (('extern . rest) (walk-extern rest)) - (('pub . rest) (walk-public rest)) - ((or ('struct . _) - ('union . _)) (walk-struct form)) - (('enum . _) (walk-enum form)) - (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest)) - (else (walk-expr form)))) + (define (process-toplevel-form form) + (match form + (('fn . _) (list 'static (walk-function form))) + (('var . _) (list 'static (walk-var form))) + (('extern . rest) (walk-extern rest)) + (('pub . rest) (walk-public rest)) + ((or ('struct . _) + ('union . _)) (walk-struct form)) + (('enum . _) (walk-enum form)) + (('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 (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 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 (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))) - (fmt #t (c-expr (process-toplevel-form form)) nl)) - sex-forms)) + (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))) + (fmt #t (c-expr (process-toplevel-form form)) nl)) + sex-forms))) 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/macros.scm b/macros.scm new file mode 100644 index 0000000..7da8a0a --- /dev/null +++ b/macros.scm @@ -0,0 +1,45 @@ +(module macros + (register-macro + cat + get-macro + macro? + apply-macro + defmacro) + (import + scheme + (only fmt fmt) + (chicken base) + (chicken plist) + (chicken string)) + + (define (cat-syms s-1 s-2) + (fmt #f s-1 s-2)) + + (define (cat sym-1 sym-2) + (string->symbol (cat-syms sym-1 sym-2))) + + (define (register-macro name arglist body) + (put! name 'sex-macro + `(lambda ,arglist + (import scheme + (only macros cat)) + ,@body))) + + (define (get-macro name) + (eval (get name 'sex-macro))) + + (define (macro? form) + (and (list? form) + (symbol? (car form)) + (get (car form) 'sex-macro))) + + (define (apply-macro form) + (assert (macro? form) + (fmt #f (car form) " is not a macro")) + (apply (get-macro (car form)) + (cdr form))) + + (define (defmacro form) + (let ((arglist (car form)) + (body (cdr form))) + (register-macro (car arglist) (cdr arglist) body)))) 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/module-system.scm b/module-system.scm new file mode 100644 index 0000000..1eca230 --- /dev/null +++ b/module-system.scm @@ -0,0 +1,92 @@ +(module module-system + (get-modules-public-forms + load-persistent-module-paths + read-public-interface) + + (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-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 + ;; module path directories, extract public definitions from the + ;; module, paste them in current one in emulation of C include + ;; directives. + (fold-right append (list) + (map (fn (import-module (symbol->string x))) + module-list))) + + (define (import-module name) + (let ((module-path (locate-module name))) + (assert module-path (fmt #f "Failed to find module " name " in " + (get-module-paths))) + (read-public-interface module-path))) + + (define (get-module-paths) + (cons (current-directory) + +persistent-module-paths+)) + + (define (locate-module name) + ;; Module locations: relative to file being compiled, or in what was + ;; in SEX_MODULE_PATH env var at the start of the process (see + ;; load-persistent-module-paths function) + + (let ((search-paths (get-module-paths))) + (let loop ((paths search-paths)) + (if (null? paths) + #f + (or (module-exists? name (car paths)) + (loop (cdr paths))))))) + + (define (module-exists? name module-dir) + ;; returns absolute path to module, if it exists + (and (directory-exists? module-dir) + (let ((module-path (make-absolute-pathname module-dir name "sex"))) + (and (file-exists? module-path) + (file-readable? module-path) + module-path)))) + + (define (read-public-interface module-path) + ;; pub fns are reduced to prototypes, other pub forms are just pasted + (let ((raw-forms (read-from-file module-path))) + (fold + process-public-interface-form + (list) + raw-forms))) + +;;; TODO: use semen facilities to analyze modules + (define (process-public-interface-form form acc) + (case (car form) + ((pub) + (case (cadr form) + ((fn) ; replace with prototype + ;; fn type name (arg-list) (body) + ;; 1 2 3 4 - we need first 4 + (cons (take (cdr form) 4) acc)) + ((define defmacro import include struct typedef union var) + (cons (cdr form) acc)) + (else (error "Pub what? " (cadr form))))) + (else acc))) + + (define (load-persistent-module-paths) + (let ((sex-module-path-env-var + (get-env-var "SEX_MODULE_PATH"))) + (when sex-module-path-env-var + (set! +persistent-module-paths+ + (map (lambda (p) + (make-absolute-pathname p #f #f)) + (string-split sex-module-path-env-var ":"))))))) diff --git a/reader.scm b/reader.scm new file mode 100644 index 0000000..8c722b7 --- /dev/null +++ b/reader.scm @@ -0,0 +1,64 @@ +(module reader (read-from-file + read-raw-forms) + (import + scheme + (chicken base) + (chicken io) + (chicken pathname) + (chicken port) + (chicken read-syntax) + (chicken string) + (chicken syntax) + 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) + (read-forms (cons r acc))))) + + (define (read-from-file file) + (with-directory file + (with-input-from-file (pathname-strip-directory file) + (fn (read-forms (list)))))) + + (define (read-bracket port) + (let loop ((c (read-char port)) + (str (string))) + (cond ((char=? c #\]) + (cons '¤ + (with-input-from-string str + (fn (port-map identity read))))) + ((char=? c #\[) + (loop port (conc ))) + (else + (loop (read-char port) + (conc str c)))))) + + (define open-bracket-counter (make-parameter 0)) + + (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)) + (read-from-file input-source)))) diff --git a/semen.scm b/semen.scm index 8912dc1..bc42680 100644 --- a/semen.scm +++ b/semen.scm @@ -1,17 +1,22 @@ ;;; Sex semantic engine -(declare (unit semen) - (uses sex-macros - sex-modules - utils)) +(module semen () + (import + scheme + (chicken base) + (chicken keyword) + (chicken string) + (chicken module) + fmt + macros + matchable ; pattern matching + module-system + srfi-1 ; list routines + srfi-69 ; hash tables + utils + ) -(import - (chicken string) - fmt - matchable ; pattern matching - srfi-1 ; list routines - srfi-69 ; hash tables - ) + (export/rename (process semen-process)) ;;; for lambda extraction, docstring processing, macro expansion, ;;; injection of module headers, i.e. all things that rearrange code @@ -21,86 +26,86 @@ ;;; 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) - (cond - ((null? forms) (reverse acc)) - ((sex-macro? (car forms)) - (semen-process-rec - (semen-apply-macro (car forms) (cdr forms)) - acc)) - (else - (semen-process-rec (cdr forms) - (match-sex-form (car forms) acc))))) + (define (process-rec forms acc) + (cond + ((null? forms) (reverse acc)) + ((macro? (car forms)) + (process-rec + (macroexpand (car forms) (cdr forms)) + acc)) + (else + (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. - (let ((res (apply-macro macro-form))) - (if (list? (car res)) - (append res rest-forms) - (cons res 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) + (cons res rest-forms)))) -(define (match-sex-form sex-form acc) - (match sex-form - ((or ('fn . _) - ('pub 'fn . _) - ('extern 'fn . _)) (process-fn sex-form acc)) - ((or ('struct . _) - ('pub 'struct . _)) (process-struct sex-form acc)) - ((or ('union . _) - ('pub 'union . _)) (process-struct sex-form acc)) - ((or ('enum . _) - ('pub 'enum . _)) (process-struct sex-form acc)) - ((or ('var . _) - ('pub 'var . _) - ('extern 'var . _)) (process-global-var sex-form acc)) - (('include _) (cons sex-form acc)) - (('define . _) (cons sex-form acc)) + (define (match-sex-form sex-form acc) + (match sex-form + ((or ('fn . _) + ('pub 'fn . _) + ('extern 'fn . _)) (process-fn sex-form acc)) + ((or ('struct . _) + ('pub 'struct . _)) (process-struct sex-form acc)) + ((or ('union . _) + ('pub 'union . _)) (process-struct sex-form acc)) + ((or ('enum . _) + ('pub 'enum . _)) (process-struct sex-form acc)) + ((or ('var . _) + ('pub 'var . _) + ('extern 'var . _)) (process-global-var sex-form acc)) + (('include _) (cons sex-form acc)) + (('define . _) (cons sex-form acc)) - (('import . modules) - (semen-process-imports (get-public-forms modules) acc)) + (('import . modules) + (process-imports (get-modules-public-forms modules) acc)) - ((or ('defmacro . rest) - ('pub 'defmacro . rest)) (defmacro rest) acc) + ((or ('defmacro . rest) + ('pub 'defmacro . rest)) (defmacro rest) acc) - ((or ('typedef new-type target) - ('pub 'typedef new-type target)) - (process-typedef new-type target acc)) + ((or ('typedef new-type target) + ('pub 'typedef new-type target)) + (process-typedef new-type target acc)) - (else (assert #f (fmt #f "Unknown top level form " sex-form))))) + (else (assert #f (fmt #f "Unknown top level form " sex-form))))) -(define (semen-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)) - (else - (semen-process-imports (cdr module-public-forms) - (cons (car 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) + (process-imports (cdr module-public-forms) acc)) + (else + (process-imports (cdr module-public-forms) + (cons (car module-public-forms) + acc)))))) -(define (semen-macro-expand form) - "Walk the form recursively and expand all macros, until none is left." - (semen-walk-form - form - (lambda (subform env) - (if (sex-macro? subform) - (cons semen-walk-embed-result (semen-apply-macro subform (list))) - subform)) - #f)) + (define (macro-expand form) + "Walk the form recursively and expand all macros, until none is left." + (walk-form + form + (lambda (subform env) + (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,128 +113,129 @@ ;;; For inspiration, see SBCL's walk.lisp and their template ;;; system. -(define semen-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 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) - (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)) - (else - (let ((new-car (semen-walk-form (car new-form) walk-fn env)) - (new-cdr (semen-walk-form (cdr new-form) walk-fn env))) - (cond ((and (pair? new-car) - (eq? (car new-car) semen-walk-embed-result)) - (append (cdr new-car) new-cdr)) - (else - (recons new-form new-car new-cdr))))))))) + (define (walk-form form walk-fn env) + (if (atom? form) form + (let ((new-form (walk-fn form env))) + (cond ((not (eq? form new-form)) + (walk-form new-form walk-fn env)) + (else + (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) walk-embed-result)) + (append (cdr new-car) new-cdr)) + (else + (recons new-form new-car new-cdr))))))))) ;;; Typdef -(define (process-typedef new-type target acc) - (cons `(typedef ,target ,new-type) acc)) + (define (process-typedef new-type target acc) + (cons `(typedef ,target ,new-type) acc)) ;;; Fn processing -(define (process-fn sex-fn acc) - (let* ((expanded (semen-macro-expand sex-fn)) - (env (make-hash-table)) - (processed - (semen-walk-form - expanded - semen-fn-walker - (begin - (set! (hash-table-ref env :fn-name) (sex-fn-name expanded)) - (set! (hash-table-ref env :lambda-counter) 0) - (set! (hash-table-ref env :lambda-aux-code) (list)) - env)))) + (define (process-fn sex-fn acc) + (let* ((expanded (macro-expand sex-fn)) + (env (make-hash-table)) + (processed + (walk-form + expanded + fn-walker + (begin + (set! (hash-table-ref env #:fn-name) (sex-fn-name expanded)) + (set! (hash-table-ref env #:lambda-counter) 0) + (set! (hash-table-ref env #:lambda-aux-code) (list)) + env)))) - (cons processed - (append (hash-table-ref env :lambda-aux-code) acc)))) + (cons processed + (append (hash-table-ref env #:lambda-aux-code) acc)))) -(define (semen-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)))) - (set! (hash-table-ref env :lambda-aux-code) - (append (semen-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)) + (define (fn-walker form env) + (if (eq? 'lambda (car form)) + (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 (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)) -(define (semen-make-lambda-name enclosing-fn-name counter) - (string->symbol - (fmt #f "__lambda_" counter "_" enclosing-fn-name))) + (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) - (match form - (('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))) - (else (assert #f (fmt #f "Malformed lambda " form))))) + (define (make-aux-lambda-struct name form) + (match form + (('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))) + (else (assert #f (fmt #f "Malformed lambda " form))))) ;;; Structs -(define (process-struct sex-struct acc) - (cons sex-struct acc)) + (define (process-struct sex-struct acc) + (cons sex-struct acc)) -(define (process-global-var sex-var acc) - (cons sex-var acc)) + (define (process-global-var sex-var acc) + (cons sex-var acc)) ;;; Utils -(define (non-empty-list? form) - (and (list? form) - (not (null? form)))) + (define (non-empty-list? form) + (and (list? form) + (not (null? form)))) -(define (sex-fn? form) - "The `form` must be toplevel. + (define (sex-fn? form) + "The `form` must be toplevel. Returns #f if the form is not a function, returns the form otherwise" - (match form - ((fn . _) form) - ((pub fn . _) form) - (else #f))) + (match form + ((fn . _) form) + ((pub fn . _) form) + (else #f))) -(define (sex-fn-public? fn-form) - (eq? (car fn-form) 'pub)) + (define (sex-fn-public? fn-form) + (eq? (car fn-form) 'pub)) -(define (sex-fn-return-type fn-form) - (assert (sex-fn? fn-form) - (fmt #f "Form " fn-form " is not a function")) - (if (sex-fn-public? fn-form) - (third fn-form) - (second fn-form))) + (define (sex-fn-return-type fn-form) + (assert (sex-fn? fn-form) + (fmt #f "Form " fn-form " is not a function")) + (if (sex-fn-public? fn-form) + (third fn-form) + (second fn-form))) -(define (sex-fn-name fn-form) - (assert (sex-fn? fn-form) - (fmt #f "Form " fn-form " is not a function")) - (if (sex-fn-public? fn-form) - (fourth fn-form) - (third fn-form))) + (define (sex-fn-name fn-form) + (assert (sex-fn? fn-form) + (fmt #f "Form " fn-form " is not a function")) + (if (sex-fn-public? fn-form) + (fourth fn-form) + (third fn-form))) -(define (sex-fn-arglist fn-form) - (assert (sex-fn? fn-form) - (fmt #f "Form " fn-form " is not a function")) - (if (sex-fn-public? fn-form) - (fifth fn-form) - (fourth fn-form))) + (define (sex-fn-arglist fn-form) + (assert (sex-fn? fn-form) + (fmt #f "Form " fn-form " is not a function")) + (if (sex-fn-public? fn-form) + (fifth fn-form) + (fourth fn-form))) -(define (sex-fn-prototype fn-form) - "Returns all except body" - (assert (sex-fn? fn-form) - (fmt #f "Form " fn-form " is not a function")) - (if (sex-fn-public? fn-form) - (take fn-form 5) - (take fn-form 4))) + (define (sex-fn-prototype fn-form) + "Returns all except body" + (assert (sex-fn? fn-form) + (fmt #f "Form " fn-form " is not a function")) + (if (sex-fn-public? fn-form) + (take fn-form 5) + (take fn-form 4))) -(define (sex-fn-body fn-form) - (assert (sex-fn? fn-form) - (fmt #f "Form " fn-form " is not a function")) - (if (sex-fn-public? fn-form) - (drop fn-form 5) - (drop fn-form 4))) + (define (sex-fn-body fn-form) + (assert (sex-fn? fn-form) + (fmt #f "Form " fn-form " is not a function")) + (if (sex-fn-public? fn-form) + (drop fn-form 5) + (drop fn-form 4))) + ) 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.scm b/sex-macros.scm deleted file mode 100644 index 1faafea..0000000 --- a/sex-macros.scm +++ /dev/null @@ -1,36 +0,0 @@ -(declare (unit sex-macros)) - -(import - (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) - (string->symbol (cat-syms sym-1 sym-2))) - -(define (register-macro name arglist body) - (put! name 'sex-macro - `(lambda ,arglist - ,@body))) - -(define (get-macro name) - (eval (get name 'sex-macro))) - -(define (sex-macro? form) - (and (list? form) - (symbol? (car form)) - (get (car form) 'sex-macro))) - -(define (apply-macro form) - (assert (sex-macro? form) - (fmt #f (car form) " is not a macro")) - (apply (get-macro (car form)) - (cdr form))) - -(define (defmacro form) - (let ((arglist (car form)) - (body (cdr form))) - (register-macro (car arglist) (cdr arglist) body))) diff --git a/sex-modules.scm b/sex-modules.scm deleted file mode 100644 index 6aba12a..0000000 --- a/sex-modules.scm +++ /dev/null @@ -1,88 +0,0 @@ -; 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) - -(define +persistent-module-paths+ (list)) - -(define (get-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 - ;; module path directories, extract public definitions from the - ;; module, paste them in current one in emulation of C include - ;; directives. - (fold-right append (list) - (map (fn (import-module (symbol->string x))) - module-list))) - -(define (import-module name) - (let ((module-path (locate-module name))) - (assert module-path (fmt #f "Failed to find module " name " in " - (get-module-paths))) - (read-public-interface module-path))) - -(define (get-module-paths) - (cons (current-directory) - +persistent-module-paths+)) - -(define (locate-module name) - ;; Module locations: relative to file being compiled, or in what was - ;; in SEX_MODULE_PATH env var at the start of the process (see - ;; load-persistent-module-paths function) - - (let ((search-paths (get-module-paths))) - (let loop ((paths search-paths)) - (if (null? paths) - #f - (or (module-exists? name (car paths)) - (loop (cdr paths))))))) - -(define (module-exists? name module-dir) - ;; returns absolute path to module, if it exists - (and (directory-exists? module-dir) - (let ((module-path (make-absolute-pathname module-dir name "sex"))) - (and (file-exists? module-path) - (file-readable? module-path) - module-path)))) - -(define (read-public-interface module-path) - ;; pub fns are reduced to prototypes, other pub forms are just pasted - (let ((raw-forms (read-from-file module-path))) - (fold - process-public-interface-form - (list) - raw-forms))) - -;;; TODO: use semen facilities to analyze modules -(define (process-public-interface-form form acc) - (case (car form) - ((pub) - (case (cadr form) - ((fn) ; replace with prototype - ;; fn type name (arg-list) (body) - ;; 1 2 3 4 - we need first 4 - (cons (take (cdr form) 4) acc)) - ((define defmacro import include struct typedef union var) - (cons (cdr form) acc)) - (else (error "Pub what? " (cadr form))))) - (else acc))) - -(define (load-persistent-module-paths) - (let ((sex-module-path-env-var - (get-env-var "SEX_MODULE_PATH"))) - (when sex-module-path-env-var - (set! +persistent-module-paths+ - (map (lambda (p) - (make-absolute-pathname p #f #f)) - (string-split sex-module-path-env-var ":")))))) diff --git a/sex-reader.scm b/sex-reader.scm deleted file mode 100644 index e68c075..0000000 --- a/sex-reader.scm +++ /dev/null @@ -1,63 +0,0 @@ -(declare (unit sex-reader)) - -(include "utils.macros.scm") - -(import - (chicken base) - (chicken io) - (chicken pathname) - (chicken port) - (chicken read-syntax) - (chicken string) - (chicken syntax) - brev-separate - fmt) - -(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 (read-from-file file) - (with-directory file - (with-input-from-file (pathname-strip-directory file) - (fn (read-forms (list)))))) - -(define (read-bracket port) - (let loop ((c (read-char port)) - (str (string))) - (cond ((char=? c #\]) - (cons '¤ - (with-input-from-string str - (fn (port-map identity read))))) - ((char=? c #\[) - (loop port (conc ))) - (else - (loop (read-char port) - (conc str c)))))) - -(define open-bracket-counter (make-parameter 0)) - -(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)) - (read-from-file input-source))) diff --git a/sexc.scm b/sexc.scm index 745cbfc..839e842 100644 --- a/sexc.scm +++ b/sexc.scm @@ -1,166 +1,167 @@ -(declare (unit sexc) - (uses fmt-c-writer - sex-reader - utils - semen)) - -(include "utils.macros.scm") - -(import brev-separate - (chicken file) - (chicken plist) - (chicken pretty-print) - (chicken process) - (chicken process-context) - (chicken port) - fmt - getopt-long - srfi-1 ; list routines - srfi-13 - tree) +(module sexc (main) + (import scheme + brev-separate + (chicken base) + (chicken file) + (chicken plist) + (chicken pretty-print) + (chicken process) + (chicken process-context) + (chicken port) + fmt + fmt-c-writer + getopt-long + macros + module-system + reader + semen + srfi-1 ; list routines + srfi-13 + tree + utils) ;;; Main function facilities -(define opts-grammar - (let ((padding 26)) - `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl - (pad padding) "environment variable, or if it is empty, to cc") - (required #f) - (value #t)) - (compile-object "Compile object file instead of executable program" + (define opts-grammar + (let ((padding 26)) + `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl + (pad padding) "environment variable, or if it is empty, to cc") + (required #f) + (value #t)) + (compile-object "Compile object file instead of executable program" + (required #f) + (value #f) + (single-char #\c)) + (emit-c "Emit C code" + (required #f) + (value #f) + (single-char #\C)) + (public-interface "Get module's public interface" + (required #f) + (value #f)) + (help "Show this help" + (required #f) + (value #f) + (single-char #\h)) + (macro-expand "Emit macro-expanded semantically processed Sex code" (required #f) (value #f) - (single-char #\c)) - (emit-c "Emit C code" - (required #f) - (value #f) - (single-char #\C)) - (public-interface "Get module's public interface" - (required #f) - (value #f)) - (help "Show this help" - (required #f) - (value #f) - (single-char #\h)) - (macro-expand "Emit macro-expanded semantically processed Sex code" - (required #f) - (value #f) - (single-char #\m)) - (output ,(fmt #f "Write output to file. Default file name is a.out." nl - (pad padding) "If -E or -m options are provided, defaults to stdout") - (required #f) - (value #t) - (single-char #\o))))) + (single-char #\m)) + (output ,(fmt #f "Write output to file. Default file name is a.out." nl + (pad padding) "If -E or -m options are provided, defaults to stdout") + (required #f) + (value #t) + (single-char #\o))))) -(define (print-help) - (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n") - (fmt #t "Options:\n") - (fmt #t (usage opts-grammar)) - (fmt #t "")) + (define (print-help) + (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n") + (fmt #t "Options:\n") + (fmt #t (usage opts-grammar)) + (fmt #t "")) -(define (help-arg? args) - (assoc 'help args)) + (define (help-arg? args) + (assoc 'help args)) -(define (get-arg args arg-name default) - (let ((arg (assoc arg-name args))) - (if arg (cdr arg) - default))) + (define (get-arg args arg-name default) + (let ((arg (assoc arg-name args))) + (if arg (cdr arg) + default))) -(define (get-rest-args args) - (cdr (assoc '@ args))) + (define (get-rest-args args) + (cdr (assoc '@ args))) -(define (get-c-compiler-args args) - (filter (fn (string-prefix? "-" x)) (get-rest-args args))) + (define (get-c-compiler-args args) + (filter (fn (string-prefix? "-" x)) (get-rest-args args))) -(define (get-input-file args) - (let ((rest-args (get-rest-args args))) - (if (null? rest-args) - 'stdin - (car rest-args)))) + (define (get-input-file args) + (let ((rest-args (get-rest-args args))) + (if (null? rest-args) + 'stdin + (car rest-args)))) -(define (write-to-file-or-stdout output what) - (if (eq? output 'default) - (what) - (with-output-to-file output - (fn (what))))) + (define (write-to-file-or-stdout output what) + (if (eq? output 'default) + (what) + (with-output-to-file output + (fn (what))))) -(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))))) + (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))))) -(define (compile-to-file sex-forms output 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))))) + (define (compile-to-file sex-forms output 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))))) -(define (semantic-process-forms raw-forms input-source) - (if (eq? input-source 'stdin) - (semen-process raw-forms) - (with-directory input-source - (semen-process raw-forms)))) + (define (semantic-process-forms raw-forms input-source) + (if (eq? input-source 'stdin) + (semen-process raw-forms) + (with-directory input-source + (semen-process raw-forms)))) -(define prelude - '((include inttypes.h) + (define prelude + '((include inttypes.h) - (typedef u8 uint8-t) - (typedef i8 int8-t) - (typedef u16 uint16-t) - (typedef i16 int16-t) - (typedef u32 uint32-t) - (typedef i32 int32-t) - (typedef u64 uint64-t) - (typedef i64 int64-t))) + (typedef u8 uint8-t) + (typedef i8 int8-t) + (typedef u16 uint16-t) + (typedef i16 int16-t) + (typedef u32 uint32-t) + (typedef i32 int32-t) + (typedef u64 uint64-t) + (typedef i64 int64-t))) -(define (main) - (let* ((raw-args (command-line-arguments)) - (args (getopt-long raw-args - opts-grammar)) - (output (get-arg args 'output 'default)) - (help (help-arg? args)) + (define (main) + (let* ((raw-args (command-line-arguments)) + (args (getopt-long raw-args + opts-grammar)) + (output (get-arg args 'output 'default)) + (help (help-arg? args)) - (input (get-input-file args)) - (current-dir (current-directory))) - (call/cc - (lambda (return) - (when help - (print-help) - (return #f)) - (when (get-arg args 'public-interface #f) - (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument") + (input (get-input-file args)) + (current-dir (current-directory))) + (call/cc + (lambda (return) + (when help + (print-help) + (return #f)) + (when (get-arg args 'public-interface #f) + (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument") - (write-to-file-or-stdout - output - (fn - (map pp (reverse - (read-public-interface input))))) - (return #f)) - (load-persistent-module-paths) + (write-to-file-or-stdout + output + (fn + (map pp (reverse + (read-public-interface input))))) + (return #f)) + (load-persistent-module-paths) - (sex-fmt-current-file (to-absolute-pathname input)) - (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) - (get-arg args 'emit-c #f)) - ;; 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))))))) + (sex-fmt-current-file (to-absolute-pathname input)) + (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) + (get-arg args 'emit-c #f)) + ;; 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)))))))) 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.scm b/utils.scm index 57f90d3..5add938 100644 --- a/utils.scm +++ b/utils.scm @@ -1,52 +1,77 @@ -(declare (unit utils)) +(module utils + (get-env-var + set-working-directory + to-absolute-pathname + list-split + list-join + recons + with-directory + ) -(include "utils.macros.scm") + (import + scheme + (chicken base) + (chicken pathname) + (chicken process-context) + srfi-1) -(import - (chicken pathname) - (chicken process-context) - srfi-1) + (define-syntax prog1 + (syntax-rules () + ((prog1 form . forms) + (let ((res form)) + (begin . forms) + res)))) -(define (get-env-var name) - (get-environment-variable name)) + (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) + (define (get-env-var name) + (get-environment-variable name)) + + (define (set-working-directory file) + (change-directory + (normalize-pathname + (if (absolute-pathname? file) + (pathname-directory file) + (make-absolute-pathname + (current-directory) + (pathname-directory file)))))) + + (define (to-absolute-pathname pathname) + (if (absolute-pathname? pathname) + pathname (make-absolute-pathname (current-directory) - (pathname-directory file)))))) + pathname))) -(define (to-absolute-pathname pathname) - (if (absolute-pathname? pathname) - pathname - (make-absolute-pathname - (current-directory) - pathname))) + (define (list-split src-list split-elt) + ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6)) + (fold (lambda (elt acc) + (if (eq? elt split-elt) + (append acc (list (list))) + (append (drop-right acc 1) + (list (append (last acc) (list elt)))))) + (list (list)) + src-list)) -(define (list-split src-list split-elt) - ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6)) - (fold (lambda (elt acc) - (if (eq? elt split-elt) - (append acc (list (list))) - (append (drop-right acc 1) - (list (append (last acc) (list elt)))))) - (list (list)) - src-list)) - -(define (list-join lists join-by) - (drop-right - (fold (lambda (elt acc) - (append acc (list elt) (list join-by))) - (list) - lists) - 1)) + (define (list-join lists join-by) + (drop-right + (fold (lambda (elt acc) + (append acc (list elt) (list join-by))) + (list) + lists) + 1)) ;;; Reconstruct form -(define (recons old-cons new-car new-cdr) - (if (and (eq? new-car (car old-cons)) - (eq? new-cdr (cdr old-cons))) - old-cons - (cons new-car new-cdr))) + (define (recons old-cons new-car new-cdr) + (if (and (eq? new-car (car old-cons)) + (eq? new-cdr (cdr old-cons))) + old-cons + (cons new-car new-cdr))) + )