X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=4f331ca5016a8dca661423994a30d6c8e91cfb57;hp=e3daa0882e9606175f9d21debe17bc68f2dc6806;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=bc6386a709da76fef1393a11a7251b4be7032fda diff --git a/src/main/parse.lisp b/src/main/parse.lisp index e3daa08..4f331ca 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -68,7 +68,8 @@ DESCRIPTION: 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 @@ -121,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)) @@ -136,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) @@ -170,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 @@ -198,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) @@ -279,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 @@ -343,6 +379,10 @@ DESCRIPTION: (defprim :green () 10) (defprim :white () 10) +; booleans +(defprim :true () 10) +(defprim :false () 10) + (defstructureprim :globals) (defstructureprim :breed) (defstructureprim :turtles-own)