+(defun parse (lexed-ast &optional dynamic-prims)
+ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
+
+ DYNAMIC-PRIMS: DYNAMIC-PRIM*
+ DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX)
+ ARGS: ARG*
+
+ARGUMENTS AND VALUES:
+
+ LEXED-AST: An ambigious ast
+ AST: An unambigious ast that can be transpiled
+ NAME: A symbol in the keyword package
+ INFIX: Boolean denoting whether the prim is infix
+ ARG: A list of symbols denoting the type of argument
+
+DESCRIPTION:
+
+ PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
+
+ DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on
+ things not statically defined by the NetLogo language, be they user defined
+ procedures or generated primitives from breed declarations.
+
+ The possible values for ARG are :agentset, :boolean, :number, :command-block,
+ or t for wildcard.
+
+ The need for a parser between the lexer and the transpiler is because NetLogo
+ needs two passes to turn into something that can be used. This is the only entry
+ point into this module, and should probably remain that way.
+
+ There's also a lot of error checking that the LEXED-AST even makes sense, even
+ though the lexer obviously thought it did.
+
+ Examples are too numerous and varied, but by inserting an output between
+ the lexer and this code, a good idea of what goes on can be gotten."
+ (let
+ ; could have defined this using the special variable, but didn't to make the
+ ; function definition simpler, as well as the documentation.
+ ((*dynamic-prims* dynamic-prims))
+ (parse-internal lexed-ast)))
+
+(defun parse-internal (lexed-ast &key prev-item arg-countdown)
+ (let
+ ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
+ (cond
+ ((and arg-countdown (zerop arg-countdown)) (append (when prev-item (list prev-item)) lexed-ast))
+ ((and prim (prim-is-infix prim))
+ (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner
+ (t
+ (append
+ (when prev-item (list prev-item))
+ (cond
+ ((not lexed-ast) nil)
+ ((stringp (car lexed-ast))
+ (parse-internal (cdr lexed-ast)
+ :prev-item (car lexed-ast)
+ :arg-countdown (when arg-countdown (1- arg-countdown))))
+ ((numberp (car lexed-ast))
+ (parse-internal (cdr lexed-ast)
+ :prev-item (coerce (car lexed-ast) 'double-float)
+ :arg-countdown (when arg-countdown (1- arg-countdown))))
+ ((eql (intern "(" (find-package :keyword)) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown))
+ ((eql (intern ")" (find-package :keyword)) (car lexed-ast)) (error "Closing parens has no opening parens"))
+ ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) arg-countdown))
+ (prim
+ (when (prim-structure-prim prim)
+ (error "This doesn't make sense here"))
+ (parse-prim prim lexed-ast nil arg-countdown))
+ (t (error "Couldn't parse ~S" lexed-ast))))))))
+
+(defun parse-prim (prim lexed-ast prev-item arg-countdown)
+ (let*
+ ((num-args (- (prim-num-args prim) (if (prim-is-infix prim) 1 0)))
+ (half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown num-args)))
+ (parse-internal
+ (nthcdr num-args half-parsed-remainder)
+ :arg-countdown (when arg-countdown (if (prim-is-infix prim) arg-countdown (1- arg-countdown)))
+ :prev-item
+ (cons
+ (prim-name prim)
+ (mapcar
+ #'help-arg
+ (prim-args prim)
+ (append
+ (when (prim-is-infix prim) (list prev-item))
+ (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args))))))))