split semantic processing and fmt-c code generation
Introducing Sex SEMantic ENgine: the semen. Also split reader to other file (it can be replaced in the future). Macro expansion inside Sex code doesn't work yet, and it must be done in semen, not during fmt-c generation as before.
This commit is contained in:
2
Makefile
2
Makefile
@@ -1,6 +1,6 @@
|
|||||||
CHICKEN_C = csc
|
CHICKEN_C = csc
|
||||||
|
|
||||||
MODULES = sexc sex-macros sex-modules utils fmt-c
|
MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
|
||||||
OBJ = $(MODULES:%=%.o)
|
OBJ = $(MODULES:%=%.o)
|
||||||
|
|
||||||
sexc: main.o $(OBJ)
|
sexc: main.o $(OBJ)
|
||||||
|
|||||||
@@ -12,7 +12,7 @@ to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
|
|||||||
environment variables. Refer to the documentation for more info:
|
environment variables. Refer to the documentation for more info:
|
||||||
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
|
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
|
||||||
|
|
||||||
~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13~
|
~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable~
|
||||||
|
|
||||||
** Compilation
|
** Compilation
|
||||||
~make~
|
~make~
|
||||||
|
|||||||
10
example/fns.sex
Normal file
10
example/fns.sex
Normal file
@@ -0,0 +1,10 @@
|
|||||||
|
;;; Prototypes
|
||||||
|
(fn void puk ())
|
||||||
|
|
||||||
|
(pub fn void plak ())
|
||||||
|
|
||||||
|
;;; Functions
|
||||||
|
(fn int foo () (return 1))
|
||||||
|
|
||||||
|
(pub fn void bar ((int a) (int b))
|
||||||
|
(printf "%d\n" (+ a b)))
|
||||||
@@ -2,10 +2,10 @@
|
|||||||
(let ((list-type (cat 'list- type)))
|
(let ((list-type (cat 'list- type)))
|
||||||
`(struct ,list-type
|
`(struct ,list-type
|
||||||
((,type value)
|
((,type value)
|
||||||
((* ,list-type) next)))))
|
((* (struct ,list-type)) next)))))
|
||||||
|
|
||||||
(pub defmacro (make-list-T type is-public?)
|
(pub defmacro (make-list-T type is-public?)
|
||||||
(let ((list-type (cat 'list- type))
|
(let ((list-type (list 'struct (cat 'list- type)))
|
||||||
(fn-name (cat 'make-list- type)))
|
(fn-name (cat 'make-list- type)))
|
||||||
`(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
|
`(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
|
||||||
(var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type))))
|
(var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type))))
|
||||||
@@ -13,7 +13,7 @@
|
|||||||
(return list))))
|
(return list))))
|
||||||
|
|
||||||
(pub defmacro (add-value-list-T type is-public?)
|
(pub defmacro (add-value-list-T type is-public?)
|
||||||
(let ((list-type (cat 'list- type))
|
(let ((list-type (list 'struct (cat 'list- type)))
|
||||||
(fn-name (cat 'add-value-list- type)))
|
(fn-name (cat 'add-value-list- type)))
|
||||||
`(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
|
`(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
|
||||||
(while (!= (-> list next) NULL)
|
(while (!= (-> list next) NULL)
|
||||||
@@ -23,7 +23,7 @@
|
|||||||
|
|
||||||
(pub defmacro (length-list-T type is-public?)
|
(pub defmacro (length-list-T type is-public?)
|
||||||
(let ((fn-name (cat 'length-list- type))
|
(let ((fn-name (cat 'length-list- type))
|
||||||
(list-type (cat 'list- type)))
|
(list-type (list 'struct (cat 'list- type))))
|
||||||
`(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list))
|
`(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list))
|
||||||
(var size-t n 0)
|
(var size-t n 0)
|
||||||
(while (!= (-> list next) NULL)
|
(while (!= (-> list next) NULL)
|
||||||
@@ -33,15 +33,15 @@
|
|||||||
|
|
||||||
(pub defmacro (is-empty-list-T type is-public?)
|
(pub defmacro (is-empty-list-T type is-public?)
|
||||||
`(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type)
|
`(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type)
|
||||||
((,(cat 'list- type) *list))
|
((,(list 'struct (cat 'list- type)) *list))
|
||||||
(return (== (-> list next) NULL))))
|
(return (== (-> list next) NULL))))
|
||||||
|
|
||||||
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
|
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
|
||||||
(let ((list-var-2 (cat list-var '-2)))
|
(let ((list-var-2 (cat list-var '-2)))
|
||||||
`((begin
|
`(begin
|
||||||
(var (pointer ,list-type) ,list-var-2 ,list-var)
|
(var (pointer ,list-type) ,list-var-2 ,list-var)
|
||||||
(var ,elt-type ,elt-var (-> ,list-var-2 value))
|
(var ,elt-type ,elt-var (-> ,list-var-2 value))
|
||||||
(while (!= (-> ,list-var-2 next) NULL)
|
(while (!= (-> ,list-var-2 next) NULL)
|
||||||
,what-do
|
,what-do
|
||||||
(= ,list-var-2 (-> ,list-var-2 next))
|
(= ,list-var-2 (-> ,list-var-2 next))
|
||||||
(= ,elt-var (-> ,list-var-2 value)))))))
|
(= ,elt-var (-> ,list-var-2 value))))))
|
||||||
|
|||||||
@@ -2,20 +2,15 @@
|
|||||||
(include stddef.h)
|
(include stddef.h)
|
||||||
(include stdio.h)
|
(include stdio.h)
|
||||||
|
|
||||||
(chicken-import srfi-1 brev-separate) ; list routines, e.g. fold
|
|
||||||
|
|
||||||
(import list)
|
(import list)
|
||||||
|
|
||||||
(chicken-define (imports-test a b c)
|
|
||||||
(fold + 0 (list 1 2 3 a b c)))
|
|
||||||
|
|
||||||
(struct foo
|
(struct foo
|
||||||
((float a-field)
|
((float a-field)
|
||||||
(int b)
|
(int b)
|
||||||
((const char *) c)
|
((const char *) c)
|
||||||
((fn bool ((bool val))) not)))
|
((fn bool ((bool val))) not)))
|
||||||
|
|
||||||
(var foo f)
|
(var (struct foo) f)
|
||||||
|
|
||||||
(list-T int)
|
(list-T int)
|
||||||
(make-list-T int #f)
|
(make-list-T int #f)
|
||||||
@@ -24,7 +19,6 @@
|
|||||||
(is-empty-list-T int #f)
|
(is-empty-list-T int #f)
|
||||||
|
|
||||||
(extern fn void puk ((int a) (float b)))
|
(extern fn void puk ((int a) (float b)))
|
||||||
(fn int bar () (return ,(imports-test 10 20 30)))
|
|
||||||
(pub fn bool baz () (return true))
|
(pub fn bool baz () (return true))
|
||||||
|
|
||||||
(extern var int i)
|
(extern var int i)
|
||||||
@@ -32,18 +26,18 @@
|
|||||||
(pub var int k)
|
(pub var int k)
|
||||||
|
|
||||||
(pub fn int main ()
|
(pub fn int main ()
|
||||||
(var (* list-int) l (make-list-int))
|
(var (struct list-int) *l (make-list-int))
|
||||||
(printf "Size of the list: %lu\n" (length-list-int l))
|
(printf "Size of the list: %lu\n" (length-list-int l))
|
||||||
(add-value-list-int l 3)
|
(add-value-list-int l 3)
|
||||||
(add-value-list-int l 4)
|
(add-value-list-int l 4)
|
||||||
(printf "Size of the list: %lu\n" (length-list-int l))
|
(printf "Size of the list: %lu\n" (length-list-int l))
|
||||||
(list-for-each list-int l int v
|
(list-for-each (struct list-int) l int v
|
||||||
(printf "%d " v))
|
(printf "%d " v))
|
||||||
(printf "\n")
|
(printf "\n")
|
||||||
(printf "Size of the list: %lu\n" (length-list-int l))
|
(printf "Size of the list: %lu\n" (length-list-int l))
|
||||||
(printf "%p\n" (cast void* l->next))
|
(printf "%p\n" (cast void* l->next))
|
||||||
(return 0))
|
(return 0))
|
||||||
|
|
||||||
(pub fn void print-list (((const list-int) *l))
|
(pub fn void print-list (((const struct list-int) *l))
|
||||||
(list-for-each (const list-int) l int v (printf "%d " v))
|
(list-for-each (const struct list-int) l int v (printf "%d " v))
|
||||||
(printf "\n"))
|
(printf "\n"))
|
||||||
|
|||||||
128
fmt-c-writer.scm
Normal file
128
fmt-c-writer.scm
Normal file
@@ -0,0 +1,128 @@
|
|||||||
|
;;; Sex fmt-c output writer
|
||||||
|
|
||||||
|
(declare (unit fmt-c-writer)
|
||||||
|
(uses fmt-c
|
||||||
|
semen))
|
||||||
|
|
||||||
|
(import (chicken string)
|
||||||
|
brev-separate
|
||||||
|
fmt
|
||||||
|
regex
|
||||||
|
srfi-1 ; lists
|
||||||
|
srfi-13 ; strings
|
||||||
|
)
|
||||||
|
|
||||||
|
(define (unkebabify sym)
|
||||||
|
(case sym
|
||||||
|
((-) sym)
|
||||||
|
((--) sym)
|
||||||
|
((->) sym)
|
||||||
|
((-=) sym)
|
||||||
|
(else
|
||||||
|
(string->symbol
|
||||||
|
(string-substitute "-(?!>)" "_"
|
||||||
|
(symbol->string sym) #t)))))
|
||||||
|
|
||||||
|
(define (atom-to-fmt-c atom)
|
||||||
|
(case atom
|
||||||
|
((fn) '%fun)
|
||||||
|
((prototype) '%prototype)
|
||||||
|
((var) '%var)
|
||||||
|
((begin) '%block-begin)
|
||||||
|
((define) '%define)
|
||||||
|
((pointer) '%pointer)
|
||||||
|
((array) '%array)
|
||||||
|
((attribute) '%attribute)
|
||||||
|
((@) 'vector-ref)
|
||||||
|
((include) '%include)
|
||||||
|
((cast) '%cast)
|
||||||
|
;; uh things we do for c89 compatibility
|
||||||
|
((bool) 'int)
|
||||||
|
((true) 1)
|
||||||
|
((false) 0)
|
||||||
|
(else
|
||||||
|
(if (symbol? atom)
|
||||||
|
(unkebabify atom)
|
||||||
|
atom))))
|
||||||
|
|
||||||
|
(define (make-field-access form)
|
||||||
|
(assert
|
||||||
|
(= 2 (length form)) "Wrong field access format")
|
||||||
|
(unkebabify
|
||||||
|
(string->symbol
|
||||||
|
(fmt #f (cadr form) (car form)))))
|
||||||
|
|
||||||
|
(define (walk-generic form acc)
|
||||||
|
(cond
|
||||||
|
((null? form) (cons '() acc))
|
||||||
|
|
||||||
|
;; vector, e.g. {}-initializer
|
||||||
|
((vector? form)
|
||||||
|
(cons
|
||||||
|
(list->vector
|
||||||
|
(car (walk-generic (vector->list form) (list))))
|
||||||
|
acc))
|
||||||
|
|
||||||
|
;; atom (hopefully)
|
||||||
|
((not (list? form)) (cons (atom-to-fmt-c form) acc))
|
||||||
|
|
||||||
|
;; another special case - field access
|
||||||
|
((and (symbol? (car form))
|
||||||
|
(char=? #\. (string-ref (symbol->string (car form)) 0)))
|
||||||
|
(cons (make-field-access form) acc))
|
||||||
|
|
||||||
|
;; toplevel, or a start of a regular list form
|
||||||
|
(else
|
||||||
|
(let ((new-acc (list)))
|
||||||
|
(cons (fold-right
|
||||||
|
walk-generic
|
||||||
|
new-acc
|
||||||
|
form)
|
||||||
|
acc)))))
|
||||||
|
|
||||||
|
(define (normalize-fn-form form)
|
||||||
|
;; (fn ret-type name arglist body) -> normal function
|
||||||
|
;; (fn ret-type name arglist) -> prototype
|
||||||
|
(if (>= (length form) 5)
|
||||||
|
form
|
||||||
|
(cons 'prototype (cdr form))))
|
||||||
|
|
||||||
|
(define (walk-function form static)
|
||||||
|
(if static
|
||||||
|
(walk-generic (list 'static (normalize-fn-form form))
|
||||||
|
(list))
|
||||||
|
(walk-generic (normalize-fn-form (cdr form))
|
||||||
|
(list))))
|
||||||
|
|
||||||
|
(define (walk-extern form)
|
||||||
|
(case (cadr form)
|
||||||
|
((fn)
|
||||||
|
(list (cons 'extern (walk-function form #f))))
|
||||||
|
((var)
|
||||||
|
(list (cons 'extern (walk-generic (cdr form) (list)))))
|
||||||
|
(else (error "Extern what?"))))
|
||||||
|
|
||||||
|
(define (walk-public form)
|
||||||
|
(case (cadr form)
|
||||||
|
((fn)
|
||||||
|
(walk-function form #f))
|
||||||
|
((var)
|
||||||
|
(walk-generic (list 'static (cdr form)) (list)))
|
||||||
|
((define defmacro import include struct typedef union var)
|
||||||
|
;; ignore here, used in generating public interface
|
||||||
|
(process-toplevel-form (cdr form)))
|
||||||
|
(else
|
||||||
|
(error "Pub what?" (cadr form)))))
|
||||||
|
|
||||||
|
(define (process-toplevel-form form)
|
||||||
|
;; todo: rewrite to match
|
||||||
|
(case (car form)
|
||||||
|
((fn) (walk-function form #t))
|
||||||
|
((extern) (walk-extern form))
|
||||||
|
((pub) (walk-public form))
|
||||||
|
(else (walk-generic form (list)))))
|
||||||
|
|
||||||
|
(define (emit-c sex-forms)
|
||||||
|
(for-each (lambda (form)
|
||||||
|
(fmt #t (c-expr (car (process-toplevel-form form))) nl))
|
||||||
|
sex-forms))
|
||||||
141
semen.scm
Normal file
141
semen.scm
Normal file
@@ -0,0 +1,141 @@
|
|||||||
|
;;; Sex semantic engine
|
||||||
|
|
||||||
|
(declare (unit semen)
|
||||||
|
(uses sex-macros
|
||||||
|
sex-modules))
|
||||||
|
|
||||||
|
(import fmt
|
||||||
|
matchable ; pattern matching
|
||||||
|
srfi-1 ; list routines
|
||||||
|
)
|
||||||
|
|
||||||
|
;;; for lambda extraction, docstring processing, macro expansion,
|
||||||
|
;;; injection of module headers, i.e. all things that rearrange code
|
||||||
|
;;; structurally, add or remove forms
|
||||||
|
;;;
|
||||||
|
;;; The algorithm: feed toplevel forms to appropriate handlers, then
|
||||||
|
;;; append their return to the resulting list. Each handler can return
|
||||||
|
;;; multiple forms, e.g. lambdas collected from a function may result
|
||||||
|
;;; in auxiliary structures and functions.
|
||||||
|
(define (semen-process raw-sex-forms)
|
||||||
|
(semen-process-rec raw-sex-forms (list)))
|
||||||
|
|
||||||
|
(define (semen-process-rec forms acc)
|
||||||
|
(cond
|
||||||
|
((null? forms) (reverse acc))
|
||||||
|
((sex-macro? (car forms))
|
||||||
|
(semen-process-rec
|
||||||
|
(semen-apply-macro (car forms) (cdr forms))
|
||||||
|
acc))
|
||||||
|
(else
|
||||||
|
(semen-process-rec (cdr forms)
|
||||||
|
(match-sex-form (car forms) acc)))))
|
||||||
|
|
||||||
|
(define (semen-apply-macro macro-form rest-forms)
|
||||||
|
;; We want to replace macro with its expansion. The problem is,
|
||||||
|
;; top-level macro can return either a single form, or a list of
|
||||||
|
;; forms, when it for example generates some aux
|
||||||
|
;; structures/functions/typedefs.
|
||||||
|
;;
|
||||||
|
;; Single form we just cons to the top of rest-forms, but multiple
|
||||||
|
;; forms have to be appended to the rest-forms.
|
||||||
|
(let ((res (apply-macro macro-form)))
|
||||||
|
(if (list? (car res))
|
||||||
|
(append res rest-forms)
|
||||||
|
(cons res rest-forms))))
|
||||||
|
|
||||||
|
(define (match-sex-form sex-form acc)
|
||||||
|
(match sex-form
|
||||||
|
((or ('fn . _)
|
||||||
|
('pub 'fn . _)
|
||||||
|
('extern 'fn . _)) (process-fn sex-form acc))
|
||||||
|
((or ('struct . _)
|
||||||
|
('pub struct . _)) (process-struct sex-form acc))
|
||||||
|
((or ('union . _)
|
||||||
|
('pub 'union . _)) (process-struct sex-form acc))
|
||||||
|
((or ('var . _)
|
||||||
|
('pub 'var . _)
|
||||||
|
('extern 'var . _)) (process-global-var sex-form acc))
|
||||||
|
(('include _) (cons sex-form acc))
|
||||||
|
|
||||||
|
(('import . modules)
|
||||||
|
(semen-process-imports (get-public-forms modules) acc))
|
||||||
|
|
||||||
|
((or ('defmacro . rest)
|
||||||
|
('pub 'defmacro . rest)) (defmacro rest) acc)
|
||||||
|
|
||||||
|
(else (assert #f (fmt #f "Unknown top level form " sex-form)))))
|
||||||
|
|
||||||
|
(define (semen-process-imports module-public-forms acc)
|
||||||
|
;; Recursively process imports: register public macros, cons all
|
||||||
|
;; other public things to our acc
|
||||||
|
(if (null? module-public-forms) acc
|
||||||
|
(match (car module-public-forms)
|
||||||
|
(('defmacro . rest)
|
||||||
|
(defmacro rest)
|
||||||
|
(semen-process-imports (cdr module-public-forms) acc))
|
||||||
|
(else
|
||||||
|
(semen-process-imports (cdr module-public-forms)
|
||||||
|
(cons (car module-public-forms)
|
||||||
|
acc))))))
|
||||||
|
|
||||||
|
(define (process-fn sex-fn acc)
|
||||||
|
(cons sex-fn acc))
|
||||||
|
|
||||||
|
(define (process-struct sex-struct acc)
|
||||||
|
(cons sex-struct acc))
|
||||||
|
|
||||||
|
(define (process-global-var sex-var acc)
|
||||||
|
(cons sex-var acc))
|
||||||
|
|
||||||
|
;;; Utils
|
||||||
|
(define (non-empty-list? form)
|
||||||
|
(and (list? form)
|
||||||
|
(not (null? form))))
|
||||||
|
|
||||||
|
(define (sex-fn? form)
|
||||||
|
"The `form` must be toplevel.
|
||||||
|
Returns #f if the form is not a function, returns the form otherwise"
|
||||||
|
(match form
|
||||||
|
((fn . _) form)
|
||||||
|
((pub fn . _) form)
|
||||||
|
(else #f)))
|
||||||
|
|
||||||
|
(define (sex-fn-public? fn-form)
|
||||||
|
(eq? (car fn-form) 'pub))
|
||||||
|
|
||||||
|
(define (sex-fn-return-type fn-form)
|
||||||
|
(assert (sex-fn? fn-form)
|
||||||
|
(fmt #f "Form " fn-form " is not a function"))
|
||||||
|
(if (sex-fn-public? fn-form)
|
||||||
|
(third fn-form)
|
||||||
|
(second fn-form)))
|
||||||
|
|
||||||
|
(define (sex-fn-name fn-form)
|
||||||
|
(assert (sex-fn? fn-form)
|
||||||
|
(fmt #f "Form " fn-form " is not a function"))
|
||||||
|
(if (sex-fn-public? fn-form)
|
||||||
|
(fourth fn-form)
|
||||||
|
(third fn-form)))
|
||||||
|
|
||||||
|
(define (sex-fn-arglist fn-form)
|
||||||
|
(assert (sex-fn? fn-form)
|
||||||
|
(fmt #f "Form " fn-form " is not a function"))
|
||||||
|
(if (sex-fn-public? fn-form)
|
||||||
|
(fifth fn-form)
|
||||||
|
(fourth fn-form)))
|
||||||
|
|
||||||
|
(define (sex-fn-prototype fn-form)
|
||||||
|
"Returns all except body"
|
||||||
|
(assert (sex-fn? fn-form)
|
||||||
|
(fmt #f "Form " fn-form " is not a function"))
|
||||||
|
(if (sex-fn-public? fn-form)
|
||||||
|
(take fn-form 5)
|
||||||
|
(take fn-form 4)))
|
||||||
|
|
||||||
|
(define (sex-fn-body fn-form)
|
||||||
|
(assert (sex-fn? fn-form)
|
||||||
|
(fmt #f "Form " fn-form " is not a function"))
|
||||||
|
(if (sex-fn-public? fn-form)
|
||||||
|
(drop fn-form 5)
|
||||||
|
(drop fn-form 4)))
|
||||||
@@ -19,11 +19,17 @@
|
|||||||
(define (get-macro name)
|
(define (get-macro name)
|
||||||
(eval (get name 'sex-macro)))
|
(eval (get name 'sex-macro)))
|
||||||
|
|
||||||
(define (macro? form)
|
(define (sex-macro? form)
|
||||||
(and (list? form)
|
(and (list? form)
|
||||||
(symbol? (car form))
|
(symbol? (car form))
|
||||||
(get (car form) 'sex-macro)))
|
(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)
|
(define (defmacro form)
|
||||||
(let ((arglist (car form))
|
(let ((arglist (car form))
|
||||||
(body (cdr form)))
|
(body (cdr form)))
|
||||||
|
|||||||
@@ -1,7 +1,8 @@
|
|||||||
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
|
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
|
||||||
; things start to break.
|
; things start to break.
|
||||||
(declare (unit sex-modules)
|
(declare (unit sex-modules)
|
||||||
(uses utils))
|
(uses sex-reader
|
||||||
|
utils))
|
||||||
|
|
||||||
(import brev-separate
|
(import brev-separate
|
||||||
(chicken file)
|
(chicken file)
|
||||||
@@ -14,7 +15,7 @@
|
|||||||
|
|
||||||
(define +persistent-module-paths+ (list))
|
(define +persistent-module-paths+ (list))
|
||||||
|
|
||||||
(define (import-modules module-list)
|
(define (get-public-forms module-list)
|
||||||
;; Module list is a list of symbols
|
;; Module list is a list of symbols
|
||||||
;; How Sex handles modules:
|
;; How Sex handles modules:
|
||||||
;; For each module in a list, construct path, find module by path in
|
;; For each module in a list, construct path, find module by path in
|
||||||
@@ -63,6 +64,7 @@
|
|||||||
(list)
|
(list)
|
||||||
raw-forms)))
|
raw-forms)))
|
||||||
|
|
||||||
|
;;; TODO: use semen facilities to analyze modules
|
||||||
(define (process-public-interface-form form acc)
|
(define (process-public-interface-form form acc)
|
||||||
(case (car form)
|
(case (car form)
|
||||||
((pub)
|
((pub)
|
||||||
|
|||||||
22
sex-reader.scm
Normal file
22
sex-reader.scm
Normal file
@@ -0,0 +1,22 @@
|
|||||||
|
(declare (unit sex-reader))
|
||||||
|
|
||||||
|
(include "utils.macros.scm")
|
||||||
|
|
||||||
|
(import (chicken pathname)
|
||||||
|
brev-separate
|
||||||
|
fmt)
|
||||||
|
|
||||||
|
(define (read-forms acc)
|
||||||
|
(let ((r (read)))
|
||||||
|
(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-raw-forms input-source)
|
||||||
|
(if (eq? input-source 'stdin)
|
||||||
|
(read-forms (list))
|
||||||
|
(read-from-file input-source)))
|
||||||
231
sexc.scm
231
sexc.scm
@@ -1,207 +1,23 @@
|
|||||||
(declare (unit sexc)
|
(declare (unit sexc)
|
||||||
(uses fmt-c
|
(uses fmt-c-writer
|
||||||
sex-macros
|
sex-reader
|
||||||
sex-modules))
|
semen))
|
||||||
|
|
||||||
(include "utils.macros.scm")
|
(include "utils.macros.scm")
|
||||||
|
|
||||||
(import brev-separate
|
(import brev-separate
|
||||||
(chicken file)
|
(chicken file)
|
||||||
(chicken pathname)
|
|
||||||
(chicken plist)
|
(chicken plist)
|
||||||
(chicken pretty-print)
|
(chicken pretty-print)
|
||||||
(chicken process)
|
(chicken process)
|
||||||
(chicken process-context)
|
(chicken process-context)
|
||||||
(chicken port)
|
(chicken port)
|
||||||
(chicken string)
|
|
||||||
fmt
|
fmt
|
||||||
getopt-long
|
getopt-long
|
||||||
regex
|
|
||||||
srfi-1 ; list routines
|
srfi-1 ; list routines
|
||||||
srfi-13 ; string routines
|
srfi-13
|
||||||
tree)
|
tree)
|
||||||
|
|
||||||
(define (unkebabify sym)
|
|
||||||
(case sym
|
|
||||||
((-) sym)
|
|
||||||
((--) sym)
|
|
||||||
((->) sym)
|
|
||||||
((-=) sym)
|
|
||||||
(else
|
|
||||||
(string->symbol
|
|
||||||
(string-substitute "-(?!>)" "_"
|
|
||||||
(symbol->string sym) #t)))))
|
|
||||||
|
|
||||||
(define (atom-to-fmt-c atom)
|
|
||||||
(case atom
|
|
||||||
((fn) '%fun)
|
|
||||||
((prototype) '%prototype)
|
|
||||||
((var) '%var)
|
|
||||||
((begin) '%block-begin)
|
|
||||||
((define) '%define)
|
|
||||||
((pointer) '%pointer)
|
|
||||||
((array) '%array)
|
|
||||||
((attribute) '%attribute)
|
|
||||||
((@) 'vector-ref)
|
|
||||||
((include) '%include)
|
|
||||||
((cast) '%cast)
|
|
||||||
;; uh things we do for c89 compatibility
|
|
||||||
((bool) 'int)
|
|
||||||
((true) 1)
|
|
||||||
((false) 0)
|
|
||||||
(else
|
|
||||||
(if (symbol? atom)
|
|
||||||
(unkebabify atom)
|
|
||||||
atom))))
|
|
||||||
|
|
||||||
(define (make-field-access form)
|
|
||||||
(assert (= 2 (length form)) "Wrong field access format")
|
|
||||||
(unkebabify
|
|
||||||
(string->symbol
|
|
||||||
(fmt #f (cadr form) (car form)))))
|
|
||||||
|
|
||||||
(require-library chicken-syntax)
|
|
||||||
|
|
||||||
(define (walk-generic form acc)
|
|
||||||
(cond
|
|
||||||
((null? form) (cons '() acc))
|
|
||||||
|
|
||||||
;; vector, e.g. {}-initializer
|
|
||||||
((vector? form)
|
|
||||||
(cons
|
|
||||||
(list->vector
|
|
||||||
(car (walk-sex-tree (vector->list form) (list))))
|
|
||||||
acc))
|
|
||||||
|
|
||||||
;; atom (hopefully)
|
|
||||||
((not (list? form)) (cons (atom-to-fmt-c form) acc))
|
|
||||||
|
|
||||||
;; special case - replace unquote with its expansion
|
|
||||||
((eq? (car form) 'unquote)
|
|
||||||
(fold
|
|
||||||
cons
|
|
||||||
acc
|
|
||||||
(car ; bc walk-sex-tree always
|
|
||||||
; wraps its result
|
|
||||||
(walk-sex-tree (eval (cadr form)) (list)))))
|
|
||||||
|
|
||||||
;; another special case - field access
|
|
||||||
((and (symbol? (car form))
|
|
||||||
(char=? #\. (string-ref (symbol->string (car form)) 0)))
|
|
||||||
(cons (make-field-access form) acc))
|
|
||||||
|
|
||||||
;; another special case - macro
|
|
||||||
((macro? form)
|
|
||||||
(append (fold-right
|
|
||||||
walk-generic
|
|
||||||
(list)
|
|
||||||
(apply (get-macro (car form)) (cdr form)))
|
|
||||||
acc))
|
|
||||||
|
|
||||||
;; toplevel, or a start of a regular list form
|
|
||||||
(else
|
|
||||||
(let ((new-acc (list)))
|
|
||||||
(cons (fold-right
|
|
||||||
walk-generic
|
|
||||||
new-acc
|
|
||||||
form)
|
|
||||||
acc)))))
|
|
||||||
|
|
||||||
(define (normalize-fn-form form)
|
|
||||||
;; (fn ret-type name arglist body) -> normal function
|
|
||||||
;; (fn ret-type name arglist) -> prototype
|
|
||||||
(if (>= (length form) 5)
|
|
||||||
form
|
|
||||||
(cons 'prototype (cdr form))))
|
|
||||||
|
|
||||||
(define (walk-function form static acc)
|
|
||||||
(if static
|
|
||||||
(append (walk-generic (list 'static (normalize-fn-form form))
|
|
||||||
(list))
|
|
||||||
acc)
|
|
||||||
(append (walk-generic (normalize-fn-form (cdr form))
|
|
||||||
(list))
|
|
||||||
acc)))
|
|
||||||
|
|
||||||
(define (walk-struct form acc)
|
|
||||||
(let ((name (unkebabify (cadr form))))
|
|
||||||
(append (walk-generic form (list))
|
|
||||||
(cons `(typedef struct ,name ,name) acc))))
|
|
||||||
|
|
||||||
(define (walk-extern form acc)
|
|
||||||
(case (cadr form)
|
|
||||||
((fn)
|
|
||||||
(append
|
|
||||||
(list (cons 'extern (walk-function form #f (list))))
|
|
||||||
acc))
|
|
||||||
((var)
|
|
||||||
(append
|
|
||||||
(list (cons 'extern (walk-generic (cdr form) (list))))
|
|
||||||
acc))
|
|
||||||
(else (error "Extern what?"))))
|
|
||||||
|
|
||||||
(define (walk-public form acc)
|
|
||||||
(case (cadr form)
|
|
||||||
((fn)
|
|
||||||
(walk-function form #f acc))
|
|
||||||
((var)
|
|
||||||
(append (walk-generic (list 'static (cdr form)) (list)) acc))
|
|
||||||
((define defmacro import include struct typedef union var)
|
|
||||||
;; ignore here, used in generating public interface
|
|
||||||
(process-form (cdr form) acc))
|
|
||||||
(else
|
|
||||||
(error "Pub what?" (cadr form)))))
|
|
||||||
|
|
||||||
(define (walk-sex-tree form acc)
|
|
||||||
(if (list? form)
|
|
||||||
(if (macro? form)
|
|
||||||
(fold-right (fn (walk-sex-tree x y))
|
|
||||||
acc
|
|
||||||
(list (apply (get-macro (car form)) (cdr form))))
|
|
||||||
(case (car form)
|
|
||||||
((fn) (walk-function form #t acc))
|
|
||||||
((extern) (walk-extern form acc))
|
|
||||||
((pub) (walk-public form acc))
|
|
||||||
((struct union) (walk-struct form acc))
|
|
||||||
((unquote) (fold (fn (walk-sex-tree x y))
|
|
||||||
acc
|
|
||||||
(eval (cadr form))))
|
|
||||||
(else (append (walk-generic form (list)) acc))))
|
|
||||||
;; only for unquote support
|
|
||||||
(list (list (atom-to-fmt-c form)))))
|
|
||||||
|
|
||||||
(define (process-form form acc)
|
|
||||||
(case (car form)
|
|
||||||
((chicken-define) (eval (cons 'define (cdr form))) acc)
|
|
||||||
((defmacro) (defmacro (cdr form)) acc)
|
|
||||||
((chicken-load)
|
|
||||||
(load (cadr form)) acc)
|
|
||||||
((chicken-import)
|
|
||||||
(eval (cons 'import (cdr form))) acc)
|
|
||||||
((import)
|
|
||||||
(append (process-raw-forms
|
|
||||||
|
|
||||||
(import-modules (cdr form)) (list))
|
|
||||||
acc))
|
|
||||||
(else
|
|
||||||
(walk-sex-tree form acc))))
|
|
||||||
|
|
||||||
(define (process-raw-forms raw-forms acc)
|
|
||||||
(if (null? raw-forms)
|
|
||||||
(reverse acc)
|
|
||||||
(process-raw-forms (cdr raw-forms)
|
|
||||||
(process-form (car raw-forms) acc))))
|
|
||||||
|
|
||||||
(define (read-forms acc)
|
|
||||||
(let ((r (read)))
|
|
||||||
(if (eof-object? r) (reverse acc)
|
|
||||||
(read-forms (cons r acc)))))
|
|
||||||
|
|
||||||
(define (emit-c forms)
|
|
||||||
(for-each (lambda (form)
|
|
||||||
(fmt #t (c-expr form) nl))
|
|
||||||
forms))
|
|
||||||
|
|
||||||
;;; Main function facilities
|
;;; Main function facilities
|
||||||
|
|
||||||
(define opts-grammar
|
(define opts-grammar
|
||||||
@@ -214,10 +30,10 @@
|
|||||||
(required #f)
|
(required #f)
|
||||||
(value #f)
|
(value #f)
|
||||||
(single-char #\c))
|
(single-char #\c))
|
||||||
(preprocess "Emit C code"
|
(emit-c "Emit C code"
|
||||||
(required #f)
|
(required #f)
|
||||||
(value #f)
|
(value #f)
|
||||||
(single-char #\E))
|
(single-char #\C))
|
||||||
(public-interface "Get module's public interface"
|
(public-interface "Get module's public interface"
|
||||||
(required #f)
|
(required #f)
|
||||||
(value #f))
|
(value #f))
|
||||||
@@ -261,20 +77,14 @@
|
|||||||
'stdin
|
'stdin
|
||||||
(car rest-args))))
|
(car rest-args))))
|
||||||
|
|
||||||
(define (read-from-file file)
|
|
||||||
(with-directory file
|
|
||||||
(with-input-from-file (pathname-strip-directory file)
|
|
||||||
(fn (read-forms (list))))))
|
|
||||||
|
|
||||||
(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 (preprocess-or-macroexpand sex-forms output args)
|
(define (emit-c-or-sex sex-forms output args)
|
||||||
(write-to-file-or-stdout
|
(write-to-file-or-stdout output
|
||||||
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)
|
||||||
@@ -301,13 +111,11 @@
|
|||||||
(close-output-port in-port)
|
(close-output-port in-port)
|
||||||
(process-wait pid)))))
|
(process-wait pid)))))
|
||||||
|
|
||||||
(define (process-input input raw-forms)
|
(define (semantic-process-forms raw-forms input-source)
|
||||||
(let ((current-dir (current-directory)))
|
(if (eq? input-source 'stdin)
|
||||||
(unless (eq? input 'stdin)
|
(semen-process raw-forms)
|
||||||
(set-working-directory input))
|
(with-directory input-source
|
||||||
(prog1
|
(semen-process raw-forms))))
|
||||||
(process-raw-forms raw-forms (list))
|
|
||||||
(change-directory current-dir))))
|
|
||||||
|
|
||||||
(define (main)
|
(define (main)
|
||||||
(let* ((raw-args (command-line-arguments))
|
(let* ((raw-args (command-line-arguments))
|
||||||
@@ -334,14 +142,11 @@
|
|||||||
(return #f))
|
(return #f))
|
||||||
(load-persistent-module-paths)
|
(load-persistent-module-paths)
|
||||||
|
|
||||||
(let* ((raw-forms
|
(let* ((raw-forms (read-raw-forms input))
|
||||||
(if (eq? input 'stdin)
|
(sex-forms (semantic-process-forms raw-forms input)))
|
||||||
(read-forms (list))
|
|
||||||
(read-from-file input)))
|
|
||||||
(sex-forms (process-input input raw-forms)))
|
|
||||||
(if (or (get-arg args 'macro-expand #f)
|
(if (or (get-arg args 'macro-expand #f)
|
||||||
(get-arg args 'preprocess #f))
|
(get-arg args 'emit-c #f))
|
||||||
;; Preprocess or macroexpand
|
;; Emit processed and macro-expanded sex code, or emit C code
|
||||||
(preprocess-or-macroexpand 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)))))))
|
||||||
|
|||||||
@@ -1,3 +1,5 @@
|
|||||||
|
(test-begin "basic")
|
||||||
|
|
||||||
;;; unkebabify
|
;;; unkebabify
|
||||||
(test '- (unkebabify '-))
|
(test '- (unkebabify '-))
|
||||||
(test '-- (unkebabify '--))
|
(test '-- (unkebabify '--))
|
||||||
@@ -29,3 +31,5 @@
|
|||||||
;;; make-field-access
|
;;; make-field-access
|
||||||
(test 'a.b (make-field-access '(.b a)))
|
(test 'a.b (make-field-access '(.b a)))
|
||||||
(test 'a.b.c (make-field-access '(.c a.b)))
|
(test 'a.b.c (make-field-access '(.c a.b)))
|
||||||
|
|
||||||
|
(test-end)
|
||||||
|
|||||||
@@ -1,4 +1,5 @@
|
|||||||
(declare (uses sexc))
|
(declare (uses fmt-c-writer
|
||||||
|
semen))
|
||||||
|
|
||||||
(import
|
(import
|
||||||
(chicken process)
|
(chicken process)
|
||||||
@@ -7,7 +8,7 @@
|
|||||||
test)
|
test)
|
||||||
|
|
||||||
(include "basic.scm")
|
(include "basic.scm")
|
||||||
(include "types.scm")
|
(include "semen.scm")
|
||||||
|
|
||||||
;;; Should be the last in the test suite
|
;;; Should be the last in the test suite
|
||||||
(test-exit)
|
(test-exit)
|
||||||
|
|||||||
34
tests/semen.scm
Normal file
34
tests/semen.scm
Normal file
@@ -0,0 +1,34 @@
|
|||||||
|
(define print-str-fn
|
||||||
|
'(fn void print-str ((string s))
|
||||||
|
(printf "%s" s)))
|
||||||
|
|
||||||
|
(define sum-fn
|
||||||
|
'(pub fn float sum ((int a) (int b))
|
||||||
|
(return (cast float (+ a b)))))
|
||||||
|
|
||||||
|
(test-begin "semen")
|
||||||
|
(test-assert (sex-fn? print-str-fn))
|
||||||
|
(test #f (sex-fn-public? print-str-fn))
|
||||||
|
(test 'void (sex-fn-return-type print-str-fn))
|
||||||
|
(test 'print-str (sex-fn-name print-str-fn))
|
||||||
|
(test '((string s)) (sex-fn-arglist print-str-fn))
|
||||||
|
(test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn))
|
||||||
|
(test '((printf "%s" s)) (sex-fn-body print-str-fn))
|
||||||
|
|
||||||
|
(test-assert (sex-fn? sum-fn))
|
||||||
|
(test #t (sex-fn-public? sum-fn))
|
||||||
|
(test 'float (sex-fn-return-type sum-fn))
|
||||||
|
(test 'sum (sex-fn-name sum-fn))
|
||||||
|
(test '((int a) (int b)) (sex-fn-arglist sum-fn))
|
||||||
|
(test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
|
||||||
|
(test '((return (cast float (+ a b)))) (sex-fn-body sum-fn))
|
||||||
|
|
||||||
|
(define sex-code
|
||||||
|
'((defmacro (sum-var name a b c)
|
||||||
|
`(var ,name ,(+ a b c)))
|
||||||
|
|
||||||
|
(sum-var v 1 2 3)))
|
||||||
|
|
||||||
|
(test '((var v 6)) (semen-process sex-code))
|
||||||
|
|
||||||
|
(test-end)
|
||||||
@@ -1 +0,0 @@
|
|||||||
(test "char *" (to-c-type '(%pointer char)))
|
|
||||||
@@ -1,3 +1,5 @@
|
|||||||
|
(import (chicken process-context))
|
||||||
|
|
||||||
(define-syntax prog1
|
(define-syntax prog1
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((prog1 form . forms)
|
((prog1 form . forms)
|
||||||
|
|||||||
Reference in New Issue
Block a user