Improve parser - generate prims from globals

diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp
index 69806ca529a71c1c0b68c0454c4be8249a108af4..7cdf2b5b1864ff53ea9483a18464e2b906cc56c4 100644 (file)
--- a/src/main/code-parse.lisp
+++ b/src/main/code-parse.lisp
@@ -6,28 +6,42 @@
 ; to the StructureParser, but I'm guessing there's weird overlap with
 ; other things
 
 ; to the StructureParser, but I'm guessing there's weird overlap with
 ; other things
 

-(defun parse (lexed-ast)
- "PARSE LEXED-AST => AST
+(defvar *dynamic-prims* nil)
+(defun global->prim (global) (list :name global))
+
+(defun parse (lexed-ast &optional external-globals)
+ "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST

 
 ARGUMENTS AND VALUES:
 
   LEXED-AST: An ambigious ast
 
 ARGUMENTS AND VALUES:
 
   LEXED-AST: An ambigious ast

+  EXTERNAL-GLOBALS: A list of symbols in keyword package

   AST: An unambigious ast that represents the code block of a model
 
 DESCRIPTION:
 
   PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
 
   AST: An unambigious ast that represents the code block of a model
 
 DESCRIPTION:
 
   PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
 

+  EXTERNAL-GLOBALS is a list of symbols representing global variables that
+  are not defined within the code.  Normally these come from widgets defined
+  in the model file, but could arguably come from elsewhere.
+

   This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
 
   Rather, the ast that's returned can be queried with other functions included
   in the CLNL-CODE-PARSER package to tease out necessary information.  Some of
   those things will involve code blocks that can then be transpiled."
   This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
 
   Rather, the ast that's returned can be queried with other functions included
   in the CLNL-CODE-PARSER package to tease out necessary information.  Some of
   those things will involve code blocks that can then be transpiled."

+ (let
+  ((*dynamic-prims* (mapcar #'global->prim external-globals)))
+  (parse-internal lexed-ast)))
+
+(defun parse-internal (lexed-ast)

  (cond
   ((not lexed-ast) nil)
   ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
  (cond
   ((not lexed-ast) nil)
   ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))

-  ((find (car lexed-ast) '(:breed :globals :turtles-own :patches-own))
-   (parse-with-unevaluated-list lexed-ast))))
+  ((find (car lexed-ast) '(:globals :turtles-own :patches-own))
+   (parse-with-unevaluated-list lexed-ast))
+  ((eql (car lexed-ast) :breed) (parse-breed lexed-ast))))

 
 ; Due to the non expression style syntax of procedures, this must be special cased
 (defun parse-procedure (tokens)
 
 ; Due to the non expression style syntax of procedures, this must be special cased
 (defun parse-procedure (tokens)


@@ -36,8 +50,8 @@ DESCRIPTION:
    (list
     (first in-block)
     (second in-block)
    (list
     (first in-block)
     (second in-block)

-    (clnl-parser:parse (cddr in-block)))
-   (parse after-block))))
+    (clnl-parser:parse (cddr in-block) *dynamic-prims*))
+   (parse-internal after-block))))

 
 (defun find-end (tokens)
  (cond
 
 (defun find-end (tokens)
  (cond


@@ -49,12 +63,20 @@ DESCRIPTION:
 ; This is a special case but left with a little wiggle room for future
 ; enhancements, like code blocks
 (defun parse-with-unevaluated-list (lexed-ast)
 ; This is a special case but left with a little wiggle room for future
 ; enhancements, like code blocks
 (defun parse-with-unevaluated-list (lexed-ast)

- (when (not (eql :[ (cadr lexed-ast)))
-  (error "Expected list literal here"))
+ (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 (car lexed-ast) (cons :list-literal in-list))
+   (let
+    ((*dynamic-prims* (append (mapcar #'global->prim in-list) *dynamic-prims*)))
+    (parse-internal after-list)))))
+
+(defun parse-breed (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 (car lexed-ast) (cons :list-literal in-list))
  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
   (cons
    (list (car lexed-ast) (cons :list-literal in-list))

-   (parse after-list))))
+   (parse-internal after-list))))

 
 (defun find-closing-bracket (tokens)
  (cond
 
 (defun find-closing-bracket (tokens)
  (cond

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 1927ff5847f9740e8d393c6da4642dab87e0189e..33f90aa588327b040c5b87a02b1f85efb21223b5 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -54,7 +54,15 @@ DESCRIPTION:
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model

-   :code (clnl-code-parser:parse (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections))))
+   :code (clnl-code-parser:parse
+          (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections)))
+          (remove nil
+           (mapcar
+            (lambda (widget)
+             (typecase widget
+              (slider (intern (string-upcase (slider-varname widget)) (find-package :keyword)))
+              (switch (intern (string-upcase (switch-varname widget)) (find-package :keyword)))))
+            (parse-interface (nth 1 sections)))))

    :interface (parse-interface (nth 1 sections))
    :info (nth 2 sections)
    :turtle-shapes (nth 3 sections)
    :interface (parse-interface (nth 1 sections))
    :info (nth 2 sections)
    :turtle-shapes (nth 3 sections)

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index eaaa3fe1d5fdf70c82d43c77431caacfaf5e7dea..c4270190c3c10654f7d517d86442833969c0ebc8 100644 (file)
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -31,7 +31,10 @@
 (defun prim-structure-prim (prim) (getf prim :structure-prim))
 (defun prim-is-infix (prim) (getf prim :infix))
 
 (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
 
 ; Make this only as complicated as it needs to be, letting it grow
 ; as we take on more and more of the language


@@ -39,12 +42,16 @@
  "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
 
   DYNAMIC-PRIMS: DYNAMIC-PRIM*
  "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
   AST: An unambigious ast that can be transpiled
 
 ARGUMENTS AND VALUES:
 
   LEXED-AST: An ambigious ast
   AST: An unambigious ast that can be transpiled

-  DYNAMIC-PRIM: A prim not statically defined
+  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:
 
 
 DESCRIPTION:
 


@@ -54,6 +61,9 @@ DESCRIPTION:
   things not statically defined by the NetLogo language, be they user defined
   procedures or generated primitives from breed declarations.
 
   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
   point into this module, and should probably remain that way.
   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.


@@ -210,6 +220,7 @@ DESCRIPTION:
 (defprim :hatch (:number :command-block))
 (defprim :let (t t))
 (defprim :if (:boolean :command-block))
 (defprim :hatch (:number :command-block))
 (defprim :let (t t))
 (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 :ifelse (:boolean :command-block :command-block))
 (defprim :label ())
 (defprim :label-color ())


@@ -251,18 +262,6 @@ DESCRIPTION:
 
 ; Placeholder prims that should be populated in dynamic prims
 
 
 ; 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 ())
 ; Generated by procedures
 (defprim :move ())
 (defprim :eat-grass ())


@@ -273,10 +272,6 @@ DESCRIPTION:
 (defprim :grow-grass ())
 (defprim :display-labels ())
 
 (defprim :grow-grass ())
 (defprim :display-labels ())
 

-; Generated by *-own
-(defprim :countdown ())
-(defprim :energy ())
-

 ; Generated by a let
 (defprim :prey ())
 
 ; Generated by a let
 (defprim :prey ())