X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=4f331ca5016a8dca661423994a30d6c8e91cfb57;hp=957d177b54792e5a833f371a581b2a7d2c4ca26c;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=008caa39f337b16ba74df818ee374acb3540b09d

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 957d177..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,11 +80,24 @@ 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.
   ((*dynamic-prims* dynamic-prims))
-  (parse-internal lexed-ast)))
+  (remove-parened-forms (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 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
@@ -101,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))
@@ -116,30 +148,78 @@ 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)
     :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))
+      (prim-precedence (find-prim (car x))))
+     20)))
+  (cond
+   ((<= (prim-precedence prim) (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)
+ (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
-     (cons
-      (prim-name prim)
+     (if
+      (prim-is-infix prim)
+      ; 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
-       (when (prim-is-infix prim) (list (second (help-arg prev-item (car (prim-args prim))))))
-       (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))))
-     already-parsed-limbo-forms)))
+       (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)
+       (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
@@ -151,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)
@@ -199,7 +281,7 @@ DESCRIPTION:
    (let
     ((parsed-in-block (parse-internal in-block)))
     (when (/= 1 (length parsed-in-block)) (error "Expected ) here"))
-    (car parsed-in-block))
+    (list :parened (car parsed-in-block)))
    :prev-remaining-arg (car remaining-args)
    :remaining-args (cdr remaining-args))))
 
@@ -216,9 +298,9 @@ DESCRIPTION:
         ((eql (intern ")" :keyword) (car tokens)) (1- depth)) (t depth)))
       (values (cons (car tokens) in-block) after-block)))))
 
-(defmacro defprim (name args &optional infix)
+(defmacro defprim (name args precedence &rest options)
  `(push
-   (list :name ,name :args ',args :infix ,infix)
+   (list :name ,name :args ',args :infix ,(find :infix options) :precedence ,precedence)
    *prims*))
 
 (defmacro defstructureprim (name)
@@ -232,66 +314,74 @@ DESCRIPTION:
 ; - :agentset
 ; - :command-block
 ; - :boolean
+; - :token (suspends evaluation)
 ; - t - any type
 ;
 ; 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) :infix)
-(defprim :!= (t t) :infix)
-(defprim :- (:number :number) :infix)
-(defprim :* (:number :number) :infix)
-(defprim :+ (:number :number) :infix)
-(defprim :/ (:number :number) :infix)
-(defprim :< (:number :number) :infix)
-(defprim :<= (:number :number) :infix)
-(defprim :any? (:agentset))
-(defprim :ask (:agentset :command-block))
-(defprim :clear-all ())
-(defprim :crt (:number (:command-block :optional)))
-(defprim :color ())
-(defprim :count (:agentset))
-(defprim :die ())
-(defprim :display ())
-(defprim :with (:agentset :reporter-block) :infix)
-(defprim :fd (:number))
-(defprim :hatch (:number (:command-block :optional)))
-; (defprim :let (t t)) ; keeping this here, commented out, to note that it has special processing
-(defprim :if (:boolean :command-block))
-(defprim :if-else (:boolean :command-block :command-block))
-(defprim :ifelse (:boolean :command-block :command-block))
-(defprim :label ())
-(defprim :label-color ())
-(defprim :not (:boolean))
-(defprim :nobody ())
-(defprim :one-of ((:agentset :list)))
-(defprim :of (:reporter-block :agentset) :infix)
-(defprim :patches ())
-(defprim :pcolor ())
-(defprim :random (:number))
-(defprim :random-float (:number))
-(defprim :random-xcor ())
-(defprim :random-ycor ())
-(defprim :round (t))
-(defprim :reset-ticks ())
-(defprim :lt (:number))
-(defprim :rt (:number))
-(defprim :set (t t))
-(defprim :set-default-shape (t t))
-(defprim :setxy (:number :number))
-(defprim :show (t))
-(defprim :size ())
-(defprim :stop ())
-(defprim :tick ())
-(defprim :ticks ())
-(defprim :turtles ())
-(defprim :who ())
+(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 :create-turtles (: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 :turtles-here () 10)
+(defprim :who () 10)
 
 ; colors
-(defprim :black ())
-(defprim :blue ())
-(defprim :brown ())
-(defprim :green ())
-(defprim :white ())
+(defprim :black () 10)
+(defprim :blue () 10)
+(defprim :brown () 10)
+(defprim :green () 10)
+(defprim :white () 10)
+
+; booleans
+(defprim :true () 10)
+(defprim :false () 10)
 
 (defstructureprim :globals)
 (defstructureprim :breed)