blob: eede4adf0626d8e8592748dcc6a83e16dfb8291b (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
(in-package #:chains)
(defun chainp (object)
(and (consp object) (eq (first object) 'chain)))
(defun chain-links (chain)
(rest chain))
(defun object-symbolp (object)
(and (consp object) (eq (first object) 'symbol)))
(defun tree-eval (environment node)
(cond ((null node)
nil)
((object-symbolp node)
(get-var environment (cdr node)))
((not (consp node))
node)
((chainp (first node))
(destructuring-bind (flink &rest rlinks) (chain-links (first node))
(setf flink (tree-eval environment flink))
(assert (and (consp flink)
(closurep (first flink))
(null (rest flink)))
(flink)
"1~A ~A" flink (content (second flink)))
(let* ((closure (first flink))
(function (closure-function closure))
(group-predicate (closure-group-p closure)))
(multiple-value-bind (siblings rest)
(group-if group-predicate (rest node))
(append
;; Evaluating a function returns a sublink, flatten all sublink
(flatten
(let ((eval-with-environment (curry #'tree-eval environment)))
(case (closure-type closure)
(:syntax
(let ((body (ensure-list (apply function environment siblings rlinks)))
(ret nil))
;; (format t "~&Body: ~A~%" body)
(setf ret (tree-eval environment (append body (rest node))))
(setf rest nil)
ret))
(:special
(ensure-list (apply function environment siblings rlinks)))
(:function
(let ((args (mapcar eval-with-environment rlinks))
(siblings (funcall eval-with-environment siblings)))
(ensure-list (apply function environment siblings args)))))))
(tree-eval environment rest))))))
(t
(cons (tree-eval environment (first node))
(tree-eval environment (rest node))))))
|
