blob: bc1d1c8cd6f950a3d80f0d6e6b6f19d7c6f3627d (
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
54
55
56
57
58
59
60
61
62
63
64
65
66
|
(in-package #:chains)
(defun group-if (predicate sequence)
(loop :for (head . tail) :on sequence
:while (funcall predicate head)
:collect head :into group
:finally
(return (values group (if (not (funcall predicate head))
(cons head tail)
tail)))))
(defun group (item sequence &key (test #'eql))
(group-if #'(lambda (x) (funcall test item x)) sequence))
(defun group-if-not (predicate sequence)
(group-if (complement predicate) sequence))
(defun link-closure (link)
"Returns the function object inside the first link of a chain"
(setf link (remove-if #'whitespace-text-p link))
(assert (and (not (null link))
(closurep (first link))
(null (rest link)))
(link)
"Link is not callable: ~A" link)
(first link))
(defun bind-arguments (environment lambda-list arguments specialp)
(unless specialp
(map-into arguments (curry #'eval-tree environment) arguments))
(append (mapcar #'cons lambda-list arguments)
environment))
(defun eval-chain (environment chain siblings)
"Evaluate CHAIN inside ENVIRONMENT and possibly consume SIBLINGS. Returns a
link with the evaluated body of the function under the ENVIRONMENT"
(destructuring-bind (head &rest arguments)
(chain-links chain)
(with-accessors ((function closure-function)
(special closure-special-p)
(lambda-list closure-lambda-list)
(group-predicate closure-group-p))
;; Evaluate all elements of first link and get closure object
(link-closure (eval-tree environment head))
(multiple-value-bind (consumed-siblings rest)
(group-if group-predicate siblings)
(values
(funcall function
(bind-arguments environment lambda-list arguments special)
consumed-siblings)
rest)))))
(defun eval-tree (environment node)
(typecase node
(object-symbol
(get-var environment (object-value node)))
(cons
(destructuring-bind (head &rest tail)
node
(if (chainp head)
(multiple-value-bind (result rest)
(eval-chain environment head tail)
(append (ensure-list result) (eval-tree environment rest)))
(cons (eval-tree environment head) (eval-tree environment tail)))))
(t
node)))
|
