X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=ad9f746a211d8e15bf1d2a3d4e55e2f41ab46531;hb=c9cf0d1;hp=ae618d283027f336c6f5c7dbcd277168289be7c4;hpb=2d0283390b58481c1f1de1ea34ea0873eed68dfe;p=clnl diff --git a/src/main/parse.lisp b/src/main/parse.lisp index ae618d2..ad9f746 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -24,32 +24,45 @@ ; prims that are created when compiling the netlogo file ; usually via procedures or top level things like breed declarations (defparameter *dynamic-prims* nil) -(defvar *in-structure* 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-in-structure (prim) (getf prim :in-structure)) +(defun prim-structure-prim (prim) (getf prim :structure-prim)) +(defun prim-is-infix (prim) (getf prim :infix)) -(defun find-prim (symb) (find symb *prims* :key #'prim-name)) +(defun find-prim (symb) + (or + (find symb *prims* :key #'prim-name) + (find symb *dynamic-prims* :key #'prim-name))) ; 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 &optional structure) - "PARSE LEXED-AST &optional STRUCTURE => AST +(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 - STRUCTURE: A boolean 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. - When STRUCTURE is true, parse is done with the expanded indentifier set used - in NetLogo files, as well as pulling out procedure definitions. + 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 @@ -63,48 +76,66 @@ DESCRIPTION: (let ; could have defined this using the special variable, but didn't to make the ; function definition simpler, as well as the documentation. - ((*in-structure* structure)) + ((*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-internal (cdr lexed-ast)))) - ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast))) - ((eql :to (car lexed-ast)) (parse-procedure lexed-ast)) - ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast))) - (let - ((prim (find-prim (car lexed-ast)))) - (when (and (not *in-structure*) (prim-in-structure prim)) - (error "This doesn't make sense here")) - (if - (and (= (prim-num-args prim) 1) (eql :unevaluated-list (car (prim-args prim)))) - (parse-prim-with-unevaluated-list prim lexed-ast) - (parse-prim-normally prim lexed-ast)))) - (t (error "Couldn't parse ~S" lexed-ast)))) - -; This is a special case but left with a little wiggle room for future -; enhancements, like code blocks -(defun parse-prim-with-unevaluated-list (prim lexed-ast) - (when (not (eql :[ (cadr lexed-ast))) - (error "Expected list literal here")) - (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast)) - (cons - (list (prim-name prim) (cons :list-literal in-list)) - (parse-internal after-list)))) - -(defun parse-prim-normally (prim lexed-ast) +(defun parse-internal (lexed-ast &key prev-item arg-countdown) (let - ((num-args (prim-num-args prim)) - (parsed-remainder (parse-internal (cdr lexed-ast)))) - (cons + ((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 :let (car lexed-ast)) (parse-let (cdr lexed-ast) arg-countdown)) + ((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-let (lexed-ast arg-countdown) + (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let")) + (let* + ((half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown 1))) + (let + ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*))) + (parse-internal + (cdr half-parsed-remainder) + :arg-countdown (when arg-countdown (1- arg-countdown)) + :prev-item (list :let (car lexed-ast) (car half-parsed-remainder)))))) + +(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) - (butlast parsed-remainder (- (length parsed-remainder) num-args)))) - (nthcdr num-args parsed-remainder)))) + (append + (when (prim-is-infix prim) (list prev-item)) + (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args)))))))) (defun help-arg (arg-type arg) (case arg-type @@ -112,19 +143,21 @@ DESCRIPTION: (if (not (and (consp arg) (eql 'block (car arg)))) (error "Required a block, but found a ~A" arg) (cons :command-block (cdr arg)))) + (:reporter-block + (if (not (and (consp arg) (eql 'block (car arg)))) + (error "Required a block, but found a ~A" arg) + (cons :reporter-block (cdr arg)))) (:list (if (and (consp arg) (eql 'block (car arg))) (cons :list-literal (cdr arg)) arg)) (t arg))) -(defun parse-block (tokens) +(defun parse-block (tokens arg-countdown) (multiple-value-bind (in-block after-block) (find-closing-bracket tokens) - (cons - (cons - 'block - (parse-internal in-block)) - (parse-internal after-block)))) + (parse-internal after-block + :prev-item (cons 'block (parse-internal in-block)) + :arg-countdown (when arg-countdown (1- arg-countdown))))) (defun find-closing-bracket (tokens &optional (depth 0)) (cond @@ -135,36 +168,37 @@ DESCRIPTION: (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth))) (values (cons (car tokens) in-block) after-block))))) -; Due to the non expression style syntax of procedures, this must be special cased -(defun parse-procedure (tokens) - (when (not *in-structure*) (error "This doesn't make sense here")) - (multiple-value-bind (in-block after-block) (find-end tokens) - (declare (ignore in-block)) - (cons - (cons - (car tokens) - nil) ; Update this to parsing the internal of the inblock) - (parse-internal after-block)))) +(defun parse-parened-expr (tokens arg-countdown) + (multiple-value-bind (in-block after-block) (find-closing-paren tokens) + (parse-internal after-block + :prev-item + (let + ((parsed-in-block (parse-internal in-block))) + (when (/= 1 (length parsed-in-block)) (error "Expected ) here")) + (car parsed-in-block)) + :arg-countdown (when arg-countdown (1- arg-countdown))))) -(defun find-end (tokens) +(defun find-closing-paren (tokens &optional (depth 0)) (cond - ((not tokens) (error "Failed to find end")) - ((eql :end (car tokens)) (values nil (cdr tokens))) - (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens)) + ((not tokens) (error "Failed to find a matching closing bracket")) + ((and (eql (intern ")" (find-package :keyword)) (car tokens)) (= depth 0)) (values nil (cdr tokens))) + (t (multiple-value-bind + (in-block after-block) + (find-closing-paren + (cdr tokens) + (cond + ((eql (intern "(" (find-package :keyword)) (car tokens)) (1+ depth)) + ((eql (intern ")" (find-package :keyword)) (car tokens)) (1- depth)) (t depth))) (values (cons (car tokens) in-block) after-block))))) -; Used to populate dynamic-prims -(defun determine-procedure-definition (tokens) - (declare (ignore tokens))) - -(defmacro defprim (name args) +(defmacro defprim (name args &optional infix) `(push - (list :name ,name :args ',args) + (list :name ,name :args ',args :infix ,infix) *prims*)) -(defmacro defstructureprim (name args) +(defmacro defstructureprim (name) `(push - (list :name ,name :args ',args :in-structure t) + (list :name ,name :structure-prim t) *prims*)) ; This list of prims will get combined with the mapping to actual code later @@ -172,15 +206,77 @@ DESCRIPTION: ; - :number ; - :agentset ; - :command-block +; - :boolean ; - t - any type +; +; After the arguments, :infix denotes that it's an :infix operator +; - Note: Later we should move it to have a list of optional attributes of the primitive +(defprim := (t t) :infix) +(defprim :!= (t t) :infix) +(defprim :- (:number :number) :infix) +(defprim :* (:number :number) :infix) +(defprim :+ (:number :number) :infix) +(defprim :/ (:number :number) :infix) +(defprim :< (:number :number) :infix) +(defprim :<= (:number :number) :infix) +(defprim :any? (:agentset)) (defprim :ask (:agentset :command-block)) +(defprim :clear-all ()) (defprim :crt (:number)) +(defprim :color ()) +(defprim :count ()) +(defprim :die ()) +(defprim :display ()) +(defprim :with (:reporter-block)) (defprim :fd (:number)) +(defprim :hatch (:number :command-block)) +; (defprim :let (t t)) ; keeping this here, commented out, to note that it has special processing +(defprim :if (:boolean :command-block)) +(defprim :if-else (:boolean :command-block :command-block)) +(defprim :ifelse (:boolean :command-block :command-block)) +(defprim :label ()) +(defprim :label-color ()) +(defprim :not (:boolean)) +(defprim :nobody ()) +(defprim :one-of (t)) +(defprim :patches ()) +(defprim :pcolor ()) +(defprim :random (:number)) (defprim :random-float (:number)) +(defprim :random-xcor ()) +(defprim :random-ycor ()) +(defprim :round ()) +(defprim :reset-ticks ()) +(defprim :lt (:number)) +(defprim :rt (:number)) +(defprim :set (t t)) +(defprim :set-default-shape (t t)) +(defprim :setxy (:number :number)) (defprim :show (t)) +(defprim :size ()) +(defprim :stop ()) +(defprim :tick ()) (defprim :turtles ()) -(defstructureprim :globals (:unevaluated-list)) -(defstructureprim :breed (:unevaluated-list)) -(defstructureprim :turtles-own (:unevaluated-list)) -(defstructureprim :patches-own (:unevaluated-list)) +; colors +(defprim :black ()) +(defprim :blue ()) +(defprim :brown ()) +(defprim :green ()) +(defprim :white ()) + +(defstructureprim :globals) +(defstructureprim :breed) +(defstructureprim :turtles-own) +(defstructureprim :patches-own) +(defstructureprim :to) +(defstructureprim :to-report) + +; Placeholder prims that should be populated in dynamic prims + +; Generated by breeds +(defprim :sheep ()) +(defprim :wolves ()) +(defprim :create-sheep (:number :command-block)) ; look at me not have to do optionals yet +(defprim :sheep-here ()) +(defprim :create-wolves (:number :command-block))