forked from gigamonkey/monkeylib-foo
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathlanguage.lisp
284 lines (221 loc) · 10.8 KB
/
language.lisp
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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
;;
;; Copyright (c) 2005, Gigamonkeys Consulting All rights reserved.
;;
(in-package :foo.language)
;;; Hmmmm. Might be useful to support symbol macros.
(defclass language ()
((special-operator-symbol
:initarg :special-operator-symbol
:accessor special-operator-symbol)
(macro-symbol
:initarg :macro-symbol
:accessor macro-symbol)
(input-readtable
:initarg :input-readtable
:accessor input-readtable)
(input-package
:initarg :input-package
:accessor input-package)
(output-file-type
:initarg :output-file-type
:accessor output-file-type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Primary interface
(defgeneric special-operator-symbol (language)
(:documentation "Return the symbol added to a symbol's plist to
indicate it is the name of a special operator in LANGUAGE."))
(defgeneric macro-symbol (language)
(:documentation "Return the symbol added to a symbol's plist to
indicate it has been defined as a macro in LANGUAGE."))
(defgeneric identifier (language form)
(:documentation "Extract a symbol that identifies the form."))
(defgeneric sexp-form-p (language form)
(:documentation "Is the given form a meaningful non-special,
non-macro form in language."))
(defgeneric embeddable-value-form (language form environment)
(:documentation "Return a form that will evaluate to a string
that can be embedded in the generated output."))
(defgeneric process-sexp (language processor form environment)
(:documentation "The basic evaluation rule for the language,
after special operators and macro forms have been handled."))
;;; Secondary interface -- these are typically implemented in terms of
;;; the primary interface.
(defgeneric special-form-p (language form)
(:documentation "Is the given form a special form in language."))
(defgeneric macro-form-p (language form)
(:documentation "Is the given form a macro form in language."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File compiler interface
(defgeneric comment (language text)
(:documentation "Return text as a comment."))
(defgeneric input-readtable (language)
(:documentation "The readtable we should use to read the input file."))
(defgeneric input-package (language)
(:documentation "The package we should use to read the input file."))
(defgeneric top-level-environment (language)
(:documentation "Environment for evaluating top-level forms."))
(defgeneric output-file-type (language)
(:documentation "File suffix for generated files."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Null implementation of processor interface -- this is used for
;;; walking forms without generating any output.
(defmethod raw-string ((pp (eql nil)) string &optional newlines-p)
(declare (ignore string newlines-p)))
(defmethod newline ((pp (eql nil))))
(defmethod freshline ((pp (eql nil))))
(defmethod indent ((pp (eql nil))))
(defmethod unindent ((pp (eql nil))))
(defmethod toggle-indenting ((pp (eql nil))))
(defmethod embed-value ((pp (eql nil)) value)
(declare (ignore value)))
(defmethod embed-code ((pp (eql nil)) code)
(declare (ignore code)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Language engine.
(defun process (language processor form environment)
"Process FORM as an expression in LANGUAGE. The ENVIRONMENT is
provided to special forms and to the basic evaluation rule
implemented by a method on PROCESS-SEXP."
(cond
((special-form-p language form) (process-special-form language processor form environment))
((macro-form-p language form) (process language processor (expand-macro-form language form environment) environment))
((sexp-form-p language form) (process-sexp language processor form environment))
((consp form) (embed-code processor form))
(t (embed-value processor (embeddable-value-form language form environment)))))
(defgeneric process-special-form (language processor form environment))
(defgeneric expand-macro-form (language form environment))
(defmethod process-special-form (language processor form environment)
(let ((special-operator (get (identifier language form) (special-operator-symbol language))))
(funcall special-operator language processor form environment)))
#+(or)(defmethod expand-macro-form :before ((language t) form environment)
(format t "Expanding~&~s~%in environment ~s~%" form environment))
(defmethod expand-macro-form (language form environment)
(let ((macro-function (get (identifier language form) (macro-symbol language))))
(funcall macro-function form environment)))
(defun fully-expand-macro-form (language form environment)
(loop while (macro-form-p language form) do
(setf form (expand-macro-form language form environment)))
(mapcar #'(lambda (x) (if (macro-form-p language x) (fully-expand-macro-form language x environment) x)) form))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Default methods.
(defmethod identifier ((language t) (form cons))
"Reasonable default for languages with a Lispy syntax."
(and (symbolp (car form)) (car form)))
(defmethod identifier ((language t) (form t))
(error "Malformed expression for ~a: ~s" language form))
(defmethod special-form-p ((language t) (form t)) nil)
(defmethod special-form-p ((language t) (form cons))
(let ((identifier (identifier language form)))
(and identifier
(get identifier (special-operator-symbol language)))))
(defmethod macro-form-p ((language t) (form t)) nil)
(defmethod macro-form-p ((language t) (form cons))
(let ((identifier (identifier language form)))
(and identifier
(get identifier (macro-symbol language)))))
(defmethod sexp-form-p ((language t) form)
"Suitable default for languages in which all forms that are not
special or macros have some meaning. Languages that allow
embedded code and embedded values will need their own
specialization of this method."
(declare (ignore form))
t)
(defmethod embeddable-value-form ((language t) form environment)
"Reasonable default. Languages that need to escape certain
characters will need their own specializations of this method."
(declare (ignore environment))
`(princ-to-string ,form))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros -- typically specific languages will provide their own
;;; definitional macros that will expand into these two macros.
(defmacro define-special-operator (name special-operator-symbol (language processor &rest other-parameters) &body body)
(with-unique-names (whole)
(multiple-value-bind (parameters environment) (parse-&environment other-parameters)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name ',special-operator-symbol)
(lambda (,language ,processor ,whole ,environment)
(declare (ignorable ,environment))
(handler-case
(destructuring-bind (,@parameters) (rest ,whole)
,@body)
(error (e)
(error 'foo-syntax-error :form ,whole :cause e)))))))))
(define-condition foo-syntax-error ()
((form :initarg :form :accessor form-of)
(cause :initarg :cause :accessor cause-of :initform nil)))
(defmethod print-object ((c foo-syntax-error) stream)
(print-unreadable-object (c stream)
(format stream "in form: ~s; caused by: ~a" (form-of c) (cause-of c))))
(defmacro define-macro (name macro-symbol (&rest parameters) &body body)
(with-unique-names (whole namevar)
(multiple-value-bind (parameters environment) (parse-&environment parameters)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name ',macro-symbol)
(lambda (,whole ,environment)
(declare (ignorable ,environment))
(handler-case
(destructuring-bind (,@(normalize-macro-lambda-list parameters namevar)) ,whole
(declare (ignore ,namevar))
,@body)
(error (e)
(error 'foo-syntax-error :form ,whole :cause e)))))))))
(defun parse-&environment (parameters)
"Parse out an optional &environment parameter and return the
parameter list without it and the name of the parameter."
(let ((cons (member '&environment parameters)))
(if cons
(values
(nconc (ldiff parameters cons) (cddr cons))
(cadr cons))
(values parameters (make-symbol (symbol-name 'no-environment))))))
(defun normalize-macro-lambda-list (parameters namevar)
"Create a destructuring-lambda list that can parse a whole
macro form, including an optional &whole parameter and a
parameter to eat up the macro name."
(let* ((back (if (eql (car parameters) '&whole) (cddr parameters) parameters))
(front (ldiff parameters back)))
`(,@front ,namevar ,@back)))
(defun self-evaluating-p (form)
(and (atom form) (if (symbolp form) (keywordp form) t)))
(defun sexp->ops (language body environment)
(loop with compiler = (make-instance 'text-compiler)
for form in body do (process language compiler form environment)
finally (return (ops compiler))))
(defun emit (language body environment)
(process language (get-pretty-printer) body environment))
(defun compile-special-op-body (processor body)
"Code generator generator."
(loop for thing in body collect
(etypecase thing
(string `(raw-string ,processor ,thing ,(not (not (find #\Newline thing)))))
(cons thing)
(keyword
(ecase thing
(:newline `(newline ,processor))
(:freshline `(freshline ,processor))
(:indent `(indent ,processor))
(:unindent `(unindent ,processor)))))))
(defun case-preserving-readtable ()
(let ((readtable (copy-readtable)))
(setf (readtable-case readtable) :preserve)
readtable))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helpers for top-level language functions and macros.
(defun emit-for-language (language-class sexp)
(let ((lang (make-instance language-class)))
(process lang (get-pretty-printer) sexp (top-level-environment lang))))
(defmacro define-language (name parent)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name (,parent) ()))
(define-language-macro ,name)))
(defmacro define-language-macro (name)
`(defmacro ,name (&whole whole &body body)
(declare (ignore body))
`(macrolet ((,(car whole) (&body body)
(let* ((lang (make-instance ',(car whole)))
(env (top-level-environment lang)))
(codegen-text (sexp->ops lang body env) ,*pretty*))))
,@(if *pretty*
`((let ((*text-pretty-printer* (get-pretty-printer))) ,whole))
`(,whole)))))