X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=src%2Fmain%2Fparse.lisp;h=6d45ed52cffb74e54f563a789d4793008ff7bc23;hb=c75540c;hp=ae618d283027f336c6f5c7dbcd277168289be7c4;hpb=2d0283390b58481c1f1de1ea34ea0873eed68dfe;p=clnl

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index ae618d2..6d45ed5 100644
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -24,32 +24,44 @@
 ; 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,68 +75,149 @@ 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))
-  (parse-internal lexed-ast)))
+  ((*dynamic-prims* dynamic-prims))
+  (remove-parened-forms (parse-internal lexed-ast))))
 
-(defun parse-internal (lexed-ast)
+; This is needed to clean up where we had to note parenthesis wrapped
+; things for the purpose of precedence
+(defun remove-parened-forms (parsed-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)
+  ((not parsed-ast) nil)
+  ((and (listp parsed-ast) (eql :parened (car parsed-ast))) (remove-parened-forms (cadr parsed-ast)))
+  ((listp parsed-ast) (mapcar #'remove-parened-forms parsed-ast))
+  (t parsed-ast)))
+
+(defun parse-internal (lexed-ast &key prev-item prev-remaining-arg remaining-args)
  (let
-  ((num-args (prim-num-args prim))
-   (parsed-remainder (parse-internal (cdr lexed-ast))))
-  (cons
-   (cons
-    (prim-name prim)
-    (mapcar
-     #'help-arg
-     (prim-args prim)
-     (butlast parsed-remainder (- (length parsed-remainder) num-args))))
-   (nthcdr num-args parsed-remainder))))
-
-(defun help-arg (arg-type arg)
- (case arg-type
-  (:command-block
+  ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
+  (cond
+   ((and remaining-args (eql (car remaining-args) :done-with-args))
+    (append (when prev-item (list (help-arg prev-item prev-remaining-arg))) lexed-ast))
+   ((and prim (prim-is-infix prim))
+    (parse-prim prim lexed-ast prev-item prev-remaining-arg remaining-args)) ; Special casing infix prims is cleaner
+   (t
+    (append
+     (when prev-item (list (help-arg prev-item prev-remaining-arg)))
+     (cond
+      ((not lexed-ast) nil)
+      ((stringp (car lexed-ast))
+       (parse-internal (cdr lexed-ast)
+        :prev-item (car lexed-ast)
+        :prev-remaining-arg (car remaining-args)
+        :remaining-args (cdr remaining-args)))
+      ((numberp (car lexed-ast))
+       (parse-internal (cdr lexed-ast)
+        :prev-item (coerce (car lexed-ast) 'double-float)
+        :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))
+      ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) remaining-args))
+      (prim
+       (when (prim-structure-prim prim)
+        (error "This doesn't make sense here"))
+       (parse-prim prim lexed-ast nil prev-remaining-arg remaining-args))
+      (t (error "Couldn't parse ~S" lexed-ast))))))))
+
+(defun parse-let (lexed-ast remaining-args)
+ (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
+ (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*)))
+   (parse-internal
+    (cdr half-parsed-remainder)
+    :remaining-args (cdr remaining-args)
+    :prev-remaining-arg (car remaining-args)
+    :prev-item (list :let (car lexed-ast) (cadr (car half-parsed-remainder)))))))
+
+(defun reconfigure-due-to-precedence (prev-item prim following-args)
+ (flet
+  ((calculate-precedence (x)
+    (or
+     (and
+      (listp x)
+      (< 1 (length prev-item))
+      (keywordp (car x))
+      (find-prim (car x))
+      (getf (find-prim (car x)) :precedence))
+     20)))
+  (cond
+   ((<= (getf prim :precedence) (calculate-precedence prev-item))
+    (cons
+     (prim-name prim)
+     (cons
+      (second (help-arg prev-item (car (prim-args prim))))
+      following-args)))
+   (t (append
+       (butlast prev-item)
+       (list
+        (reconfigure-due-to-precedence
+         (car (last prev-item))
+         prim
+         following-args)))))))
+
+(defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args)
+ (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))))
+   (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))))
+   (middle-forms
+    (cons
+     (if
+      (prim-is-infix prim)
+      (reconfigure-due-to-precedence prev-item prim (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint)))
+      (cons
+       (prim-name prim)
+       (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))))
+     already-parsed-limbo-forms)))
+  (append
+   (butlast middle-forms)
+   (parse-internal
+    (nthcdr (length args) half-parsed-remainder)
+    :remaining-args (if (prim-is-infix prim) remaining-args (cdr remaining-args))
+    :prev-remaining-arg (if (prim-is-infix prim) prev-remaining-arg (car remaining-args))
+    :prev-item (car (last middle-forms))))))
+
+(defun help-arg (arg arg-type)
+ (cond
+  ((not arg-type) arg)
+  ((eql arg-type :command-block)
+   (if (not (and (consp arg) (eql 'block (car arg))))
+    (error "Required a block, but found a ~A" arg)
+    (list :arg (cons :command-block (cdr arg)))))
+  ((eql arg-type :reporter-block)
    (if (not (and (consp arg) (eql 'block (car arg))))
     (error "Required a block, but found a ~A" arg)
-    (cons :command-block (cdr arg))))
-  (:list
-   (if (and (consp arg) (eql 'block (car arg)))
-    (cons :list-literal (cdr arg))
-    arg))
-  (t arg)))
-
-(defun parse-block (tokens)
+    (list :arg (cons :reporter-block (cdr arg)))))
+  ((or
+    (eql arg-type :list)
+    (and (listp arg-type) (find :list arg-type)))
+   (list
+    :arg
+    (if (and (consp arg) (eql 'block (car arg)))
+     (cons :list-literal (cdr arg))
+     arg)))
+  ((and
+    (listp arg-type)
+    (find :command-block arg-type)
+    (consp arg)
+    (eql 'block (car arg)))
+   (list :arg (cons :command-block (cdr arg))))
+  ((and (listp arg-type) (find :optional arg-type)) arg)
+  (t (list :arg arg))))
+
+(defun parse-block (tokens remaining-args)
  (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))
+   :prev-remaining-arg (car remaining-args)
+   :remaining-args (cdr remaining-args))))
 
 (defun find-closing-bracket (tokens &optional (depth 0))
  (cond
@@ -135,36 +228,38 @@ 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 find-end (tokens)
+(defun parse-parened-expr (tokens remaining-args)
+ (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"))
+    (list :parened (car parsed-in-block)))
+   :prev-remaining-arg (car remaining-args)
+   :remaining-args (cdr remaining-args))))
+
+(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 ")" :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 "(" :keyword) (car tokens)) (1+ depth))
+        ((eql (intern ")" :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 precedence &rest options)
  `(push
-   (list :name ,name :args ',args)
+   (list :name ,name :args ',args :infix ,(find :infix options) :precedence ,precedence)
    *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 +267,72 @@ DESCRIPTION:
 ; - :number
 ; - :agentset
 ; - :command-block
+; - :boolean
 ; - t - any type
-(defprim :ask (:agentset :command-block))
-(defprim :crt (:number))
-(defprim :fd (:number))
-(defprim :random-float (:number))
-(defprim :show (t))
-(defprim :turtles ())
-
-(defstructureprim :globals (:unevaluated-list))
-(defstructureprim :breed (:unevaluated-list))
-(defstructureprim :turtles-own (:unevaluated-list))
-(defstructureprim :patches-own (:unevaluated-list))
+;
+; 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) 5 :infix)
+(defprim :!= (t t) 5 :infix)
+(defprim :- (:number :number) 7 :infix)
+(defprim :* (:number :number) 8 :infix)
+(defprim :+ (:number :number) 7 :infix)
+(defprim :/ (:number :number) 8 :infix)
+(defprim :< (:number :number) 6 :infix)
+(defprim :<= (:number :number) 6 :infix)
+(defprim :any? (:agentset) 10)
+(defprim :ask (:agentset :command-block) 0)
+(defprim :ca () 0)
+(defprim :clear-all () 0)
+(defprim :crt (:number (:command-block :optional)) 0)
+(defprim :color () 10)
+(defprim :count (:agentset) 10)
+(defprim :die () 0)
+(defprim :display () 0)
+(defprim :with (:agentset :reporter-block) 12 :infix)
+(defprim :fd (:number) 0)
+(defprim :hatch (:number (:command-block :optional)) 0)
+(defprim :let (t t) 0) ; while this has special processing, we need a prim for meta information
+(defprim :if (:boolean :command-block) 0)
+(defprim :if-else (:boolean :command-block :command-block) 0)
+(defprim :ifelse (:boolean :command-block :command-block) 0)
+(defprim :label () 10)
+(defprim :label-color () 10)
+(defprim :not (:boolean) 10)
+(defprim :nobody () 10)
+(defprim :one-of ((:agentset :list)) 10)
+(defprim :of (:reporter-block :agentset) 11 :infix)
+(defprim :patches () 10)
+(defprim :pcolor () 10)
+(defprim :random (:number) 10)
+(defprim :random-float (:number) 10)
+(defprim :random-xcor () 10)
+(defprim :random-ycor () 10)
+(defprim :round (t) 10)
+(defprim :reset-ticks () 0)
+(defprim :lt (:number) 0)
+(defprim :rt (:number) 0)
+(defprim :set (t t) 0)
+(defprim :set-default-shape (t t) 0)
+(defprim :setxy (:number :number) 0)
+(defprim :show (t) 0)
+(defprim :size () 10)
+(defprim :stop () 0)
+(defprim :tick () 0)
+(defprim :ticks () 10)
+(defprim :turtles () 10)
+(defprim :who () 10)
+
+; colors
+(defprim :black () 10)
+(defprim :blue () 10)
+(defprim :brown () 10)
+(defprim :green () 10)
+(defprim :white () 10)
+
+(defstructureprim :globals)
+(defstructureprim :breed)
+(defstructureprim :turtles-own)
+(defstructureprim :patches-own)
+(defstructureprim :to)
+(defstructureprim :to-report)