rewrite tree walk with tree module
also add pub support
This commit is contained in:
@@ -14,7 +14,7 @@ By the way, there's a way to make Chicken install eggs non-globally. Refer to
|
|||||||
the documentation for more info:
|
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~
|
~chicken-install fmt getopt-long brev-separate~
|
||||||
|
|
||||||
** Compilation
|
** Compilation
|
||||||
~make~
|
~make~
|
||||||
@@ -38,7 +38,7 @@ The Sex source:
|
|||||||
(define (foo)
|
(define (foo)
|
||||||
"Hello from Chicken code!\n")
|
"Hello from Chicken code!\n")
|
||||||
|
|
||||||
(fn int main ((int argc) (char **argv))
|
(pub fn int main ((int argc) (char **argv))
|
||||||
(puts "Hello from Sex!")
|
(puts "Hello from Sex!")
|
||||||
(var (array char 512) name)
|
(var (array char 512) name)
|
||||||
(puts "What is your name?")
|
(puts "What is your name?")
|
||||||
|
|||||||
@@ -3,7 +3,7 @@
|
|||||||
(define (foo)
|
(define (foo)
|
||||||
"Hello from Chicken code!\n")
|
"Hello from Chicken code!\n")
|
||||||
|
|
||||||
(fn int main ((int argc) (char **argv))
|
(pub fn int main ((int argc) (char **argv))
|
||||||
(puts "Hello from Sex!")
|
(puts "Hello from Sex!")
|
||||||
(var (array char 512) name)
|
(var (array char 512) name)
|
||||||
(puts "What is your name?")
|
(puts "What is your name?")
|
||||||
|
|||||||
@@ -30,6 +30,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
|
|||||||
(list (concat "("
|
(list (concat "("
|
||||||
(regexp-opt '("include"
|
(regexp-opt '("include"
|
||||||
"fn"
|
"fn"
|
||||||
|
"pub"
|
||||||
"struct"
|
"struct"
|
||||||
"template"
|
"template"
|
||||||
"var")
|
"var")
|
||||||
|
|||||||
112
sexc.scm
112
sexc.scm
@@ -1,42 +1,19 @@
|
|||||||
(import (chicken pretty-print)
|
(import brev-separate
|
||||||
|
(chicken pretty-print)
|
||||||
(chicken process-context)
|
(chicken process-context)
|
||||||
(chicken string)
|
(chicken string)
|
||||||
fmt
|
fmt
|
||||||
fmt-c
|
fmt-c
|
||||||
getopt-long
|
getopt-long
|
||||||
srfi-1 ; list routines
|
srfi-1 ; list routines
|
||||||
)
|
tree)
|
||||||
|
|
||||||
(define (unkebabify sym)
|
(define (unkebabify sym)
|
||||||
(string->symbol
|
(string->symbol
|
||||||
(string-translate (symbol->string sym) #\- #\_)))
|
(string-translate (symbol->string sym) #\- #\_)))
|
||||||
|
|
||||||
; Maybe rewrite with tree inversions?
|
(define (atom-to-fmt-c atom)
|
||||||
(define (map-filter-tree map-proc filter-proc tree)
|
(case atom
|
||||||
"Walk the tree, checking each element with filter-proc.
|
|
||||||
If filter-proc returns #t:
|
|
||||||
- if the element is list, process it recursively,
|
|
||||||
- if the element is an atom, process it with map-proc.
|
|
||||||
|
|
||||||
If filter-proc returns #f, ignore the element.
|
|
||||||
|
|
||||||
If filter-proc returns something other, use it instead of processing the element."
|
|
||||||
(let ((cont (cut map-filter-tree map-proc filter-proc <>)))
|
|
||||||
(if (null? tree) '()
|
|
||||||
(let ((filter-res (filter-proc (car tree))))
|
|
||||||
(case filter-res
|
|
||||||
((#t) (cons
|
|
||||||
(if (atom? (car tree))
|
|
||||||
(map-proc (car tree))
|
|
||||||
(cont (car tree)))
|
|
||||||
(cont (cdr tree))))
|
|
||||||
((#f) (cont (cdr tree)))
|
|
||||||
(else (cons filter-res (cont (cdr tree)))))))))
|
|
||||||
|
|
||||||
(define (walk-tree tree)
|
|
||||||
(map-filter-tree
|
|
||||||
(lambda (elem)
|
|
||||||
(case elem
|
|
||||||
((fn) '%fun)
|
((fn) '%fun)
|
||||||
((var) '%var)
|
((var) '%var)
|
||||||
((begin) '%begin)
|
((begin) '%begin)
|
||||||
@@ -46,36 +23,55 @@ If filter-proc returns something other, use it instead of processing the element
|
|||||||
((include) '%include)
|
((include) '%include)
|
||||||
((cast) '%cast)
|
((cast) '%cast)
|
||||||
(else
|
(else
|
||||||
(if (symbol? elem)
|
(if (symbol? atom)
|
||||||
(unkebabify elem)
|
(unkebabify atom)
|
||||||
elem))))
|
atom))))
|
||||||
(lambda (subtree)
|
|
||||||
(if (list? subtree)
|
|
||||||
(case (car subtree)
|
|
||||||
((unquote)
|
|
||||||
(eval (cadr subtree)))
|
|
||||||
(else #t))
|
|
||||||
#t))
|
|
||||||
tree))
|
|
||||||
|
|
||||||
(define (read-forms collect)
|
(define (tree-finder symbol)
|
||||||
(call/cc
|
(lambda (node)
|
||||||
(lambda (return)
|
(or (and (tree? node)
|
||||||
(read-forms
|
(eq? (car node) symbol))
|
||||||
(cons
|
#f)))
|
||||||
(let ((r (read)))
|
|
||||||
(when (eof-object? r)
|
(define (walk-generic form)
|
||||||
(return (filter (lambda (e) (not (null? e)))
|
(let loop ((tree (tree-map atom-to-fmt-c form)))
|
||||||
(reverse collect))))
|
(let ((unquote-form (tree-find (tree-finder 'unquote) tree #f)))
|
||||||
(case (car r)
|
(if unquote-form
|
||||||
|
(let ((inv (invert-tree tree)))
|
||||||
|
(loop (tree-replace inv unquote-form (eval (cadr unquote-form)))))
|
||||||
|
tree))))
|
||||||
|
|
||||||
|
(define (walk-function form static)
|
||||||
|
(if static
|
||||||
|
(list 'static (walk-generic form))
|
||||||
|
(walk-generic (cdr form))))
|
||||||
|
|
||||||
|
(define (walk-sex-tree form)
|
||||||
|
(case (car form)
|
||||||
|
((fn) (walk-function form #t))
|
||||||
|
((pub) (walk-function form #f))
|
||||||
|
((template) '()) ; TODO
|
||||||
|
((struct) (walk-generic form))
|
||||||
|
(else (walk-generic form))))
|
||||||
|
|
||||||
|
(define (process-form form)
|
||||||
|
(case (car form)
|
||||||
((define)
|
((define)
|
||||||
(eval r)
|
(eval form) '())
|
||||||
'())
|
|
||||||
(else
|
(else
|
||||||
(let ((result (walk-tree r)))
|
(walk-sex-tree form))))
|
||||||
(if result result
|
|
||||||
'())))))
|
(define (process-raw-forms raw-forms acc)
|
||||||
collect)))))
|
(if (null? raw-forms) (filter (fn (not (null? x)))
|
||||||
|
(reverse acc))
|
||||||
|
(process-raw-forms (cdr raw-forms)
|
||||||
|
(cons (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)
|
(define (emit-c forms)
|
||||||
(map (lambda (form)
|
(map (lambda (form)
|
||||||
@@ -127,12 +123,12 @@ If filter-proc returns something other, use it instead of processing the element
|
|||||||
(help (help-arg? args))
|
(help (help-arg? args))
|
||||||
(input (get-input-file args)))
|
(input (get-input-file args)))
|
||||||
(if help (print-help)
|
(if help (print-help)
|
||||||
(let ((sex-forms
|
(let* ((raw-forms
|
||||||
(if (eq? input 'stdin)
|
(if (eq? input 'stdin)
|
||||||
(read-forms (list))
|
(read-forms (list))
|
||||||
(with-input-from-file input
|
(with-input-from-file input
|
||||||
(lambda () (read-forms (list)))))))
|
(lambda () (read-forms (list))))))
|
||||||
|
(sex-forms (process-raw-forms raw-forms (list))))
|
||||||
(if (get-arg args 'macro-expand #f)
|
(if (get-arg args 'macro-expand #f)
|
||||||
(map pp sex-forms)
|
(map pp sex-forms)
|
||||||
(if (not (eq? output 'stdout))
|
(if (not (eq? output 'stdout))
|
||||||
|
|||||||
Reference in New Issue
Block a user