alex-eg/sex
1
0
Fork 1
Code Issues 3 Pull Requests 1 Actions Packages Projects 1 Releases Wiki Activity

modularize sex
Some checks failed
Sex CI / build-linux (pull_request) Has been cancelled
Details
Sex CI / build-macos (pull_request) Has been cancelled
Details

Browse Source
This commit is contained in:
alex-eg
2026-02-17 16:11:56 +03:00
parent f5b3fcb399
commit 4c53946f1f
16 changed files with 1853 additions and 1786 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@@ -1,3 +1,4 @@
*.o *.o
*.import.scm
sexc sexc
sex-tests sex-tests

19
Makefile
View File

@@ -1,21 +1,30 @@
CHICKEN_C = csc CHICKEN_C = csc
CSC_FLAGS += -K prefix CSC_FLAGS += -K prefix -static
MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils # Order matters, since module check correctness on compilation
MODULES = utils macros reader module-system semen sex-fmt-c fmt-c-writer sexc
OBJ = $(MODULES:%=%.o) OBJ = $(MODULES:%=%.o)
IMPORTS = $(MODULES:%=%.import.scm)
sexc: main.o $(OBJ) sexc: $(OBJ) main.o
$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@ $(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
main.o: main.scm main.o: main.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ $(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@
module-system.o: module-system.scm reader.import.scm
$(CHICKEN_C) $(CSC_FLAGS) module-system.scm -e -c -J -o module-system.o -unit module-system -uses macros -uses utils
%.import.scm: %.o %.scm
%.o: %.scm %.o: %.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@ $(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%)
sex-tests: $(OBJ) tests/*.scm sex-tests: $(OBJ) tests/*.scm
cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o 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 $(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests
clean: 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

500
fmt-c-writer.scm
View File

@@ -1,283 +1,285 @@
;;; Sex fmt-c output writer ;;; Sex fmt-c output writer
(declare (unit fmt-c-writer) (module fmt-c-writer (emit-c
(uses fmt-c sex-fmt-current-file)
semen (import
utils)) 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) (define (unkebabify sym)
(chicken syntax) (case sym
brev-separate ((-) sym)
fmt ((--) sym)
matchable ((->) sym)
regex ((-=) sym)
srfi-1 ; lists (else
srfi-13 ; strings (string->symbol
srfi-39 ; parameters (string-substitute "-(?!>)" "_"
tree) (symbol->string sym) #t)))))
(define (unkebabify sym) (define (atom-to-fmt-c atom)
(case sym (case atom
((-) sym) ((fn) '%fun)
((--) sym) ((prototype) '%prototype)
((->) sym) ((begin) '%block-begin)
((-=) sym) ((define) '%define)
(else ((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->symbol
(string-substitute "-(?!>)" "_" (fmt #f (cadr form) (car form)))))
(symbol->string sym) #t)))))
(define (atom-to-fmt-c atom) (define (walk-generic-toplevel form)
(case atom (cond ((atom? form) (atom-to-fmt-c form))
((fn) '%fun) ((list? form) (map walk-generic-toplevel form))
((prototype) '%prototype) (else (error "Malformed form " form))))
((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) (define (field-access-form? form)
(if (and (list? type) (and (symbol? (car form))
(= 1 (length type))) (char=? #\. (string-ref (symbol->string (car form)) 0))))
(car type)
type))
(define (make-field-access form) (define (walk-expr form)
(assert (match form
(= 2 (length form)) "Wrong field access format") ((? vector?)
(unkebabify (list->vector
(string->symbol (walk-expr (vector->list form))))
(fmt #f (cadr form) (car 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) (define (walk-var form)
(cond ((atom? form) (atom-to-fmt-c form)) ;; (var a int) -> (%var int a)
((list? form) (map walk-generic-toplevel form)) ;; (var a (const int) 32) -> (%var (const int) a 32)
(else (error "Malformed form " form)))) ;; (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) (define (walk-type form)
(and (symbol? (car form)) ;; int -> int
(char=? #\. (string-ref (symbol->string (car form)) 0)))) ;; (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) ;; Special case: nested structs/unions
(match form ((or ('struct . _)
((? vector?) ('union . _)) (walk-struct form))
(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-var form) (('enum . _) (walk-enum form))
;; (var a int) -> (%var int a) (else
;; (var a (const int) 32) -> (%var (const int) a 32) (type-convert-to-c form))))
;; (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 (walk-type form) (define (type-convert-to-c type)
;; int -> int ;; Our pointers to C pointers
;; (const int) -> const int ;; int -> int
;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512) ;; * const char -> const char *
;; [float 8] -> (%array float 8) ;; const * const char -> const char * const
;; (* const char) -> (const char *) (if (atom? type) (atom-to-fmt-c type)
;; (const * const * const char) -> (const char * const * const) (flatten
;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) (tree-map atom-to-fmt-c
(match form (flatten
(('¤ . array-type) (list-join (reverse (list-split 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"))
;; Special case: nested structs/unions (define (walk-fn-def form)
((or ('struct . _) (match form
('union . _)) (walk-struct form)) (('fn name args ret-type . maybe-body)
`(%fun
(('enum . _) (walk-enum form)) ,(walk-type ret-type)
(else ,(atom-to-fmt-c name)
(type-convert-to-c form)))) ,(walk-arglist args)
.
(define (type-convert-to-c type) ,(walk-expr maybe-body)))))
;; 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)))))
;;; TODO: isn't there a better way? ;;; TODO: isn't there a better way?
(define (is-probably-type form) (define (is-probably-type form)
(case (car form) (case (car form)
((¤ * const volatile struct union) #t) ((¤ * const volatile struct union) #t)
(else #f))) (else #f)))
(define (walk-arglist form) (define (walk-arglist form)
;; E.g.: ;; E.g.:
;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
(map (fn (map (fn
(match x (match x
(('¤ . _) (walk-type x)) (('¤ . _) (walk-type x))
;; yeah shitty, but I don't know yet how to determine if the ;; 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 ;; first entry is part of the type and not an argument name
;; :( ;; :(
((? is-probably-type) (walk-type x)) ((? is-probably-type) (walk-type x))
;; 1 element args are always type ;; 1 element args are always type
((_) (walk-type x)) ((_) (walk-type x))
((var . type) (append (list (walk-type (maybe-unwrap-type type))) ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
(list (walk-type var)))))) (list (walk-type var))))))
form)) form))
(define (walk-function form) (define (walk-function form)
;; (fn ret-type name arglist body) -> normal function ;; (fn ret-type name arglist body) -> normal function
;; (fn ret-type name arglist) -> prototype ;; (fn ret-type name arglist) -> prototype
(if (>= (length form) 5) (if (>= (length form) 5)
(walk-fn-def form) (walk-fn-def form)
(cons '%prototype (cdr (walk-fn-def form))))) (cons '%prototype (cdr (walk-fn-def form)))))
(define (process-struct-fields fields) (define (process-struct-fields fields)
(map (fn (map (fn
(let ((type (walk-type (last x)))) (let ((type (walk-type (last x))))
(cons type (map atom-to-fmt-c (drop-right x 1))))) (cons type (map atom-to-fmt-c (drop-right x 1)))))
fields)) fields))
(define (walk-struct form) (define (walk-struct form)
(match form (match form
((type (fields ...) . attrs) ; anonymous struct ((type (fields ...) . attrs) ; anonymous struct
`(,type ,(process-struct-fields fields) `(,type ,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs))) . ,(tree-map atom-to-fmt-c attrs)))
((type name) ; simple 'struct whatever', like in variable def ((type name) ; simple 'struct whatever', like in variable def
`(,type ,(atom-to-fmt-c name))) `(,type ,(atom-to-fmt-c name)))
((type name (fields ...) . attrs) ((type name (fields ...) . attrs)
`(,type ,(atom-to-fmt-c name) `(,type ,(atom-to-fmt-c name)
,(process-struct-fields fields) ,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs))) . ,(tree-map atom-to-fmt-c attrs)))
(else (error "Malformed aggregate definition " form)))) (else (error "Malformed aggregate definition " form))))
(define (walk-enum form) (define (walk-enum form)
(match form (match form
(('enum (values ...)) (('enum (values ...))
`(enum ,(map atom-to-fmt-c values))) `(enum ,(map atom-to-fmt-c values)))
(('enum name (values ...)) (('enum name (values ...))
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
(define (walk-extern form) (define (walk-extern form)
(match form (match form
(('fn . _) (('fn . _)
;; extern function?.. What ;; extern function?.. What
(list 'extern (walk-function form))) (list 'extern (walk-function form)))
(('var . _) (('var . _)
(list 'extern (walk-var form))) (list 'extern (walk-var form)))
(else (error "Extern what?")))) (else (error "Extern what?"))))
(define (walk-public form) (define (walk-public form)
(match form (match form
(('fn . _) (('fn . _)
(walk-function form)) (walk-function form))
(('var . _) (('var . _)
(walk-var form)) (walk-var form))
((or ('define . _) ((or ('define . _)
('defmacro . _) ('defmacro . _)
('import . _) ('import . _)
('include . _) ('include . _)
('struct . _) ('struct . _)
('union . _) ('union . _)
('typedef . _)) ('typedef . _))
;; ignore here, used in generating public interface ;; ignore here, used in generating public interface
(process-toplevel-form form)) (process-toplevel-form form))
(else (else
(error "Pub what?" (cadr form))))) (error "Pub what?" (cadr form)))))
(define (process-toplevel-form form) (define (process-toplevel-form form)
(match form (match form
(('fn . _) (list 'static (walk-function form))) (('fn . _) (list 'static (walk-function form)))
(('var . _) (list 'static (walk-var form))) (('var . _) (list 'static (walk-var form)))
(('extern . rest) (walk-extern rest)) (('extern . rest) (walk-extern rest))
(('pub . rest) (walk-public rest)) (('pub . rest) (walk-public rest))
((or ('struct . _) ((or ('struct . _)
('union . _)) (walk-struct form)) ('union . _)) (walk-struct form))
(('enum . _) (walk-enum form)) (('enum . _) (walk-enum form))
(('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest)) (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
(else (walk-expr form)))) (else (walk-expr form))))
(define (get-line-num form) (define (get-line-num form)
(let ((num (get-line-number form))) (let ((num (get-line-number form)))
(if (string? num) (if (string? num)
(last (string-split num ":")) (last (string-split num ":"))
#f))) #f)))
(define sex-fmt-current-file (make-parameter "/dev/null")) (define sex-fmt-current-file (make-parameter "/dev/null"))
(define sex-fmt-line-num (make-parameter 0)) (define sex-fmt-line-num (make-parameter 0))
(define (line-directive-string) (define (line-directive-string)
(fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\")) (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
(define (emit-c sex-forms) (define (emit-c sex-forms)
(for-each (lambda (form) (for-each (lambda (form)
(let ((start-line (get-line-num form))) (let ((start-line (get-line-num form)))
(when start-line (when start-line
(sex-fmt-line-num start-line) (sex-fmt-line-num start-line)
(fmt #t (line-directive-string) nl))) (fmt #t (line-directive-string) nl)))
(fmt #t (c-expr (process-toplevel-form form)) nl)) (fmt #t (c-expr (process-toplevel-form form)) nl))
sex-forms)) sex-forms)))

959
fmt-c.scm
View File

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

45
macros.scm Normal file
View File

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

3
main.scm
View File

@@ -1,6 +1,5 @@
;;; The purpose of this file is to compile it to the only ;;; The purpose of this file is to compile it to the only
;;; .o that has main entry point. ;;; .o that has main entry point.
(declare (uses sexc)) (import sexc)
(main) (main)

92
module-system.scm Normal file
View File

@@ -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 ":")))))))

64
reader.scm Normal file
View File

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

368
semen.scm
View File

@@ -1,17 +1,22 @@
;;; Sex semantic engine ;;; Sex semantic engine
(declare (unit semen) (module semen ()
(uses sex-macros (import
sex-modules scheme
utils)) (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 (export/rename (process semen-process))
(chicken string)
fmt
matchable ; pattern matching
srfi-1 ; list routines
srfi-69 ; hash tables
)
;;; for lambda extraction, docstring processing, macro expansion, ;;; for lambda extraction, docstring processing, macro expansion,
;;; injection of module headers, i.e. all things that rearrange code ;;; 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 ;;; append their return to the resulting list. Each handler can return
;;; multiple forms, e.g. lambdas collected from a function may result ;;; multiple forms, e.g. lambdas collected from a function may result
;;; in auxiliary structures and functions. ;;; in auxiliary structures and functions.
(define (semen-process raw-sex-forms) (define (process raw-sex-forms)
(semen-process-rec raw-sex-forms (list))) (process-rec raw-sex-forms (list)))
(define (semen-process-rec forms acc) (define (process-rec forms acc)
(cond (cond
((null? forms) (reverse acc)) ((null? forms) (reverse acc))
((sex-macro? (car forms)) ((macro? (car forms))
(semen-process-rec (process-rec
(semen-apply-macro (car forms) (cdr forms)) (macroexpand (car forms) (cdr forms))
acc)) acc))
(else (else
(semen-process-rec (cdr forms) (process-rec (cdr forms)
(match-sex-form (car forms) acc))))) (match-sex-form (car forms) acc)))))
(define (semen-apply-macro macro-form rest-forms) (define (macroexpand macro-form rest-forms)
;; We want to replace macro with its expansion. The problem is, ;; We want to replace macro with its expansion. The problem is,
;; top-level macro can return either a single form, or a list of ;; top-level macro can return either a single form, or a list of
;; forms, when it for example generates some aux ;; forms, when it for example generates some aux
;; structures/functions/typedefs. ;; structures/functions/typedefs.
;; ;;
;; Single form we just cons to the top of rest-forms, but multiple ;; Single form we just cons to the top of rest-forms, but multiple
;; forms have to be appended to the rest-forms. ;; forms have to be appended to the rest-forms.
(let ((res (apply-macro macro-form))) (let ((res (apply-macro macro-form)))
(if (list? (car res)) (if (list? (car res))
(append res rest-forms) (append res rest-forms)
(cons res rest-forms)))) (cons res rest-forms))))
(define (match-sex-form sex-form acc) (define (match-sex-form sex-form acc)
(match sex-form (match sex-form
((or ('fn . _) ((or ('fn . _)
('pub 'fn . _) ('pub 'fn . _)
('extern 'fn . _)) (process-fn sex-form acc)) ('extern 'fn . _)) (process-fn sex-form acc))
((or ('struct . _) ((or ('struct . _)
('pub 'struct . _)) (process-struct sex-form acc)) ('pub 'struct . _)) (process-struct sex-form acc))
((or ('union . _) ((or ('union . _)
('pub 'union . _)) (process-struct sex-form acc)) ('pub 'union . _)) (process-struct sex-form acc))
((or ('enum . _) ((or ('enum . _)
('pub 'enum . _)) (process-struct sex-form acc)) ('pub 'enum . _)) (process-struct sex-form acc))
((or ('var . _) ((or ('var . _)
('pub 'var . _) ('pub 'var . _)
('extern 'var . _)) (process-global-var sex-form acc)) ('extern 'var . _)) (process-global-var sex-form acc))
(('include _) (cons sex-form acc)) (('include _) (cons sex-form acc))
(('define . _) (cons sex-form acc)) (('define . _) (cons sex-form acc))
(('import . modules) (('import . modules)
(semen-process-imports (get-public-forms modules) acc)) (process-imports (get-modules-public-forms modules) acc))
((or ('defmacro . rest) ((or ('defmacro . rest)
('pub 'defmacro . rest)) (defmacro rest) acc) ('pub 'defmacro . rest)) (defmacro rest) acc)
((or ('typedef new-type target) ((or ('typedef new-type target)
('pub 'typedef new-type target)) ('pub 'typedef new-type target))
(process-typedef new-type target acc)) (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) (define (process-imports module-public-forms acc)
;; Recursively process imports: register public macros, cons all ;; Recursively process imports: register public macros, cons all
;; other public things to our acc ;; other public things to our acc
(if (null? module-public-forms) acc (if (null? module-public-forms) acc
(match (car module-public-forms) (match (car module-public-forms)
(('defmacro . rest) (('defmacro . rest)
(defmacro rest) (defmacro rest)
(semen-process-imports (cdr module-public-forms) acc)) (process-imports (cdr module-public-forms) acc))
(else (else
(semen-process-imports (cdr module-public-forms) (process-imports (cdr module-public-forms)
(cons (car module-public-forms) (cons (car module-public-forms)
acc)))))) acc))))))
(define (semen-macro-expand form) (define (macro-expand form)
"Walk the form recursively and expand all macros, until none is left." "Walk the form recursively and expand all macros, until none is left."
(semen-walk-form (walk-form
form form
(lambda (subform env) (lambda (subform env)
(if (sex-macro? subform) (if (macro? subform)
(cons semen-walk-embed-result (semen-apply-macro subform (list))) (cons walk-embed-result (macroexpand subform (list)))
subform)) subform))
#f)) #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 ;;; By default, replaces walked form with walk-fn result But may
;;; perform additional operations depending of what the walk function ;;; perform additional operations depending of what the walk function
;;; has requested. ;;; has requested.
@@ -108,128 +113,129 @@
;;; For inspiration, see SBCL's walk.lisp and their template ;;; For inspiration, see SBCL's walk.lisp and their template
;;; system. ;;; system.
(define semen-walk-embed-result (gensym) (define walk-embed-result (gensym)
;; For cases when result is a list which must be embedded in the ;; For cases when result is a list which must be embedded in the
;; form, e.g. when it returned from a macro ;; form, e.g. when it returned from a macro
) )
(define (semen-walk-form form walk-fn env) (define (walk-form form walk-fn env)
(if (atom? form) form (if (atom? form) form
(let ((new-form (walk-fn form env))) (let ((new-form (walk-fn form env)))
(cond ((not (eq? form new-form)) (cond ((not (eq? form new-form))
(semen-walk-form new-form walk-fn env)) (walk-form new-form walk-fn env))
(else (else
(let ((new-car (semen-walk-form (car new-form) walk-fn env)) (let ((new-car (walk-form (car new-form) walk-fn env))
(new-cdr (semen-walk-form (cdr new-form) walk-fn env))) (new-cdr (walk-form (cdr new-form) walk-fn env)))
(cond ((and (pair? new-car) (cond ((and (pair? new-car)
(eq? (car new-car) semen-walk-embed-result)) (eq? (car new-car) walk-embed-result))
(append (cdr new-car) new-cdr)) (append (cdr new-car) new-cdr))
(else (else
(recons new-form new-car new-cdr))))))))) (recons new-form new-car new-cdr)))))))))
;;; Typdef ;;; Typdef
(define (process-typedef new-type target acc) (define (process-typedef new-type target acc)
(cons `(typedef ,target ,new-type) acc)) (cons `(typedef ,target ,new-type) acc))
;;; Fn processing ;;; Fn processing
(define (process-fn sex-fn acc) (define (process-fn sex-fn acc)
(let* ((expanded (semen-macro-expand sex-fn)) (let* ((expanded (macro-expand sex-fn))
(env (make-hash-table)) (env (make-hash-table))
(processed (processed
(semen-walk-form (walk-form
expanded expanded
semen-fn-walker fn-walker
(begin (begin
(set! (hash-table-ref env :fn-name) (sex-fn-name expanded)) (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-counter) 0)
(set! (hash-table-ref env :lambda-aux-code) (list)) (set! (hash-table-ref env :lambda-aux-code) (list))
env)))) env))))
(cons processed (cons processed
(append (hash-table-ref env :lambda-aux-code) acc)))) (append (hash-table-ref env :lambda-aux-code) acc))))
(define (semen-fn-walker form env) (define (fn-walker form env)
(if (eq? 'lambda (car form)) (if (eq? 'lambda (car form))
(let ((lambda-name (semen-make-lambda-name (hash-table-ref env :fn-name) (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
(hash-table-ref env :lambda-counter)))) (hash-table-ref env :lambda-counter))))
(set! (hash-table-ref env :lambda-aux-code) (set! (hash-table-ref env :lambda-aux-code)
(append (semen-make-aux-lambda-struct lambda-name form) (append (make-aux-lambda-struct lambda-name form)
(hash-table-ref env :lambda-aux-code))) (hash-table-ref env :lambda-aux-code)))
(set! (hash-table-ref env :lambda-counter) (set! (hash-table-ref env :lambda-counter)
(+ (hash-table-ref env :lambda-counter) 1)) (+ (hash-table-ref env :lambda-counter) 1))
lambda-name) lambda-name)
form)) form))
(define (semen-make-lambda-name enclosing-fn-name counter) (define (make-lambda-name enclosing-fn-name counter)
(string->symbol (string->symbol
(fmt #f "__lambda_" counter "_" enclosing-fn-name))) (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
(define (semen-make-aux-lambda-struct name form) (define (make-aux-lambda-struct name form)
(match form (match form
(('lambda ret-type arglist captures . body) (('lambda ret-type arglist captures . body)
;; Captures are ignored for now, but ;; Captures are ignored for now, but
;; we'll need them for TODO: closures support ;; we'll need them for TODO: closures support
(process-fn `(fn ,ret-type ,name ,arglist ,@body) (list))) (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
(else (assert #f (fmt #f "Malformed lambda " form))))) (else (assert #f (fmt #f "Malformed lambda " form)))))
;;; Structs ;;; Structs
(define (process-struct sex-struct acc) (define (process-struct sex-struct acc)
(cons sex-struct acc)) (cons sex-struct acc))
(define (process-global-var sex-var acc) (define (process-global-var sex-var acc)
(cons sex-var acc)) (cons sex-var acc))
;;; Utils ;;; Utils
(define (non-empty-list? form) (define (non-empty-list? form)
(and (list? form) (and (list? form)
(not (null? form)))) (not (null? form))))
(define (sex-fn? form) (define (sex-fn? form)
"The `form` must be toplevel. "The `form` must be toplevel.
Returns #f if the form is not a function, returns the form otherwise" Returns #f if the form is not a function, returns the form otherwise"
(match form (match form
((fn . _) form) ((fn . _) form)
((pub fn . _) form) ((pub fn . _) form)
(else #f))) (else #f)))
(define (sex-fn-public? fn-form) (define (sex-fn-public? fn-form)
(eq? (car fn-form) 'pub)) (eq? (car fn-form) 'pub))
(define (sex-fn-return-type fn-form) (define (sex-fn-return-type fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(third fn-form) (third fn-form)
(second fn-form))) (second fn-form)))
(define (sex-fn-name fn-form) (define (sex-fn-name fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(fourth fn-form) (fourth fn-form)
(third fn-form))) (third fn-form)))
(define (sex-fn-arglist fn-form) (define (sex-fn-arglist fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(fifth fn-form) (fifth fn-form)
(fourth fn-form))) (fourth fn-form)))
(define (sex-fn-prototype fn-form) (define (sex-fn-prototype fn-form)
"Returns all except body" "Returns all except body"
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(take fn-form 5) (take fn-form 5)
(take fn-form 4))) (take fn-form 4)))
(define (sex-fn-body fn-form) (define (sex-fn-body fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(drop fn-form 5) (drop fn-form 5)
(drop fn-form 4))) (drop fn-form 4)))
)

985
sex-fmt-c.scm Normal file
View File

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

36
sex-macros.scm
View File

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

88
sex-modules.scm
View File

@@ -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 ":"))))))

63
sex-reader.scm
View File

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

291
sexc.scm
View File

@@ -1,166 +1,167 @@
(declare (unit sexc) (module sexc (main)
(uses fmt-c-writer (import scheme
sex-reader brev-separate
utils (chicken base)
semen)) (chicken file)
(chicken plist)
(include "utils.macros.scm") (chicken pretty-print)
(chicken process)
(import brev-separate (chicken process-context)
(chicken file) (chicken port)
(chicken plist) fmt
(chicken pretty-print) fmt-c-writer
(chicken process) getopt-long
(chicken process-context) macros
(chicken port) module-system
fmt reader
getopt-long semen
srfi-1 ; list routines srfi-1 ; list routines
srfi-13 srfi-13
tree) tree
utils)
;;; Main function facilities ;;; Main function facilities
(define opts-grammar (define opts-grammar
(let ((padding 26)) (let ((padding 26))
`((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl `((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") (pad padding) "environment variable, or if it is empty, to cc")
(required #f) (required #f)
(value #t)) (value #t))
(compile-object "Compile object file instead of executable program" (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) (required #f)
(value #f) (value #f)
(single-char #\c)) (single-char #\m))
(emit-c "Emit C code" (output ,(fmt #f "Write output to file. Default file name is a.out." nl
(required #f) (pad padding) "If -E or -m options are provided, defaults to stdout")
(value #f) (required #f)
(single-char #\C)) (value #t)
(public-interface "Get module's public interface" (single-char #\o)))))
(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)))))
(define (print-help) (define (print-help)
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n") (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
(fmt #t "Options:\n") (fmt #t "Options:\n")
(fmt #t (usage opts-grammar)) (fmt #t (usage opts-grammar))
(fmt #t "")) (fmt #t ""))
(define (help-arg? args) (define (help-arg? args)
(assoc 'help args)) (assoc 'help args))
(define (get-arg args arg-name default) (define (get-arg args arg-name default)
(let ((arg (assoc arg-name args))) (let ((arg (assoc arg-name args)))
(if arg (cdr arg) (if arg (cdr arg)
default))) default)))
(define (get-rest-args args) (define (get-rest-args args)
(cdr (assoc '@ args))) (cdr (assoc '@ args)))
(define (get-c-compiler-args args) (define (get-c-compiler-args args)
(filter (fn (string-prefix? "-" x)) (get-rest-args args))) (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
(define (get-input-file args) (define (get-input-file args)
(let ((rest-args (get-rest-args args))) (let ((rest-args (get-rest-args args)))
(if (null? rest-args) (if (null? rest-args)
'stdin 'stdin
(car rest-args)))) (car rest-args))))
(define (write-to-file-or-stdout output what) (define (write-to-file-or-stdout output what)
(if (eq? output 'default) (if (eq? output 'default)
(what) (what)
(with-output-to-file output (with-output-to-file output
(fn (what))))) (fn (what)))))
(define (emit-c-or-sex sex-forms output args) (define (emit-c-or-sex sex-forms output args)
(write-to-file-or-stdout output (write-to-file-or-stdout output
(lambda () (lambda ()
(if (get-arg args 'macro-expand #f) (if (get-arg args 'macro-expand #f)
(map pp sex-forms) (map pp sex-forms)
(emit-c sex-forms))))) (emit-c sex-forms)))))
(define (compile-to-file sex-forms output args) (define (compile-to-file sex-forms output args)
(let ((compiler (or (get-arg args 'c-compiler #f) (let ((compiler (or (get-arg args 'c-compiler #f)
(get-env-var "SEX_CC") (get-env-var "SEX_CC")
"cc")) "cc"))
(out-file (if (eq? output 'default) (out-file (if (eq? output 'default)
"a.out" "a.out"
output))) output)))
(call-with-values (call-with-values
(lambda () (lambda ()
(process compiler (append (list "-o" out-file "-x" "c") (process compiler (append (list "-o" out-file "-x" "c")
(if (get-arg args 'compile-object #f) (if (get-arg args 'compile-object #f)
(list "-c") (list "-c")
(list)) (list))
(list "-") ; read stdin (list "-") ; read stdin
(get-c-compiler-args args)))) (get-c-compiler-args args))))
(lambda (out-port in-port pid) (lambda (out-port in-port pid)
(with-output-to-port in-port (with-output-to-port in-port
(lambda () (emit-c sex-forms))) (lambda () (emit-c sex-forms)))
(close-output-port in-port) (close-output-port in-port)
(process-wait pid))))) (process-wait pid)))))
(define (semantic-process-forms raw-forms input-source) (define (semantic-process-forms raw-forms input-source)
(if (eq? input-source 'stdin) (if (eq? input-source 'stdin)
(semen-process raw-forms) (semen-process raw-forms)
(with-directory input-source (with-directory input-source
(semen-process raw-forms)))) (semen-process raw-forms))))
(define prelude (define prelude
'((include inttypes.h) '((include inttypes.h)
(typedef u8 uint8-t) (typedef u8 uint8-t)
(typedef i8 int8-t) (typedef i8 int8-t)
(typedef u16 uint16-t) (typedef u16 uint16-t)
(typedef i16 int16-t) (typedef i16 int16-t)
(typedef u32 uint32-t) (typedef u32 uint32-t)
(typedef i32 int32-t) (typedef i32 int32-t)
(typedef u64 uint64-t) (typedef u64 uint64-t)
(typedef i64 int64-t))) (typedef i64 int64-t)))
(define (main) (define (main)
(let* ((raw-args (command-line-arguments)) (let* ((raw-args (command-line-arguments))
(args (getopt-long raw-args (args (getopt-long raw-args
opts-grammar)) opts-grammar))
(output (get-arg args 'output 'default)) (output (get-arg args 'output 'default))
(help (help-arg? args)) (help (help-arg? args))
(input (get-input-file args)) (input (get-input-file args))
(current-dir (current-directory))) (current-dir (current-directory)))
(call/cc (call/cc
(lambda (return) (lambda (return)
(when help (when help
(print-help) (print-help)
(return #f)) (return #f))
(when (get-arg args 'public-interface #f) (when (get-arg args 'public-interface #f)
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument") (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
(write-to-file-or-stdout (write-to-file-or-stdout
output output
(fn (fn
(map pp (reverse (map pp (reverse
(read-public-interface input))))) (read-public-interface input)))))
(return #f)) (return #f))
(load-persistent-module-paths) (load-persistent-module-paths)
(sex-fmt-current-file (to-absolute-pathname input)) (sex-fmt-current-file (to-absolute-pathname input))
(let* ((raw-forms (append prelude (read-raw-forms input))) (let* ((raw-forms (append prelude (read-raw-forms input)))
(sex-forms (semantic-process-forms raw-forms input))) (sex-forms (semantic-process-forms raw-forms input)))
(if (or (get-arg args 'macro-expand #f) (if (or (get-arg args 'macro-expand #f)
(get-arg args 'emit-c #f)) (get-arg args 'emit-c #f))
;; Emit processed and macro-expanded sex code, or emit C code ;; Emit processed and macro-expanded sex code, or emit C code
(emit-c-or-sex sex-forms output args) (emit-c-or-sex sex-forms output args)
;; Compile file! ;; Compile file!
(compile-to-file sex-forms output args))))))) (compile-to-file sex-forms output args))))))))

16
utils.macros.scm
View File

@@ -1,17 +1 @@
(import (chicken process-context)) (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))))))

109
utils.scm
View File

@@ -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 (define-syntax prog1
(chicken pathname) (syntax-rules ()
(chicken process-context) ((prog1 form . forms)
srfi-1) (let ((res form))
(begin . forms)
res))))
(define (get-env-var name) (define-syntax with-directory
(get-environment-variable name)) (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) (define (get-env-var name)
(change-directory (get-environment-variable name))
(normalize-pathname
(if (absolute-pathname? file) (define (set-working-directory file)
(pathname-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 (make-absolute-pathname
(current-directory) (current-directory)
(pathname-directory file)))))) pathname)))
(define (to-absolute-pathname pathname) (define (list-split src-list split-elt)
(if (absolute-pathname? pathname) ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
pathname (fold (lambda (elt acc)
(make-absolute-pathname (if (eq? elt split-elt)
(current-directory) (append acc (list (list)))
pathname))) (append (drop-right acc 1)
(list (append (last acc) (list elt))))))
(list (list))
src-list))
(define (list-split src-list split-elt) (define (list-join lists join-by)
;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6)) (drop-right
(fold (lambda (elt acc) (fold (lambda (elt acc)
(if (eq? elt split-elt) (append acc (list elt) (list join-by)))
(append acc (list (list))) (list)
(append (drop-right acc 1) lists)
(list (append (last acc) (list elt)))))) 1))
(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))
;;; Reconstruct form ;;; Reconstruct form
(define (recons old-cons new-car new-cdr) (define (recons old-cons new-car new-cdr)
(if (and (eq? new-car (car old-cons)) (if (and (eq? new-car (car old-cons))
(eq? new-cdr (cdr old-cons))) (eq? new-cdr (cdr old-cons)))
old-cons old-cons
(cons new-car new-cdr))) (cons new-car new-cdr)))
)