1 (in-package #:clnl-parser)
3 ; Ok, after thinking about this a little, the parser is completely contextual
4 ; based on what has come before. We can't do a contextless parsing, like we
5 ; could in other languages, due to amiguity about reporters vs reporter tasks
7 ; So, for instance, we could have:
9 ; x + y => (x (task +) y)
10 ; So the definition of "+" is completely dependent on the nature of x
12 ; The goal of this parser should be to turn in the amiguous lexed ast representing
13 ; NetLogo into an unambigious S-expression, and nothing more, so things like
14 ; expectation of commands being the first symbol is not be necessary until later
16 ; In general, the parser will:
17 ; * Parse the structure of the lexed output first
18 ; * Parse the structure of the individual expressions (finding ('s and ['s and doing the right thing)
19 ; * Coalate things into an unambigious expressions
20 ; * Then we're done, let someone else make it evaluatable
21 ; - We don't really care if things are commands or reporters right now
23 (defparameter *prims* nil)
24 ; prims that are created when compiling the netlogo file
25 ; usually via procedures or top level things like breed declarations
26 (defparameter *dynamic-prims* nil)
28 (defun prim-name (prim) (getf prim :name))
29 (defun prim-num-args (prim) (length (getf prim :args)))
30 (defun prim-args (prim) (getf prim :args))
31 (defun prim-structure-prim (prim) (getf prim :structure-prim))
32 (defun prim-is-infix (prim) (getf prim :infix))
34 (defun find-prim (symb)
36 (find symb *prims* :key #'prim-name)
37 (find symb *dynamic-prims* :key #'prim-name)))
39 ; Make this only as complicated as it needs to be, letting it grow
40 ; as we take on more and more of the language
41 (defun parse (lexed-ast &optional dynamic-prims)
42 "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
44 DYNAMIC-PRIMS: DYNAMIC-PRIM*
45 DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX)
50 LEXED-AST: An ambigious ast
51 AST: An unambigious ast that can be transpiled
52 NAME: A symbol in the keyword package
53 INFIX: Boolean denoting whether the prim is infix
54 ARG: A list of symbols denoting the type of argument
58 PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
60 DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on
61 things not statically defined by the NetLogo language, be they user defined
62 procedures or generated primitives from breed declarations.
64 The possible values for ARG are :agentset, :boolean, :number, :command-block,
67 The need for a parser between the lexer and the transpiler is because NetLogo
68 needs two passes to turn into something that can be used. This is the only entry
69 point into this module, and should probably remain that way.
71 There's also a lot of error checking that the LEXED-AST even makes sense, even
72 though the lexer obviously thought it did.
74 Examples are too numerous and varied, but by inserting an output between
75 the lexer and this code, a good idea of what goes on can be gotten."
77 ; could have defined this using the special variable, but didn't to make the
78 ; function definition simpler, as well as the documentation.
79 ((*dynamic-prims* dynamic-prims))
80 (parse-internal lexed-ast)))
82 (defun parse-internal (lexed-ast &key prev-item arg-countdown)
84 ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
86 ((and arg-countdown (zerop arg-countdown)) (append (when prev-item (list prev-item)) lexed-ast))
87 ((and prim (prim-is-infix prim))
88 (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner
91 (when prev-item (list prev-item))
94 ((stringp (car lexed-ast))
95 (parse-internal (cdr lexed-ast)
96 :prev-item (car lexed-ast)
97 :arg-countdown (when arg-countdown (1- arg-countdown))))
98 ((numberp (car lexed-ast))
99 (parse-internal (cdr lexed-ast)
100 :prev-item (coerce (car lexed-ast) 'double-float)
101 :arg-countdown (when arg-countdown (1- arg-countdown))))
102 ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown))
103 ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens"))
104 ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) arg-countdown))
105 ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) arg-countdown))
107 (when (prim-structure-prim prim)
108 (error "This doesn't make sense here"))
109 (parse-prim prim lexed-ast nil arg-countdown))
110 (t (error "Couldn't parse ~S" lexed-ast))))))))
112 (defun parse-let (lexed-ast arg-countdown)
113 (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
115 ((half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown 1)))
117 ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*)))
119 (cdr half-parsed-remainder)
120 :arg-countdown (when arg-countdown (1- arg-countdown))
121 :prev-item (list :let (car lexed-ast) (car half-parsed-remainder))))))
123 (defun parse-prim (prim lexed-ast prev-item arg-countdown)
125 ((num-args (- (prim-num-args prim) (if (prim-is-infix prim) 1 0)))
126 (half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown num-args)))
128 (nthcdr num-args half-parsed-remainder)
129 :arg-countdown (when arg-countdown (if (prim-is-infix prim) arg-countdown (1- arg-countdown)))
137 (when (prim-is-infix prim) (list prev-item))
138 (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args))))))))
140 (defun help-arg (arg-type arg)
142 ((eql arg-type :command-block)
143 (if (not (and (consp arg) (eql 'block (car arg))))
144 (error "Required a block, but found a ~A" arg)
145 (cons :command-block (cdr arg))))
146 ((eql arg-type :reporter-block)
147 (if (not (and (consp arg) (eql 'block (car arg))))
148 (error "Required a block, but found a ~A" arg)
149 (cons :reporter-block (cdr arg))))
150 ((or (eql arg-type :list) (and (listp arg-type) (find :list arg-type)))
151 (if (and (consp arg) (eql 'block (car arg)))
152 (cons :list-literal (cdr arg))
156 (defun parse-block (tokens arg-countdown)
157 (multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
158 (parse-internal after-block
159 :prev-item (cons 'block (parse-internal in-block))
160 :arg-countdown (when arg-countdown (1- arg-countdown)))))
162 (defun find-closing-bracket (tokens &optional (depth 0))
164 ((not tokens) (error "Failed to find a matching closing bracket"))
165 ((and (eql :] (car tokens)) (= depth 0)) (values nil (cdr tokens)))
166 (t (multiple-value-bind
167 (in-block after-block)
168 (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
169 (values (cons (car tokens) in-block) after-block)))))
171 (defun parse-parened-expr (tokens arg-countdown)
172 (multiple-value-bind (in-block after-block) (find-closing-paren tokens)
173 (parse-internal after-block
176 ((parsed-in-block (parse-internal in-block)))
177 (when (/= 1 (length parsed-in-block)) (error "Expected ) here"))
178 (car parsed-in-block))
179 :arg-countdown (when arg-countdown (1- arg-countdown)))))
181 (defun find-closing-paren (tokens &optional (depth 0))
183 ((not tokens) (error "Failed to find a matching closing bracket"))
184 ((and (eql (intern ")" :keyword) (car tokens)) (= depth 0)) (values nil (cdr tokens)))
185 (t (multiple-value-bind
186 (in-block after-block)
190 ((eql (intern "(" :keyword) (car tokens)) (1+ depth))
191 ((eql (intern ")" :keyword) (car tokens)) (1- depth)) (t depth)))
192 (values (cons (car tokens) in-block) after-block)))))
194 (defmacro defprim (name args &optional infix)
196 (list :name ,name :args ',args :infix ,infix)
199 (defmacro defstructureprim (name)
201 (list :name ,name :structure-prim t)
204 ; This list of prims will get combined with the mapping to actual code later
205 ; Current list of argument types we accept:
212 ; After the arguments, :infix denotes that it's an :infix operator
213 ; - Note: Later we should move it to have a list of optional attributes of the primitive
214 (defprim := (t t) :infix)
215 (defprim :!= (t t) :infix)
216 (defprim :- (:number :number) :infix)
217 (defprim :* (:number :number) :infix)
218 (defprim :+ (:number :number) :infix)
219 (defprim :/ (:number :number) :infix)
220 (defprim :< (:number :number) :infix)
221 (defprim :<= (:number :number) :infix)
222 (defprim :any? (:agentset))
223 (defprim :ask (:agentset :command-block))
224 (defprim :clear-all ())
225 (defprim :crt (:number))
227 (defprim :count (:agentset))
229 (defprim :display ())
230 (defprim :with (:reporter-block))
231 (defprim :fd (:number))
232 (defprim :hatch (:number :command-block))
233 ; (defprim :let (t t)) ; keeping this here, commented out, to note that it has special processing
234 (defprim :if (:boolean :command-block))
235 (defprim :if-else (:boolean :command-block :command-block))
236 (defprim :ifelse (:boolean :command-block :command-block))
238 (defprim :label-color ())
239 (defprim :not (:boolean))
241 (defprim :one-of ((:agentset :list)))
242 (defprim :of (:reporter-block :agentset) :infix)
243 (defprim :patches ())
245 (defprim :random (:number))
246 (defprim :random-float (:number))
247 (defprim :random-xcor ())
248 (defprim :random-ycor ())
250 (defprim :reset-ticks ())
251 (defprim :lt (:number))
252 (defprim :rt (:number))
254 (defprim :set-default-shape (t t))
255 (defprim :setxy (:number :number))
261 (defprim :turtles ())
271 (defstructureprim :globals)
272 (defstructureprim :breed)
273 (defstructureprim :turtles-own)
274 (defstructureprim :patches-own)
275 (defstructureprim :to)
276 (defstructureprim :to-report)