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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
(in-package #:chains)
(defparameter *default-environment* '()
"")
(let ((true (make-object :symbol (intern "TRUE" *interpreter-package*)))
(false (make-object :symbol (intern "FALSE" *interpreter-package*))))
(push (cons (intern "TRUE" *interpreter-package*) true) *default-environment*)
(push (cons (intern "FALSE" *interpreter-package*) false) *default-environment*))
(defun get-var (env key)
(if-let ((slot (assoc key env)))
(cdr slot)
(error "var ~A not found~% ~A~%" key env)))
;; Built-in functions and variables used inside the interpreter use their own
;; package. This allows the language to have keywords like lambda which
;; otherwise would be reserved words from the cl package
(defmacro define-function (name (&rest args) &body body)
(let ((siblings (gensym)))
(setf name (intern (symbol-name name) *interpreter-package*))
`(push (cons ',name
(make-closure #'(lambda (environment ,siblings ,@args)
(declare (ignore ,siblings))
,@body)
',args
(complement #'identity)
nil
:function))
*default-environment*)))
(defmacro define-function* (name (&rest args) (siblings group-predicate)
&body body)
`(acons ',name
(make-closure #'(lambda (environment ,siblings ,@args)
,@body)
',args
,group-predicate
nil
:function)
*default-environment*))
(defmacro define-special (name (&rest args) &body body)
(setf name (intern (symbol-name name) *interpreter-package*))
`(push (cons ',name
(make-closure #'(lambda (environment siblings ,@args)
,@body)
',args
(complement #'identity)
nil
:special))
*default-environment*))
(defmacro define-special* (name (&rest args) (siblings group-predicate)
&body body)
(setf name (intern (symbol-name name) *interpreter-package*))
`(push (cons ',name
(make-closure #'(lambda (environment ,siblings ,@args)
,@body)
',args
,group-predicate
nil
:special))
*default-environment*))
(define-special lambda (arglist body)
(setf arglist (remove-if #'whitespace-text-p arglist))
(assert (every #'object-symbol-p arglist))
(setf arglist (mapcar #'object-value arglist))
(let ((env environment))
(make-closure #'(lambda (environment siblings &rest args)
(tree-eval (append (pairlis arglist args)
env
environment)
body))
arglist (complement #'identity) env :function)))
(define-special lambda* (arglist group-predicate body)
(setf arglist (remove-if #'whitespace-text-p arglist))
(assert (every #'object-symbol-p arglist))
(setf arglist (mapcar #'object-value arglist))
(cond ((and (listp group-predicate))
;; TODO: Check arglist of predicate
(setf group-predicate (first (tree-eval environment group-predicate)))
(assert (closurep group-predicate))
(let ((function (closure-function group-predicate)))
(setf group-predicate #'(lambda (object)
(funcall function nil nil (list object))))))
((not (functionp group-predicate))
(error "~A" group-predicate)))
(let ((env environment))
(make-closure #'(lambda (environment siblings &rest args)
(tree-eval (append (pairlis arglist args)
(list (cons (intern "SIBLINGS" *interpreter-package*)
siblings))
env
environment)
body))
arglist group-predicate
env :function)))
(defun mapflatten (function list &rest more-lists)
(flatten (apply #'mapcar function list more-lists)))
(defun syntax-expand (table body)
"Replace all instances inside BODY of symbols in the TABLE with their
respectives values"
(cond ((listp body)
(mapflatten (curry #'syntax-expand table) body))
((object-symbol-p body)
(if-let (entry (assoc (object-value body) table))
(cdr entry)
body))
((chainp body)
(make-chain (mapcar (curry #'syntax-expand table) (chain-links body))))
(t
body)))
;; Is this basically quasiquote?
(define-special syntax (arglist body)
(setf arglist (remove-if #'whitespace-text-p arglist))
(assert (every #'object-symbol-p arglist))
(setf arglist (mapcar #'object-value arglist))
(make-closure #'(lambda (environment siblings &rest args)
(declare (ignorable environment siblings))
(syntax-expand (pairlis arglist args) body))
arglist (complement #'identity) environment :syntax))
(define-special* define (name value) (siblings #'identity)
(assert (object-symbol-p (first name)))
(setf name (object-value (first name)))
(setf value (first (tree-eval environment value)))
(tree-eval (acons name value environment)
siblings))
;; TODO: Restrict chain link's length to avoid so many asserts
(define-function gp (symbol)
(assert (object-symbol-p (first symbol)) nil "a")
(setf symbol (first symbol))
(make-closure #'(lambda (environment siblings &rest args)
(declare (ignorable environment siblings))
(let ((object (caar args)))
(not (and (chainp object)
(let ((name (caar (chain-links object))))
(and (object-symbol-p name)
(eq (object-value name)
(object-value symbol))))))))
(list nil) (complement #'identity) nil :function))
(define-special quote (object)
object)
|
