X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fparse.lisp;h=eaaa3fe1d5fdf70c82d43c77431caacfaf5e7dea;hb=72d7364634aec6c24803deb29bdfde0fbfa6e7ad;hp=65200d3e5927c01d22e3ff526c4e9399454a4955;hpb=d4ab3334d216c9963f9459d9e8870c6abafce8f1;p=clnl

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 65200d3..eaaa3fe 100644
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -1,4 +1,4 @@
-(in-package #:cl-nl.parser)
+(in-package #:clnl-parser)
 
 ; Ok, after thinking about this a little, the parser is completely contextual
 ; based on what has come before.  We can't do a contextless parsing, like we
@@ -21,50 +21,121 @@
 ;    - We don't really care if things are commands or reporters right now
 
 (defparameter *prims* nil)
+; prims that are created when compiling the netlogo file
+; usually via procedures or top level things like breed declarations
+(defparameter *dynamic-prims* 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-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))
 
 ; 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)
- (cond
-  ((not lexed-ast) nil)
-  ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse (cdr lexed-ast))))
-  ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast)))
-  ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))
-   (let*
-    ((prim (find-prim (car lexed-ast)))
-     (num-args (prim-num-args prim))
-     (parsed-remainder (parse (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))))
-  (t (error "Couldn't parse ~S" lexed-ast))))
+(defun parse (lexed-ast &optional dynamic-prims)
+ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
+
+  DYNAMIC-PRIMS: DYNAMIC-PRIM*
+
+ARGUMENTS AND VALUES:
+
+  LEXED-AST: An ambigious ast
+  AST: An unambigious ast that can be transpiled
+  DYNAMIC-PRIM: A prim not statically defined
+
+DESCRIPTION:
+
+  PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
+
+  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 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
+  point into this module, and should probably remain that way.
+
+  There's also a lot of error checking that the LEXED-AST even makes sense, even
+  though the lexer obviously thought it did.
+
+  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."
+ (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)))
+
+(defun parse-internal (lexed-ast &key prev-item arg-countdown)
+ (let
+  ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
+  (cond
+   ((and arg-countdown (zerop arg-countdown)) (append (when prev-item (list prev-item)) lexed-ast))
+   ((and prim (prim-is-infix prim))
+    (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner
+   (t
+    (append
+     (when prev-item (list prev-item))
+     (cond
+      ((not lexed-ast) nil)
+      ((stringp (car lexed-ast))
+       (parse-internal (cdr lexed-ast)
+        :prev-item (car lexed-ast)
+        :arg-countdown (when arg-countdown (1- arg-countdown))))
+      ((numberp (car lexed-ast))
+       (parse-internal (cdr lexed-ast)
+        :prev-item (coerce (car lexed-ast) 'double-float)
+        :arg-countdown (when arg-countdown (1- arg-countdown))))
+      ((eql (intern "(" (find-package :keyword)) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown))
+      ((eql (intern ")" (find-package :keyword)) (car lexed-ast)) (error "Closing parens has no opening parens"))
+      ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) arg-countdown))
+      (prim
+       (when (prim-structure-prim prim)
+        (error "This doesn't make sense here"))
+       (parse-prim prim lexed-ast nil arg-countdown))
+      (t (error "Couldn't parse ~S" lexed-ast))))))))
+
+(defun parse-prim (prim lexed-ast prev-item arg-countdown)
+ (let*
+  ((num-args (- (prim-num-args prim) (if (prim-is-infix prim) 1 0)))
+   (half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown num-args)))
+  (parse-internal
+   (nthcdr num-args half-parsed-remainder)
+   :arg-countdown (when arg-countdown (if (prim-is-infix prim) arg-countdown (1- arg-countdown)))
+   :prev-item
+   (cons
+    (prim-name prim)
+    (mapcar
+     #'help-arg
+     (prim-args prim)
+     (append
+      (when (prim-is-infix prim) (list prev-item))
+      (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args))))))))
 
 (defun help-arg (arg-type arg)
  (case arg-type
   (:command-block
    (if (not (and (consp arg) (eql 'block (car arg))))
-       (error "Required a block, but found a ~A" arg)
-       (cons :command-block (cdr arg))))
+    (error "Required a block, but found a ~A" arg)
+    (cons :command-block (cdr arg))))
+  (:reporter-block
+   (if (not (and (consp arg) (eql 'block (car arg))))
+    (error "Required a block, but found a ~A" arg)
+    (cons :reporter-block (cdr arg))))
+  (:list
+   (if (and (consp arg) (eql 'block (car arg)))
+    (cons :list-literal (cdr arg))
+    arg))
   (t arg)))
 
-(defun parse-block (tokens)
+(defun parse-block (tokens arg-countdown)
  (multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
-  (cons
-   (cons
-    'block
-    (parse in-block))
-   (parse after-block))))
+  (parse-internal after-block
+   :prev-item (cons 'block (parse-internal in-block))
+   :arg-countdown (when arg-countdown (1- arg-countdown)))))
 
 (defun find-closing-bracket (tokens &optional (depth 0))
  (cond
@@ -75,9 +146,37 @@
       (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
       (values (cons (car tokens) in-block) after-block)))))
 
-(defmacro defprim (name args)
+(defun parse-parened-expr (tokens arg-countdown)
+ (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"))
+    (car parsed-in-block))
+   :arg-countdown (when arg-countdown (1- arg-countdown)))))
+
+(defun find-closing-paren (tokens &optional (depth 0))
+ (cond
+  ((not tokens) (error "Failed to find a matching closing bracket"))
+  ((and (eql (intern ")" (find-package :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 "(" (find-package :keyword)) (car tokens)) (1+ depth))
+        ((eql (intern ")" (find-package :keyword)) (car tokens)) (1- depth)) (t depth)))
+      (values (cons (car tokens) in-block) after-block)))))
+
+(defmacro defprim (name args &optional infix)
  `(push
-   (list :name ,name :args ',args)
+   (list :name ,name :args ',args :infix ,infix)
+   *prims*))
+
+(defmacro defstructureprim (name)
+ `(push
+   (list :name ,name :structure-prim t)
    *prims*))
 
 ; This list of prims will get combined with the mapping to actual code later
@@ -85,10 +184,105 @@
 ; - :number
 ; - :agentset
 ; - :command-block
+; - :boolean
 ; - 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))
