Parser/Transpiler - Add optional reporter logic

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 196b63bc35bf70484a12f3edab04ec82af632917..4a0ddeb288675ba1f2a27653e038eef4b5fe6a71 100644 (file)
--- 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)))
   (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))))
    (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)
    (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)
       (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
   (append
    (butlast middle-forms)
    (parse-internal

diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index e78208d55bab867c01a5451d495a7fc2beb52857..4ab75596f5a84c9703df9cf7db55072775f2535f 100644 (file)
--- 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."
 
   Calling eval on that code should work correctly as long as you have a
   running engine."

-

  (let
   ((*dynamic-prims*
     (mapcar
  (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)))
        (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
 
 (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."
 
   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
  (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
 
 (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
 
   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)))))
 
   (symbolp (car parsed-ast))
   (prim-reporter-p (find-prim (car parsed-ast)))))
 


@@ -101,6 +106,51 @@ DESCRIPTION:
  `(progn
    ,@(transpile-commands-inner parsed-ast)))
 
  `(progn
    ,@(transpile-commands-inner parsed-ast)))
 

+; This makes some assumptions about the precedence of optionality
+; Consider the following:
+; - command-1 <optional> <optional>
+; - reporter-1 <optional>
+;
+; 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)
 (defun transpile-commands-inner (parsed-ast)
  (cond
   ((not parsed-ast) nil)