X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=97588bb085d1ef9df51ad59aab4ab1a0f00165b4;hb=3abea7023574532423fa24d5f97154db474b50a0;hp=40be292d3d97fe2ab18955627409aaac2cfe35d8;hpb=c5613b87ab91b845b628d9201ad053da92912838;p=clnl diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 40be292..97588bb 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-nl.parser) +(in-package #:clnl-parser) ; Ok, after thinking about this a little, the parser is completely contextual ; based on what has come before. We can't do a contextless parsing, like we @@ -21,44 +21,134 @@ ; - We don't really care if things are commands or reporters right now (defparameter *prims* nil) +; prims that are created when compiling the netlogo file +; usually via procedures or top level things like breed declarations +(defparameter *dynamic-prims* nil) (defun prim-name (prim) (getf prim :name)) (defun prim-num-args (prim) (length (getf prim :args))) +(defun prim-args (prim) (getf prim :args)) +(defun prim-structure-prim (prim) (getf prim :structure-prim)) (defun find-prim (symb) (find symb *prims* :key #'prim-name)) -; We don't care if it's a command! -;(defun is-command (symb) -; (let -; ((prim (find-prim symb))) -; (and prim (eql :command (getf prim :type))))) - ; Make this only as complicated as it needs to be, letting it grow ; as we take on more and more of the language -(defun parse (lexed-ast) +(defun parse (lexed-ast &optional dynamic-prims) + "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST + + DYNAMIC-PRIMS: DYNAMIC-PRIM* + +ARGUMENTS AND VALUES: + + LEXED-AST: An ambigious ast + AST: An unambigious ast that can be transpiled + DYNAMIC-PRIM: A prim not statically defined + +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 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) (cond ((not lexed-ast) nil) - ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse (cdr lexed-ast)))) + ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse-internal (cdr lexed-ast)))) + ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast))) ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast))) - (let* - ((prim (find-prim (car lexed-ast))) - (num-args (prim-num-args prim)) - (parsed-remainder (parse (cdr lexed-ast)))) - (cons - (cons - (prim-name prim) - (butlast parsed-remainder (- (length parsed-remainder) num-args))) - (nthcdr num-args parsed-remainder)))) + (let + ((prim (find-prim (car lexed-ast)))) + (when (prim-structure-prim prim) + (error "This doesn't make sense here")) + (parse-prim prim lexed-ast))) (t (error "Couldn't parse ~S" lexed-ast)))) +(defun parse-prim (prim lexed-ast) + (let + ((num-args (prim-num-args prim)) + (parsed-remainder (parse-internal (cdr lexed-ast)))) + (cons + (cons + (prim-name prim) + (mapcar + #'help-arg + (prim-args prim) + (butlast parsed-remainder (- (length parsed-remainder) num-args)))) + (nthcdr num-args parsed-remainder)))) + +(defun help-arg (arg-type arg) + (case arg-type + (:command-block + (if (not (and (consp arg) (eql 'block (car arg)))) + (error "Required a block, but found a ~A" arg) + (cons :command-block (cdr arg)))) + (:list + (if (and (consp arg) (eql 'block (car arg))) + (cons :list-literal (cdr arg)) + arg)) + (t arg))) + +(defun parse-block (tokens) + (multiple-value-bind (in-block after-block) (find-closing-bracket tokens) + (cons + (cons + 'block + (parse-internal in-block)) + (parse-internal after-block)))) + +(defun find-closing-bracket (tokens &optional (depth 0)) + (cond + ((not tokens) (error "Failed to find a matching closing bracket")) + ((and (eql :] (car tokens)) (= depth 0)) (values nil (cdr tokens))) + (t (multiple-value-bind + (in-block after-block) + (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth))) + (values (cons (car tokens) in-block) after-block))))) + (defmacro defprim (name args) `(push (list :name ,name :args ',args) *prims*)) +(defmacro defstructureprim (name) + `(push + (list :name ,name :structure-prim t) + *prims*)) + ; This list of prims will get combined with the mapping to actual code later ; Current list of argument types we accept: ; - :number +; - :agentset +; - :command-block ; - t - any type +(defprim :ask (:agentset :command-block)) (defprim :crt (:number)) +(defprim :fd (:number)) +(defprim :random-float (:number)) (defprim :show (t)) +(defprim :turtles ()) + +(defstructureprim :globals) +(defstructureprim :breed) +(defstructureprim :turtles-own) +(defstructureprim :patches-own) +(defstructureprim :to) +(defstructureprim :to-report)