+(defprim :color ())
+(defprim :count ())
+(defprim :die ())
+(defprim :display ())
+(defprim :with (:reporter-block))
 (defprim :fd (:number))
+(defprim :hatch (:number :command-block))
+(defprim :let (t t))
+(defprim :if (:boolean :command-block))
+(defprim :ifelse (:boolean :command-block :command-block))
+(defprim :label ())
+(defprim :label-color ())
+(defprim :not (:boolean))
+(defprim :nobody ())
+(defprim :one-of (t))
+(defprim :patches ())
+(defprim :pcolor ())
+(defprim :random (:number))
 (defprim :random-float (:number))
+(defprim :random-xcor ())
+(defprim :random-ycor ())
+(defprim :round ())
+(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 :turtles ())
+
+; colors
+(defprim :black ())
+(defprim :blue ())
+(defprim :brown ())
+(defprim :green ())
+(defprim :white ())
+
+(defstructureprim :globals)
+(defstructureprim :breed)
+(defstructureprim :turtles-own)
+(defstructureprim :patches-own)
+(defstructureprim :to)
+(defstructureprim :to-report)
+
+; Placeholder prims that should be populated in dynamic prims
+
+; Generated by globals/widgets
+(defprim :grass ())
+(defprim :initial-number-sheep ())
+(defprim :initial-number-wolves ())
+(defprim :sheep-gain-from-food ())
+(defprim :wolf-gain-from-food ())
+(defprim :sheep-reproduce ())
+(defprim :wolf-reproduce ())
+(defprim :grass? ())
+(defprim :grass-regrowth-time ())
+(defprim :show-energy? ())
+
+; Generated by procedures
+(defprim :move ())
+(defprim :eat-grass ())
+(defprim :reproduce-sheep ())
+(defprim :reproduce-wolves ())
+(defprim :catch-sheep ())
+(defprim :death ())
+(defprim :grow-grass ())
+(defprim :display-labels ())
+
+; Generated by *-own
+(defprim :countdown ())
+(defprim :energy ())
+
+; Generated by a let
+(defprim :prey ())
+
+; Generated by breeds
+(defprim :sheep ())
+(defprim :wolves ())
+(defprim :create-sheep (:number :command-block))   ; look at me not have to do optionals yet
+(defprim :sheep-here ())
+(defprim :create-wolves (:number :command-block))