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
57 (if (getf prim :macro)
58 (append (list :func (getf prim :macro)) prim)
59 (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim)))
62 ((command-list-p parsed-ast) (transpile-commands parsed-ast))
63 ((and (listp parsed-ast) (= 1 (length parsed-ast)) (reporter-p (car parsed-ast)))
64 (transpile-reporter (car parsed-ast)))
65 (t (error "Is neither a list of commands nor a reporter: ~S" parsed-ast)))))
67 (defun command-list-p (parsed-ast)
68 "COMMAND-LIST-P PARSED-AST => RESULT
72 PARSED-AST: An ast as returned by the parser
77 COMMAND-LIST-P returns whether the parsed-ast is a valid list
80 (every #'listp parsed-ast)
81 (every #'prim-command-p (mapcar #'find-prim (mapcar #'car parsed-ast)))))
83 (defun reporter-p (parsed-ast)
84 "REPORTER-P PARSED-AST => RESULT
88 PARSED-AST: An ast as returned by the parser
93 REPORTER-P returns whether the parsed-ast is a valid reporter."
95 (symbolp (car parsed-ast))
96 (prim-reporter-p (find-prim (car parsed-ast)))))
98 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
99 ; For now, it's just a
100 (defun transpile-commands (parsed-ast)
102 ,@(transpile-commands-inner parsed-ast)))
104 (defun transpile-commands-inner (parsed-ast)
106 ((not parsed-ast) nil)
107 ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast)))
110 (transpile-command (car parsed-ast))
111 (transpile-commands-inner (cdr parsed-ast))))))
113 (defun handle-let (parsed-ast &optional vars)
115 (and (listp (car parsed-ast)) (eql :let (caar parsed-ast)))
117 ((*local-variables* (cons (second (car parsed-ast)) *local-variables*)))
122 (transpile-reporter (second (car parsed-ast)))
123 (transpile-reporter (third (car parsed-ast))))
127 ,@(transpile-commands-inner parsed-ast))))
129 (defun transpile-command (command)
131 ((not (listp command)) (error "Expected a statement of some sort"))
132 ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
133 ((not (prim-command-p (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
134 (t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
136 (defun transpile-reporter (reporter)
138 ((numberp reporter) reporter) ; The parser converts to double for us
139 ((stringp reporter) reporter)
140 ; The parser should have checked that having a symbol here is ok
141 ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*))
142 ((not (listp reporter)) (error "Expected a statement of some sort"))
143 ((eql :command-block (car reporter)) (transpile-command-block reporter))
144 ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter))))
145 ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter))
146 ((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
147 (intern (symbol-name (car reporter)) clnl:*model-package*))
148 ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
149 ((not (prim-reporter-p (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
150 (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
152 (defun transpile-command-block (block)
153 `(lambda () ,@(transpile-commands-inner (cdr block))))
155 (defun transpile-reporter-block (block)
156 (when (/= (length block) 2) (error "Reporter block invalid ~S" block))
158 ,(transpile-reporter (cadr block))))
160 ; Undoes the previous function :)
161 (defun make-command-block-inline (block)
164 (defmacro defprim (name type func)
165 `(push (list :name ,name :type ,type :func ,func) *prims*))
167 (defmacro defsimpleprim (name type simple-func)
168 `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args))))
170 (defmacro defkeywordprim (name)
171 `(defprim ,name :reporter (lambda () ',name)))
173 (defmacro defagentvalueprim (name)
174 `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
176 ; We count on the parser to handle arguemnts for us, when collating things.
178 (defsimpleprim := :reporter cl:equalp)
179 (defprim :!= :reporter (lambda (a b) `(not (equalp ,a ,b))))
180 (defsimpleprim :<= :reporter cl:<=)
181 (defsimpleprim :< :reporter cl:<)
182 (defsimpleprim :- :reporter cl:-)
183 (defsimpleprim :+ :reporter cl:+)
184 (defsimpleprim :* :reporter cl:*)
185 (defsimpleprim :/ :reporter cl:/)
186 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
187 (defsimpleprim :ask :command clnl-nvm:ask)
188 (defagentvalueprim :color)
189 (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
190 (defsimpleprim :count :reporter clnl-nvm:count)
191 (defsimpleprim :crt :command clnl-nvm:create-turtles)
192 (defsimpleprim :die :command clnl-nvm:die)
193 (defsimpleprim :display :command clnl-nvm:display)
194 (defsimpleprim :fd :command clnl-nvm:forward)
195 (defsimpleprim :hatch :command clnl-nvm:hatch)
196 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
197 (defprim '(:ifelse :if-else)
198 :command (lambda (pred a b)
200 ,@(make-command-block-inline a)
201 ,@(make-command-block-inline b))))
203 (defagentvalueprim :label)
204 (defagentvalueprim :label-color)
205 (defsimpleprim :let :command nil)
206 (defsimpleprim :lt :command clnl-nvm:turn-left)
207 (defsimpleprim :not :reporter cl:not)
208 (defkeywordprim :nobody)
209 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
210 (defsimpleprim :of :reporter clnl-nvm:of)
211 (defsimpleprim :patches :reporter clnl-nvm:patches)
212 (defagentvalueprim :pcolor)
213 (defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks)
214 (defsimpleprim :random :reporter clnl-nvm:random)
215 (defsimpleprim :random-float :reporter clnl-nvm:random-float)
216 (defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor)
217 (defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor)
218 (defprim :round :reporter (lambda (n) `(ffloor (+ ,n 0.5d0))))
219 (defsimpleprim :rt :command clnl-nvm:turn-right)
220 (defsimpleprim :set :command cl:setf)
221 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
222 (defsimpleprim :setxy :command clnl-nvm:setxy)
223 (defsimpleprim :show :command clnl-nvm:show)
224 (defsimpleprim :stop :command clnl-nvm:stop)
225 (defagentvalueprim :size)
226 (defsimpleprim :tick :command clnl-nvm:tick)
227 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
228 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
229 (defagentvalueprim :who)
230 (defsimpleprim :with :reporter clnl-nvm:with)
233 (defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color))))
234 (defcolorprim :black)
236 (defcolorprim :brown)
237 (defcolorprim :green)
238 (defcolorprim :white)