1 (in-package #:clnl-transpiler)
3 (defparameter *prims* nil)
5 (defvar *local-variables* nil)
6 (defvar *dynamic-prims* nil)
8 (defun prim-name (prim) (getf prim :name))
9 (defun prim-type (prim) (getf prim :type))
10 (defun prim-func (prim) (getf prim :func))
11 (defun prim-reporter-p (prim) (eql :reporter (getf prim :type)))
12 (defun prim-command-p (prim) (eql :command (getf prim :type)))
14 (defun find-prim (symb)
17 (lambda (prim-name) (or (eql symb prim-name) (and (listp prim-name) (find symb prim-name))))
18 (append *prims* *dynamic-prims*)
21 (defun transpile (parsed-ast &optional dynamic-prims)
22 "TRANSPILE PARSED-AST &optional DYNAMIC-PRIMS => AST
24 DYNAMIC-PRIMS: DYNAMIC-PRIM*
25 DYNAMIC-PRIM: (:name NAME :type TYPE :macro MACRO :func FUNC)
26 TYPE: :reporter | :command
30 PARSED-AST: An ast as returned by the parser
31 AST: An common lisp AST that can be actually run in a common lisp instance
32 NAME: A symbol in the keyword package
33 MACRO: A macro that will be called with the arguments ast
34 FUNC: A function that will be called with the transpiled arguments
38 TRANSPILE takes a unambigious PARSED-AST and converts it to
39 Common Lisp code. The PARSED-AST must be either a list of commands,
42 When a set of DYNAMIC-PRIMS is included, external language constructs
43 can be also transpiled. The provided functions will be inserted into
44 the returned AST with a call to FUNCALL. If :macro is included, instead
45 of having a call to FUNCALL provided, the macro will be run at netlogo
46 transpile time, with the arguments it should have specified to the
47 parser. The result of that function call will then be dropped into
50 Calling eval on that code should work correctly as long as you have a
56 (if (getf prim :macro)
57 (append (list :func (getf prim :macro)) prim)
58 (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim)))
61 ((deoptionalized-ast (deoptionalize parsed-ast)))
63 ((command-list-p deoptionalized-ast) (transpile-commands deoptionalized-ast))
64 ((and (listp deoptionalized-ast) (= 1 (length deoptionalized-ast)) (reporter-p (car deoptionalized-ast)))
65 (transpile-reporter (car deoptionalized-ast)))
66 (t (error "Is neither a list of commands nor a reporter: ~S" deoptionalized-ast))))))
68 (defun command-list-p (parsed-ast)
69 "COMMAND-LIST-P PARSED-AST => RESULT
73 PARSED-AST: An ast as returned by the parser
78 COMMAND-LIST-P returns whether the parsed-ast is a valid list
80 (every #'command-p parsed-ast))
82 (defun command-p (parsed-ast)
85 (prim-command-p (find-prim (car parsed-ast)))))
87 (defun reporter-p (parsed-ast)
88 "REPORTER-P PARSED-AST => RESULT
92 PARSED-AST: An ast as returned by the parser
97 REPORTER-P returns whether the parsed-ast is a valid reporter."
100 (symbolp (car parsed-ast))
101 (prim-reporter-p (find-prim (car parsed-ast)))))
103 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
104 ; For now, it's just a
105 (defun transpile-commands (parsed-ast)
107 ,@(transpile-commands-inner parsed-ast)))
109 ; This makes some assumptions about the precedence of optionality
110 ; Consider the following:
111 ; - command-1 <optional> <optional>
112 ; - reporter-1 <optional>
115 ; - command-1 reporter-1 "foo"
117 ; Does the "foo" belong to command-1 or reporter-1?
119 ; I'm not sure how netlogo answers this at this time, but for the purposes
120 ; of this deoptionalizer, "foo" belongs to reporter-1. In the case that the
121 ; language tests treat this as incorrect, I'll fix it. I'm not sure if this
122 ; case exists in the base netlogo language, and I don't feel like creating
123 ; a specific test case at this time to find out.
124 (defun deoptionalize (parsed-ast)
126 ((first-thing (car parsed-ast)))
128 ((not parsed-ast) nil)
129 ((not (listp first-thing)) (cons first-thing (deoptionalize (cdr parsed-ast))))
131 (find :optional first-thing)
133 (not (command-p (cadr parsed-ast))))
135 ((deoptionalized-rest (deoptionalize (cdr parsed-ast)))
136 (optional-pos (position :optional first-thing)))
140 (subseq first-thing 0 optional-pos)
141 (list (car deoptionalized-rest))
142 (subseq first-thing (1+ optional-pos)))
143 (cdr deoptionalized-rest)))))
144 ((find :optional first-thing)
147 (subseq first-thing 0 (position :optional first-thing))
151 (deoptionalize first-thing)
152 (deoptionalize (cdr parsed-ast)))))))
154 (defun transpile-commands-inner (parsed-ast)
156 ((not parsed-ast) nil)
157 ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast)))
160 (transpile-command (car parsed-ast))
161 (transpile-commands-inner (cdr parsed-ast))))))
163 (defun handle-let (parsed-ast &optional vars)
165 (and (listp (car parsed-ast)) (eql :let (caar parsed-ast)))
167 ((*local-variables* (cons (second (car parsed-ast)) *local-variables*)))
172 (transpile-reporter (second (car parsed-ast)))
173 (transpile-reporter (third (car parsed-ast))))
177 ,@(transpile-commands-inner parsed-ast))))
179 (defun transpile-command (command)
181 ((not (listp command)) (error "Expected a statement of some sort"))
182 ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
183 ((not (prim-command-p (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
184 (t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
186 (defun transpile-reporter (reporter)
188 ((numberp reporter) reporter) ; The parser converts to double for us
189 ((stringp reporter) reporter)
190 ; The parser should have checked that having a symbol here is ok
191 ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*))
192 ((not (listp reporter)) (error "Expected a statement of some sort"))
193 ((eql :command-block (car reporter)) (transpile-command-block reporter))
194 ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter))))
195 ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter))
196 ((eql :token (car reporter)) (cadr reporter))
197 ((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
198 (intern (symbol-name (car reporter)) clnl:*model-package*))
199 ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
200 ((not (prim-reporter-p (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
201 (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
203 (defun transpile-command-block (block)
204 `(lambda () ,@(transpile-commands-inner (cdr block))))
206 (defun transpile-reporter-block (block)
207 (when (/= (length block) 2) (error "Reporter block invalid ~S" block))
209 ,(transpile-reporter (cadr block))))
211 ; Undoes the previous function :)
212 (defun make-command-block-inline (block)
215 (defmacro defprim (name type func)
216 `(push (list :name ,name :type ,type :func ,func) *prims*))
218 (defmacro defsimpleprim (name type simple-func)
219 `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args))))
221 (defmacro defkeywordprim (name)
222 `(defprim ,name :reporter (lambda () ',name)))
224 (defmacro defagentvalueprim (name)
225 `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
227 ; We count on the parser to handle arguemnts for us, when collating things.
229 (defsimpleprim := :reporter cl:equalp)
230 (defprim :!= :reporter (lambda (a b) `(not (equalp ,a ,b))))
231 (defsimpleprim :<= :reporter cl:<=)
232 (defsimpleprim :< :reporter cl:<)
233 (defsimpleprim :- :reporter cl:-)
234 (defsimpleprim :+ :reporter cl:+)
235 (defsimpleprim :* :reporter cl:*)
236 (defsimpleprim :/ :reporter cl:/)
237 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
238 (defsimpleprim :ask :command clnl-nvm:ask)
239 (defagentvalueprim :color)
240 (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
241 (defsimpleprim :count :reporter clnl-nvm:count)
242 (defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn)))
243 (defsimpleprim :die :command clnl-nvm:die)
244 (defsimpleprim :display :command clnl-nvm:display)
245 (defsimpleprim :fd :command clnl-nvm:forward)
246 (defsimpleprim :hatch :command clnl-nvm:hatch)
247 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
248 (defprim '(:ifelse :if-else)
249 :command (lambda (pred a b)
251 ((then (make-command-block-inline a))
252 (else (make-command-block-inline b)))
254 ,@(if (= (length then) 1) then `((progn ,@then)))
255 ,@(if (= (length else) 1) else `((progn ,@else)))))))
257 (defagentvalueprim :label)
258 (defagentvalueprim :label-color)
259 (defsimpleprim :let :command nil)
260 (defsimpleprim :lt :command clnl-nvm:turn-left)
261 (defsimpleprim :not :reporter cl:not)
262 (defkeywordprim :nobody)
263 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
264 (defsimpleprim :of :reporter clnl-nvm:of)
265 (defsimpleprim :patches :reporter clnl-nvm:patches)
266 (defagentvalueprim :pcolor)
267 (defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks)
268 (defsimpleprim :random :reporter clnl-nvm:random)
269 (defsimpleprim :random-float :reporter clnl-nvm:random-float)
270 (defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor)
271 (defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor)
272 (defprim :round :reporter (lambda (n) `(ffloor (+ ,n 0.5d0))))
273 (defsimpleprim :rt :command clnl-nvm:turn-right)
274 (defsimpleprim :set :command cl:setf)
275 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
276 (defsimpleprim :setxy :command clnl-nvm:setxy)
277 (defsimpleprim :show :command clnl-nvm:show)
278 (defsimpleprim :stop :command clnl-nvm:stop)
279 (defagentvalueprim :size)
280 (defsimpleprim :tick :command clnl-nvm:tick)
281 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
282 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
283 (defsimpleprim :turtles-here :reporter clnl-nvm:turtles-here)
284 (defagentvalueprim :who)
285 (defsimpleprim :with :reporter clnl-nvm:with)
288 (defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color))))
289 (defcolorprim :black)
291 (defcolorprim :brown)
292 (defcolorprim :green)
293 (defcolorprim :white)