Add semantic engine #8

Merged
alex-eg merged 2 commits from add-semantic-engine into main 2025-09-29 14:50:01 +02:00
17 changed files with 393 additions and 244 deletions

1
.gitignore vendored Normal file
View File

@@ -0,0 +1 @@
*.o

View File

@@ -1,6 +1,6 @@
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)
sexc: main.o $(OBJ)

View File

@@ -12,7 +12,7 @@ to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
environment variables. Refer to the documentation for more info:
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
~make~

10
example/fns.sex Normal file
View 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)))

View File

@@ -2,10 +2,10 @@
(let ((list-type (cat 'list- type)))
`(struct ,list-type
((,type value)
((* ,list-type) next)))))
((* (struct ,list-type)) next)))))
(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)))
`(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
(var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type))))
@@ -13,7 +13,7 @@
(return list))))
(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)))
`(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
(while (!= (-> list next) NULL)
@@ -23,7 +23,7 @@
(pub defmacro (length-list-T type is-public?)
(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))
(var size-t n 0)
(while (!= (-> list next) NULL)
@@ -33,15 +33,15 @@
(pub defmacro (is-empty-list-T type is-public?)
`(,@(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))))
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
(let ((list-var-2 (cat list-var '-2)))
`((begin
(var (pointer ,list-type) ,list-var-2 ,list-var)
(var ,elt-type ,elt-var (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)
,what-do
(= ,list-var-2 (-> ,list-var-2 next))
(= ,elt-var (-> ,list-var-2 value)))))))
`(begin
(var (pointer ,list-type) ,list-var-2 ,list-var)
(var ,elt-type ,elt-var (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)
,what-do
(= ,list-var-2 (-> ,list-var-2 next))
(= ,elt-var (-> ,list-var-2 value))))))

View File

@@ -2,20 +2,15 @@
(include stddef.h)
(include stdio.h)
(chicken-import srfi-1 brev-separate) ; list routines, e.g. fold
(import list)
(chicken-define (imports-test a b c)
(fold + 0 (list 1 2 3 a b c)))
(struct foo
((float a-field)
(int b)
((const char *) c)
((fn bool ((bool val))) not)))
(var foo f)
(var (struct foo) f)
(list-T int)
(make-list-T int #f)
@@ -24,7 +19,6 @@
(is-empty-list-T int #f)
(extern fn void puk ((int a) (float b)))
(fn int bar () (return ,(imports-test 10 20 30)))
(pub fn bool baz () (return true))
(extern var int i)
@@ -32,18 +26,18 @@
(pub var int k)
(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))
(add-value-list-int l 3)
(add-value-list-int l 4)
(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 "\n")
(printf "Size of the list: %lu\n" (length-list-int l))
(printf "%p\n" (cast void* l->next))
(return 0))
(pub fn void print-list (((const list-int) *l))
(list-for-each (const list-int) l int v (printf "%d " v))
(pub fn void print-list (((const struct list-int) *l))
(list-for-each (const struct list-int) l int v (printf "%d " v))
(printf "\n"))

128
fmt-c-writer.scm Normal file
View 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
View File

@@ -0,0 +1,141 @@
;;; Sex semantic engine
pkulev commented 2025-09-29 14:14:26 +02:00 (Migrated from github.com)
Review

Is this a typo or all symbols of matching pattern are quoted?

         ('pub 'struct . _)) (process-struct sex-form acc))
Is this a typo or all symbols of matching pattern are quoted? ```suggestion ('pub 'struct . _)) (process-struct sex-form acc)) ```
alex-eg commented 2025-09-29 14:30:44 +02:00 (Migrated from github.com)
Review

😱
Typo indeed. Thanks.

😱 Typo indeed. Thanks.
(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)))

View File

