X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=4f331ca5016a8dca661423994a30d6c8e91cfb57;hp=a44caeaa0df8704d984116dcde11d6c233bd03d1;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=c739aec9e225747148c14c0c3b76f4147ff7be81 diff --git a/src/main/parse.lisp b/src/main/parse.lisp index a44caea..4f331ca 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -26,6 +26,7 @@ (defparameter *dynamic-prims* nil) (defun prim-name (prim) (getf prim :name)) +(defun prim-precedence (prim) (getf prim :precedence)) (defun prim-args (prim) (getf prim :args)) (defun prim-structure-prim (prim) (getf prim :structure-prim)) (defun prim-is-infix (prim) (getf prim :infix)) @@ -41,7 +42,7 @@ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST DYNAMIC-PRIMS: DYNAMIC-PRIM* - DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX) + DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE) ARGS: ARG* ARGUMENTS AND VALUES: @@ -49,7 +50,8 @@ 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 + INFIX: Boolean denoting whether the prim is infix, defaulting to NIL + PRECEDENCE: A number, usually 10 for reporters, and 0 for commands ARG: A list of symbols denoting the type of argument DESCRIPTION: @@ -58,10 +60,16 @@ DESCRIPTION: 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. + procedures or generated primitives from breed declarations. NAME and PRECEDENCE + are required for all dynamic prims. + + PRECEDENCE is a number used to calculate the order of operations. Higher numbers + have more precedence than lower ones. Generally all commands should have the + lowest precedence, and all reporters should have 10 as the precedence. The possible values for ARG are :agentset, :boolean, :number, :command-block, - or t for wildcard. + :string, or t for wildcard. For optional arguments, ARG can be a list of the form + (ARG :optional) where ARG is one of the aforementioned values. 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 @@ -72,6 +80,10 @@ DESCRIPTION: 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." + (when (find nil dynamic-prims :key #'prim-name) + (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name))) + (when (find nil dynamic-prims :key #'prim-precedence) + (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence))) (let ; could have defined this using the special variable, but didn't to make the ; function definition simpler, as well as the documentation. @@ -110,6 +122,17 @@ DESCRIPTION: :prev-item (coerce (car lexed-ast) 'double-float) :prev-remaining-arg (car remaining-args) :remaining-args (cdr remaining-args))) + ((and remaining-args + (or + (eql :token (car remaining-args)) + (and + (listp (car remaining-args)) + (find :token (car remaining-args)) + (symbolp (car lexed-ast))))) + (parse-internal (cdr lexed-ast) + :prev-item (car lexed-ast) + :prev-remaining-arg (car remaining-args) + :remaining-args (cdr remaining-args))) ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) remaining-args)) ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens")) ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) remaining-args)) @@ -125,7 +148,7 @@ DESCRIPTION: (let* ((half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (list t :done-with-args)))) (let - ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*))) + ((*dynamic-prims* (cons (list :name (car lexed-ast) :precedence 20) *dynamic-prims*))) (parse-internal (cdr half-parsed-remainder) :remaining-args (cdr remaining-args) @@ -141,10 +164,10 @@ DESCRIPTION: (< 1 (length prev-item)) (keywordp (car x)) (find-prim (car x)) - (getf (find-prim (car x)) :precedence)) + (prim-precedence (find-prim (car x)))) 20))) (cond - ((<= (getf prim :precedence) (calculate-precedence prev-item)) + ((<= (prim-precedence prim) (calculate-precedence prev-item)) (cons (prim-name prim) (cons @@ -159,23 +182,44 @@ DESCRIPTION: following-args))))))) (defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args) + (when (not (prim-precedence prim)) + (error "Prim must have a precedence! ~A" prim)) + (when (and (prim-is-infix prim) (eql :token (car (prim-args prim)))) + (error "Can't have a prim that wants a token in the first position while being infix: ~A" prim)) + (when + (and + (< (prim-precedence prim) 20) + (find-if (lambda (arg) (or (eql :token arg) (and (listp arg) (find :token arg)))) (prim-args prim))) + (error "Can't have a prim that wants a token and has a precedence of less than 20: ~A" prim)) (let* ((args (if (prim-is-infix prim) (cdr (prim-args prim)) (prim-args prim))) - (half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args)))) + (half-parsed-remainder + (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args)))) (breakpoint (or (position-if (lambda (form) (or (not (listp form)) (not (eql :arg (car form))))) half-parsed-remainder) (length half-parsed-remainder))) (already-parsed-limbo-forms (subseq half-parsed-remainder breakpoint (min (length args) (length half-parsed-remainder)))) + (num-optional-forms (- (length args) breakpoint)) (middle-forms (cons (if (prim-is-infix prim) - (reconfigure-due-to-precedence prev-item prim (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))) + ; There's a potential bug here about infix operators with optional forms, where the first item is optional + ; I don't consider that super likely though... + (append + (reconfigure-due-to-precedence prev-item prim (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))) + (loop :repeat num-optional-forms :collect :optional)) (cons (prim-name prim) - (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint)))) - already-parsed-limbo-forms))) + (append + (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint)) + (loop :repeat num-optional-forms :collect :optional)))) ; we save the place for optionals for the transpiler + already-parsed-limbo-forms)));) + (let + ((arg-at-bp (nth breakpoint args))) + (when (and arg-at-bp (or (not (listp arg-at-bp)) (not (find :optional arg-at-bp)))) + (error "Stopped collecting arguments, but non optional arguments remain"))) (append (butlast middle-forms) (parse-internal @@ -187,6 +231,8 @@ DESCRIPTION: (defun help-arg (arg arg-type) (cond ((not arg-type) arg) + ((eql arg-type :token) (list :arg (list :token arg))) + ((and (listp arg-type) (find :token arg-type) (symbolp arg)) (list :arg (list :token arg))) ((eql arg-type :command-block) (if (not (and (consp arg) (eql 'block (car arg)))) (error "Required a block, but found a ~A" arg) @@ -268,6 +314,7 @@ DESCRIPTION: ; - :agentset ; - :command-block ; - :boolean +; - :token (suspends evaluation) ; - t - any type ; ; After the arguments, :infix denotes that it's an :infix operator @@ -285,6 +332,7 @@ DESCRIPTION: (defprim :ca () 0) (defprim :clear-all () 0) (defprim :crt (:number (:command-block :optional)) 0) +(defprim :create-turtles (:number (:command-block :optional)) 0) (defprim :color () 10) (defprim :count (:agentset) 10) (defprim :die () 0) @@ -331,6 +379,10 @@ DESCRIPTION: (defprim :green () 10) (defprim :white () 10) +; booleans +(defprim :true () 10) +(defprim :false () 10) + (defstructureprim :globals) (defstructureprim :breed) (defstructureprim :turtles-own)