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
|
(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 (name arguments
(environment &key specialp siblings group-predicate)
&body body)
(setf name (intern (symbol-name name) *interpreter-package*))
`(push (cons ',name
(make-closure #'(lambda (,environment ,siblings)
(declare (ignorable ,siblings))
(let ,(mapcar #'(lambda (x)
`(,x (get-var ,environment (find-symbol (symbol-name ',x) *interpreter-package*))))
arguments)
,@body))
',(mapcar #'(lambda (x) (intern (symbol-name x) *interpreter-package*))
arguments)
,(if group-predicate
group-predicate
'(complement #'identity))
nil
,specialp))
*default-environment*))
(defmacro define-function (name arguments &body body)
(let ((environment (gensym)))
`(define ,name ,arguments (,environment) ,@body)))
(defmacro define-special (name arguments &body body)
(let ((environment (gensym)))
`(define ,name ,arguments (,environment :specialp t) ,@body)))
(defmacro clambda ((environment lambda-list) &body body)
(let ((siblings (gensym)))
`(make-instance 'closure :function #'(lambda (,environment ,siblings)
(declare (ignorable ,siblings))
,@body)
:lambda-list ,lambda-list
:groupp (complement #'identity)
:environment nil
:specialp nil)))
(define lambda (lambda-list body)
(captured-environment :siblings siblings :specialp t)
(setf lambda-list (remove-if #'whitespace-text-p lambda-list))
(assert (every #'object-symbol-p lambda-list))
(setf lambda-list (mapcar #'object-value lambda-list))
(clambda (environment lambda-list)
;; Splice arguments into resulting link
(flatten (eval-tree (append environment captured-environment) body))))
;; (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 (eval-tree 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)
;; (eval-tree (append (pairlis arglist args)
;; (list (cons (intern "SIBLINGS" *interpreter-package*)
;; siblings))
;; env
;; environment)
;; body))
;; arglist group-predicate
;; env nil)))
(define define (name value)
(environment :siblings siblings :group-predicate #'identity :specialp t)
(assert (object-symbol-p (first name)))
(setf name (object-value (first name)))
(setf value (first (eval-tree environment value)))
(eval-tree (acons name value environment)
siblings))
;;; TODO: Macro for checking arguments types, eliminate whitespace and so on
;;; TODO: Docstrings for functions
;;; TODO: More advance lambda-lists (optional values, etc)
|
