From: Frank Duncan Date: Fri, 28 Apr 2017 22:38:55 +0000 (-0500) Subject: Parser/Transpiler - Add optional reporter logic X-Git-Tag: 0.1.1~11 X-Git-Url: https://code.consxy.com/gitweb/?a=commitdiff_plain;h=a1c5dfe5f543aeb9d0e68414151153603a7435f0;p=clnl Parser/Transpiler - Add optional reporter logic --- diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 196b63b..4a0ddeb 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -193,21 +193,33 @@ DESCRIPTION: (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 diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index e78208d..4ab7559 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -49,7 +49,6 @@ DESCRIPTION: Calling eval on that code should work correctly as long as you have a running engine." - (let ((*dynamic-prims* (mapcar @@ -58,11 +57,13 @@ DESCRIPTION: (append (list :func (getf prim :macro)) prim) (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim))) dynamic-prims))) - (cond - ((command-list-p parsed-ast) (transpile-commands parsed-ast)) - ((and (listp parsed-ast) (= 1 (length parsed-ast)) (reporter-p (car parsed-ast))) - (transpile-reporter (car parsed-ast))) - (t (error "Is neither a list of commands nor a reporter: ~S" parsed-ast))))) + (let + ((deoptionalized-ast (deoptionalize parsed-ast))) + (cond + ((command-list-p deoptionalized-ast) (transpile-commands deoptionalized-ast)) + ((and (listp deoptionalized-ast) (= 1 (length deoptionalized-ast)) (reporter-p (car deoptionalized-ast))) + (transpile-reporter (car deoptionalized-ast))) + (t (error "Is neither a list of commands nor a reporter: ~S" deoptionalized-ast)))))) (defun command-list-p (parsed-ast) "COMMAND-LIST-P PARSED-AST => RESULT @@ -76,9 +77,12 @@ DESCRIPTION: COMMAND-LIST-P returns whether the parsed-ast is a valid list of commands." + (every #'command-p parsed-ast)) + +(defun command-p (parsed-ast) (and - (every #'listp parsed-ast) - (every #'prim-command-p (mapcar #'find-prim (mapcar #'car parsed-ast))))) + (listp parsed-ast) + (prim-command-p (find-prim (car parsed-ast))))) (defun reporter-p (parsed-ast) "REPORTER-P PARSED-AST => RESULT @@ -92,6 +96,7 @@ DESCRIPTION: REPORTER-P returns whether the parsed-ast is a valid reporter." (and + (listp parsed-ast) (symbolp (car parsed-ast)) (prim-reporter-p (find-prim (car parsed-ast))))) @@ -101,6 +106,51 @@ DESCRIPTION: `(progn ,@(transpile-commands-inner parsed-ast))) +; This makes some assumptions about the precedence of optionality +; Consider the following: +; - command-1 +; - reporter-1 +; +; And consider: +; - command-1 reporter-1 "foo" +; +; Does the "foo" belong to command-1 or reporter-1? +; +; I'm not sure how netlogo answers this at this time, but for the purposes +; of this deoptionalizer, "foo" belongs to reporter-1. In the case that the +; language tests treat this as incorrect, I'll fix it. I'm not sure if this +; case exists in the base netlogo language, and I don't feel like creating +; a specific test case at this time to find out. +(defun deoptionalize (parsed-ast) + (let + ((first-thing (car parsed-ast))) + (cond + ((not parsed-ast) nil) + ((not (listp first-thing)) (cons first-thing (deoptionalize (cdr parsed-ast)))) + ((and + (find :optional first-thing) + (cadr parsed-ast) + (not (command-p (cadr parsed-ast)))) + (let + ((deoptionalized-rest (deoptionalize (cdr parsed-ast))) + (optional-pos (position :optional first-thing))) + (deoptionalize + (cons + (append + (subseq first-thing 0 optional-pos) + (list (car deoptionalized-rest)) + (subseq first-thing (1+ optional-pos))) + (cdr deoptionalized-rest))))) + ((find :optional first-thing) + (deoptionalize + (cons + (subseq first-thing 0 (position :optional first-thing)) + (cdr parsed-ast)))) + (t + (cons + (deoptionalize first-thing) + (deoptionalize (cdr parsed-ast))))))) + (defun transpile-commands-inner (parsed-ast) (cond ((not parsed-ast) nil)