syntax tree

gistfile1.txt

gosh$ (tree '(2 ^ < 6 - 7 > + 3 * 4))
(+ (^ 2 (- 6 7)) (* 3 4))

syntaxtree.scm

;
; syntax tree
; https://gist.github.com/yamasushi/5d2d9e948f0ae67ca2faf70ed9343431
(define (tree x) ($ car $ expr (cons (undefined) x) ) )

(define (restx syms termx par)
	(define (_restx_ par)
		;(format #t "_restx_ par=~s~%" par)
		(let (	 {inh (car par)}
				{xs	(cdr par) } )
			(if (null? xs)
				`(,inh)
				(let (	{hd (car xs)}
						{tl (cdr xs)} )
					(if (find (cut eq? hd <>) syms)
						($ _restx_
							$ (^y
								(cons
									`( ,hd ,inh ,(car y) )
									(cdr y) ) )
							$ termx (cons inh tl) )
						par
					)
				)
			)
		)
	)
	;(format #t "restx syms=~s par=~s~%" syms par)
	(_restx_ par)
)

(define (expr par) ($ rest1 $ term1 par) )
(define rest1 (cut restx '(+ -) term1 <>) )

(define (term1 par)	($ rest2 $ term2 par) )
(define rest2 (cut restx '(* / %) term2 <>))

(define (term2 par)	($ rest3 $ term3 par) )
(define rest3 (cut restx '(^) term3 <>) )

(define (term3 par) (factor par))

(define (factor par)
	;(format #t "factor par=~s~%" par)
	(let (	 {inh (car par)}
			{xs	(cdr par) } )
		(if (null? xs)
			(error "factor:error xs=~s" xs)
			(let (	{hd (car xs)}
					{tl (cdr xs)} )
				(cond
					{(of-type? hd <number>) (cons hd tl) }
					{(eq? hd '< )
						($ (cut match-term '> <>) $ expr (cons (undefined) tl) )}
					{else
						(error "factor:error xs=" xs) }
					)
			)
		)
	)
)

(define (match-term t par)
	;(format #t "match-term t=~s , par=~s~%" t par)
	(let (	 {inh (car par)}
			{xs	(cdr par) } )
		(if (null? xs)
			(error "syntax error xs=" xs)
			(if (equal? (car xs) t)
				(cons inh (cdr xs))
				(error "syntax error xs=" xs)
			)
		)
	)
)