1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3. See distributed LICENSE.txt.
2 (in-package #:clnl-parser)
4 ; Ok, after thinking about this a little, the parser is completely contextual
5 ; based on what has come before. We can't do a contextless parsing, like we
6 ; could in other languages, due to amiguity about reporters vs reporter tasks
8 ; So, for instance, we could have:
10 ; x + y => (x (task +) y)
11 ; So the definition of "+" is completely dependent on the nature of x
13 ; The goal of this parser should be to turn in the amiguous lexed ast representing
14 ; NetLogo into an unambigious S-expression, and nothing more, so things like
15 ; expectation of commands being the first symbol is not be necessary until later
17 ; In general, the parser will:
18 ; * Parse the structure of the lexed output first
19 ; * Parse the structure of the individual expressions (finding ('s and ['s and doing the right thing)
20 ; * Coalate things into an unambigious expressions
21 ; * Then we're done, let someone else make it evaluatable
22 ; - We don't really care if things are commands or reporters right now
24 (defparameter *prims* nil)
25 ; prims that are created when compiling the netlogo file
26 ; usually via procedures or top level things like breed declarations
27 (defparameter *dynamic-prims* nil)
29 (defun prim-name (prim) (getf prim :name))
30 (defun prim-precedence (prim) (getf prim :precedence))
31 (defun prim-args (prim) (getf prim :args))
32 (defun prim-structure-prim (prim) (getf prim :structure-prim))
33 (defun prim-is-infix (prim) (getf prim :infix))
35 (defun find-prim (symb)
37 (find symb *prims* :key #'prim-name)
38 (find symb *dynamic-prims* :key #'prim-name)))
40 ; Make this only as complicated as it needs to be, letting it grow
41 ; as we take on more and more of the language
42 (defun parse (lexed-ast &optional dynamic-prims)
43 "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
45 DYNAMIC-PRIMS: DYNAMIC-PRIM*
46 DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE)
51 LEXED-AST: An ambigious ast
52 AST: An unambigious ast that can be transpiled
53 NAME: A symbol in the keyword package
54 INFIX: Boolean denoting whether the prim is infix, defaulting to NIL
55 PRECEDENCE: A number, usually 10 for reporters, and 0 for commands
56 ARG: A list of symbols denoting the type of argument
60 PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
62 DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on
63 things not statically defined by the NetLogo language, be they user defined
64 procedures or generated primitives from breed declarations. NAME and PRECEDENCE
65 are required for all dynamic prims.
67 PRECEDENCE is a number used to calculate the order of operations. Higher numbers
68 have more precedence than lower ones. Generally all commands should have the
69 lowest precedence, and all reporters should have 10 as the precedence.
71 The possible values for ARG are :agentset, :boolean, :number, :command-block,
72 :string, or t for wildcard. For optional arguments, ARG can be a list of the form
73 (ARG :optional) where ARG is one of the aforementioned values.
75 The need for a parser between the lexer and the transpiler is because NetLogo
76 needs two passes to turn into something that can be used. This is the only entry
77 point into this module, and should probably remain that way.
79 There's also a lot of error checking that the LEXED-AST even makes sense, even
80 though the lexer obviously thought it did.
82 Examples are too numerous and varied, but by inserting an output between
83 the lexer and this code, a good idea of what goes on can be gotten."
84 (when (find nil dynamic-prims :key #'prim-name)
85 (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name)))
86 (when (find nil dynamic-prims :key #'prim-precedence)
87 (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence)))
89 ; could have defined this using the special variable, but didn't to make the
90 ; function definition simpler, as well as the documentation.
91 ((*dynamic-prims* dynamic-prims))
92 (remove-parened-forms (parse-internal lexed-ast))))
94 ; This is needed to clean up where we had to note parenthesis wrapped
95 ; things for the purpose of precedence
96 (defun remove-parened-forms (parsed-ast)
98 ((not parsed-ast) nil)
99 ((and (listp parsed-ast) (eql :parened (car parsed-ast))) (remove-parened-forms (cadr parsed-ast)))
100 ((listp parsed-ast) (mapcar #'remove-parened-forms parsed-ast))
103 (defun parse-internal (lexed-ast &key prev-item prev-remaining-arg remaining-args)
105 ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
107 ((and remaining-args (eql (car remaining-args) :done-with-args))
108 (append (when prev-item (list (help-arg prev-item prev-remaining-arg))) lexed-ast))
109 ((and prim (prim-is-infix prim))
110 (parse-prim prim lexed-ast prev-item prev-remaining-arg remaining-args)) ; Special casing infix prims is cleaner
113 (when prev-item (list (help-arg prev-item prev-remaining-arg)))
115 ((not lexed-ast) nil)
116 ((stringp (car lexed-ast))
117 (parse-internal (cdr lexed-ast)
118 :prev-item (car lexed-ast)
119 :prev-remaining-arg (car remaining-args)
120 :remaining-args (cdr remaining-args)))
121 ((numberp (car lexed-ast))
122 (parse-internal (cdr lexed-ast)
123 :prev-item (coerce (car lexed-ast) 'double-float)
124 :prev-remaining-arg (car remaining-args)
125 :remaining-args (cdr remaining-args)))
128 (eql :token (car remaining-args))
130 (listp (car remaining-args))
131 (find :token (car remaining-args))
132 (symbolp (car lexed-ast)))))
133 (parse-internal (cdr lexed-ast)
134 :prev-item (car lexed-ast)
135 :prev-remaining-arg (car remaining-args)
136 :remaining-args (cdr remaining-args)))
137 ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) remaining-args))
138 ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens"))
139 ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) remaining-args))
140 ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) remaining-args))
142 (when (prim-structure-prim prim)
143 (error "This doesn't make sense here"))
144 (parse-prim prim lexed-ast nil prev-remaining-arg remaining-args))
145 (t (error "Couldn't parse ~S" lexed-ast))))))))
147 (defun parse-let (lexed-ast remaining-args)
148 (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
150 ((half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (list t :done-with-args))))
152 ((*dynamic-prims* (cons (list :name (car lexed-ast) :precedence 20) *dynamic-prims*)))
154 (cdr half-parsed-remainder)
155 :remaining-args (cdr remaining-args)
156 :prev-remaining-arg (car remaining-args)
157 :prev-item (list :let (car lexed-ast) (cadr (car half-parsed-remainder)))))))
159 (defun reconfigure-due-to-precedence (prev-item prim following-args)
161 ((calculate-precedence (x)
165 (< 1 (length prev-item))
168 (prim-precedence (find-prim (car x))))
171 ((<= (prim-precedence prim) (calculate-precedence prev-item))
175 (second (help-arg prev-item (car (prim-args prim))))
180 (reconfigure-due-to-precedence
181 (car (last prev-item))
183 following-args)))))))
185 (defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args)
186 (when (not (prim-precedence prim))
187 (error "Prim must have a precedence! ~A" prim))
188 (when (and (prim-is-infix prim) (eql :token (car (prim-args prim))))
189 (error "Can't have a prim that wants a token in the first position while being infix: ~A" prim))
192 (< (prim-precedence prim) 20)
193 (find-if (lambda (arg) (or (eql :token arg) (and (listp arg) (find :token arg)))) (prim-args prim)))
194 (error "Can't have a prim that wants a token and has a precedence of less than 20: ~A" prim))
196 ((args (if (prim-is-infix prim) (cdr (prim-args prim)) (prim-args prim)))
197 (half-parsed-remainder
198 (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args))))
200 (position-if (lambda (form) (or (not (listp form)) (not (eql :arg (car form))))) half-parsed-remainder)
201 (length half-parsed-remainder)))
202 (already-parsed-limbo-forms
203 (subseq half-parsed-remainder breakpoint (min (length args) (length half-parsed-remainder))))
204 (num-optional-forms (- (length args) breakpoint))
209 ; There's a potential bug here about infix operators with optional forms, where the first item is optional
210 ; I don't consider that super likely though...
212 (reconfigure-due-to-precedence prev-item prim (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint)))
213 (loop :repeat num-optional-forms :collect :optional))
217 (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))
218 (loop :repeat num-optional-forms :collect :optional)))) ; we save the place for optionals for the transpiler
219 already-parsed-limbo-forms)));)
221 ((arg-at-bp (nth breakpoint args)))
222 (when (and arg-at-bp (or (not (listp arg-at-bp)) (not (find :optional arg-at-bp))))
223 (error "Stopped collecting arguments, but non optional arguments remain")))
225 (butlast middle-forms)
227 (nthcdr (length args) half-parsed-remainder)
228 :remaining-args (if (prim-is-infix prim) remaining-args (cdr remaining-args))
229 :prev-remaining-arg (if (prim-is-infix prim) prev-remaining-arg (car remaining-args))
230 :prev-item (car (last middle-forms))))))
232 (defun help-arg (arg arg-type)
235 ((eql arg-type :token) (list :arg (list :token arg)))
236 ((and (listp arg-type) (find :token arg-type) (symbolp arg)) (list :arg (list :token arg)))
237 ((eql arg-type :command-block)
238 (if (not (and (consp arg) (eql 'block (car arg))))
239 (error "Required a block, but found a ~A" arg)
240 (list :arg (cons :command-block (cdr arg)))))
241 ((eql arg-type :reporter-block)
242 (if (not (and (consp arg) (eql 'block (car arg))))
243 (error "Required a block, but found a ~A" arg)
244 (list :arg (cons :reporter-block (cdr arg)))))
247 (and (listp arg-type) (find :list arg-type)))
250 (if (and (consp arg) (eql 'block (car arg)))
251 (cons :list-literal (cdr arg))
255 (find :command-block arg-type)
257 (eql 'block (car arg)))
258 (list :arg (cons :command-block (cdr arg))))
259 ((and (listp arg-type) (find :optional arg-type)) arg)
260 (t (list :arg arg))))
262 (defun parse-block (tokens remaining-args)
263 (multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
264 (parse-internal after-block
265 :prev-item (cons 'block (parse-internal in-block))
266 :prev-remaining-arg (car remaining-args)
267 :remaining-args (cdr remaining-args))))
269 (defun find-closing-bracket (tokens &optional (depth 0))
271 ((not tokens) (error "Failed to find a matching closing bracket"))
272 ((and (eql :] (car tokens)) (= depth 0)) (values nil (cdr tokens)))
273 (t (multiple-value-bind
274 (in-block after-block)
275 (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
276 (values (cons (car tokens) in-block) after-block)))))
278 (defun parse-parened-expr (tokens remaining-args)
279 (multiple-value-bind (in-block after-block) (find-closing-paren tokens)
280 (parse-internal after-block
283 ((parsed-in-block (parse-internal in-block)))
284 (when (/= 1 (length parsed-in-block)) (error "Expected ) here"))
285 (list :parened (car parsed-in-block)))
286 :prev-remaining-arg (car remaining-args)
287 :remaining-args (cdr remaining-args))))
289 (defun find-closing-paren (tokens &optional (depth 0))
291 ((not tokens) (error "Failed to find a matching closing bracket"))
292 ((and (eql (intern ")" :keyword) (car tokens)) (= depth 0)) (values nil (cdr tokens)))
293 (t (multiple-value-bind
294 (in-block after-block)
298 ((eql (intern "(" :keyword) (car tokens)) (1+ depth))
299 ((eql (intern ")" :keyword) (car tokens)) (1- depth)) (t depth)))
300 (values (cons (car tokens) in-block) after-block)))))
302 (defmacro defprim (name args precedence &rest options)
304 (list :name ,name :args ',args :infix ,(find :infix options) :precedence ,precedence)
307 (defmacro defstructureprim (name)
309 (list :name ,name :structure-prim t)
312 ; This list of prims will get combined with the mapping to actual code later
313 ; Current list of argument types we accept:
318 ; - :token (suspends evaluation)
321 ; After the arguments, :infix denotes that it's an :infix operator
322 ; - Note: Later we should move it to have a list of optional attributes of the primitive
323 (defprim := (t t) 5 :infix)
324 (defprim :!= (t t) 5 :infix)
325 (defprim :- (:number :number) 7 :infix)
326 (defprim :* (:number :number) 8 :infix)
327 (defprim :+ (:number :number) 7 :infix)
328 (defprim :/ (:number :number) 8 :infix)
329 (defprim :< (:number :number) 6 :infix)
330 (defprim :<= (:number :number) 6 :infix)
331 (defprim :any? (:agentset) 10)
332 (defprim :ask (:agentset :command-block) 0)
334 (defprim :clear-all () 0)
335 (defprim :crt (:number (:command-block :optional)) 0)
336 (defprim :create-turtles (:number (:command-block :optional)) 0)
337 (defprim :color () 10)
338 (defprim :count (:agentset) 10)
340 (defprim :display () 0)
341 (defprim :with (:agentset :reporter-block) 12 :infix)
342 (defprim :fd (:number) 0)
343 (defprim :hatch (:number (:command-block :optional)) 0)
344 (defprim :let (t t) 0) ; while this has special processing, we need a prim for meta information
345 (defprim :if (:boolean :command-block) 0)
346 (defprim :if-else (:boolean :command-block :command-block) 0)
347 (defprim :ifelse (:boolean :command-block :command-block) 0)
348 (defprim :label () 10)
349 (defprim :label-color () 10)
350 (defprim :not (:boolean) 10)
351 (defprim :nobody () 10)
352 (defprim :one-of ((:agentset :list)) 10)
353 (defprim :of (:reporter-block :agentset) 11 :infix)
354 (defprim :patches () 10)
355 (defprim :pcolor () 10)
356 (defprim :random (:number) 10)
357 (defprim :random-float (:number) 10)
358 (defprim :random-xcor () 10)
359 (defprim :random-ycor () 10)
360 (defprim :round (t) 10)
361 (defprim :reset-ticks () 0)
362 (defprim :lt (:number) 0)
363 (defprim :rt (:number) 0)
364 (defprim :set (t t) 0)
365 (defprim :set-default-shape (t t) 0)
366 (defprim :setxy (:number :number) 0)
367 (defprim :show (t) 0)
368 (defprim :size () 10)
371 (defprim :ticks () 10)
372 (defprim :turtles () 10)
373 (defprim :turtles-here () 10)
377 (defprim :black () 10)
378 (defprim :blue () 10)
379 (defprim :brown () 10)
380 (defprim :green () 10)
381 (defprim :white () 10)
384 (defprim :true () 10)
385 (defprim :false () 10)
387 (defstructureprim :globals)
388 (defstructureprim :breed)
389 (defstructureprim :turtles-own)
390 (defstructureprim :patches-own)
391 (defstructureprim :to)
392 (defstructureprim :to-report)