@@ -19,11 +19,17 @@
(define (get-macro name)
(eval (get name 'sex-macro)))
(define (macro? form)
(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)))

View File

@@ -1,7 +1,8 @@
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
; things start to break.
(declare (unit sex-modules)
(uses utils))
(uses sex-reader
utils))
(import brev-separate
(chicken file)
@@ -14,7 +15,7 @@
(define +persistent-module-paths+ (list))
(define (import-modules module-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
@@ -63,6 +64,7 @@
(list)
raw-forms)))
;;; TODO: use semen facilities to analyze modules
(define (process-public-interface-form form acc)
(case (car form)
((pub)

22
sex-reader.scm Normal file
View 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
View File

@@ -1,207 +1,23 @@
(declare (unit sexc)
(uses fmt-c
sex-macros
sex-modules))
(uses fmt-c-writer
sex-reader
semen))
(include "utils.macros.scm")
(import brev-separate
(chicken file)
(chicken pathname)
(chicken plist)
(chicken pretty-print)
(chicken process)
(chicken process-context)
(chicken port)
(chicken string)
fmt
getopt-long
regex
srfi-1 ; list routines
srfi-13 ; string routines
srfi-13
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
(define opts-grammar
@@ -214,10 +30,10 @@
(required #f)
(value #f)
(single-char #\c))
(preprocess "Emit C code"
(emit-c "Emit C code"
(required #f)
(value #f)
(single-char #\E))
(single-char #\C))
(public-interface "Get module's public interface"
(required #f)
(value #f))
@@ -261,20 +77,14 @@
'stdin
(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)
(if (eq? output 'default)
(what)
(with-output-to-file output
(fn (what)))))
(define (preprocess-or-macroexpand sex-forms output args)
(write-to-file-or-stdout
output
(define (emit-c-or-sex sex-forms output args)
(write-to-file-or-stdout output
(lambda ()
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
@@ -301,13 +111,11 @@
(close-output-port in-port)
(process-wait pid)))))
(define (process-input input raw-forms)
(let ((current-dir (current-directory)))
(unless (eq? input 'stdin)
(set-working-directory input))
(prog1
(process-raw-forms raw-forms (list))
(change-directory current-dir))))
(define (semantic-process-forms raw-forms input-source)
(if (eq? input-source 'stdin)
(semen-process raw-forms)
(with-directory input-source
(semen-process raw-forms))))
(define (main)
(let* ((raw-args (command-line-arguments))
@@ -334,14 +142,11 @@
(return #f))
(load-persistent-module-paths)
(let* ((raw-forms
(if (eq? input 'stdin)
(read-forms (list))
(read-from-file input)))
(sex-forms (process-input input raw-forms)))
(let* ((raw-forms (read-raw-forms input))
(sex-forms (semantic-process-forms raw-forms input)))
(if (or (get-arg args 'macro-expand #f)
(get-arg args 'preprocess #f))
;; Preprocess or macroexpand
(preprocess-or-macroexpand sex-forms output args)
(get-arg args 'emit-c #f))
;; Emit processed and macro-expanded sex code, or emit C code
(emit-c-or-sex sex-forms output args)
;; Compile file!
(compile-to-file sex-forms output args)))))))

View File

@@ -1,3 +1,5 @@
(test-begin "basic")
;;; unkebabify
(test '- (unkebabify '-))
(test '-- (unkebabify '--))
@@ -29,3 +31,5 @@
;;; make-field-access
(test 'a.b (make-field-access '(.b a)))
(test 'a.b.c (make-field-access '(.c a.b)))
(test-end)

View File

@@ -1,4 +1,5 @@
(declare (uses sexc))
(declare (uses fmt-c-writer
semen))
(import
(chicken process)
@@ -7,7 +8,7 @@
test)
(include "basic.scm")
(include "types.scm")
(include "semen.scm")
;;; Should be the last in the test suite
(test-exit)

34
tests/semen.scm Normal file
View 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)

View File

@@ -1 +0,0 @@
(test "char *" (to-c-type '(%pointer char)))

View File

@@ -1,3 +1,5 @@
(import (chicken process-context))
(define-syntax prog1
(syntax-rules ()
((prog1 form . forms)