rewrite tree walk with tree module

also add pub support
This commit is contained in:
2025-06-05 17:11:30 +03:00
parent dd9765bd62
commit 39e1e4a664
4 changed files with 70 additions and 73 deletions

136
sexc.scm
View File

@@ -1,81 +1,77 @@
(import (chicken pretty-print)
(import brev-separate
(chicken pretty-print)
(chicken process-context)
(chicken string)
fmt
fmt-c
getopt-long
srfi-1 ; list routines
)
srfi-1 ; list routines
tree)
(define (unkebabify sym)
(string->symbol
(string-translate (symbol->string sym) #\- #\_)))
; Maybe rewrite with tree inversions?
(define (map-filter-tree map-proc filter-proc tree)
"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.
(define (atom-to-fmt-c atom)
(case atom
((fn) '%fun)
((var) '%var)
((begin) '%begin)
((pointer) '%pointer)
((array) '%array)
(([]) 'vector-ref)
((include) '%include)
((cast) '%cast)
(else
(if (symbol? atom)
(unkebabify atom)
atom))))
If filter-proc returns #f, ignore the element.
(define (tree-finder symbol)
(lambda (node)
(or (and (tree? node)
(eq? (car node) symbol))
#f)))
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-generic form)
(let loop ((tree (tree-map atom-to-fmt-c form)))
(let ((unquote-form (tree-find (tree-finder 'unquote) tree #f)))
(if unquote-form
(let ((inv (invert-tree tree)))
(loop (tree-replace inv unquote-form (eval (cadr unquote-form)))))
tree))))
(define (walk-tree tree)
(map-filter-tree
(lambda (elem)
(case elem
((fn) '%fun)
((var) '%var)
((begin) '%begin)
((pointer) '%pointer)
((array) '%array)
(([]) 'vector-ref)
((include) '%include)
((cast) '%cast)
(else
(if (symbol? elem)
(unkebabify elem)
elem))))
(lambda (subtree)
(if (list? subtree)
(case (car subtree)
((unquote)
(eval (cadr subtree)))
(else #t))
#t))
tree))
(define (walk-function form static)
(if static
(list 'static (walk-generic form))
(walk-generic (cdr form))))
(define (read-forms collect)
(call/cc
(lambda (return)
(read-forms
(cons
(let ((r (read)))
(when (eof-object? r)
(return (filter (lambda (e) (not (null? e)))
(reverse collect))))
(case (car r)
((define)
(eval r)
'())
(else
(let ((result (walk-tree r)))
(if result result
'())))))
collect)))))
(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)
(eval form) '())
(else
(walk-sex-tree form))))
(define (process-raw-forms raw-forms acc)
(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)
(map (lambda (form)
@@ -127,12 +123,12 @@ If filter-proc returns something other, use it instead of processing the element
(help (help-arg? args))
(input (get-input-file args)))
(if help (print-help)
(let ((sex-forms
(if (eq? input 'stdin)
(read-forms (list))
(with-input-from-file input
(lambda () (read-forms (list)))))))
(let* ((raw-forms
(if (eq? input 'stdin)
(read-forms (list))
(with-input-from-file input
(lambda () (read-forms (list))))))
(sex-forms (process-raw-forms raw-forms (list))))
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(if (not (eq? output 'stdout))