Code - globals

diff --git a/src/main/clnl.asd b/src/main/clnl.asd
index d03aee3578a314ae24349540c1f575e54c688c5a..476728e923b9ae6988bb9dcddb921d462e750348 100644 (file)
--- a/src/main/clnl.asd
+++ b/src/main/clnl.asd
@@ -7,6 +7,7 @@
               (:file "model")
               (:file "lex")
               (:file "parse")
               (:file "model")
               (:file "lex")
               (:file "parse")

+              (:file "code-parse")

               (:file "nvm/base")
               (:file "nvm/utils")
               (:file "nvm/nvm")
               (:file "nvm/base")
               (:file "nvm/utils")
               (:file "nvm/nvm")

diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp
new file mode 100644 (file)
index 0000000..182e4af
--- /dev/null
+++ b/src/main/code-parse.lisp
@@ -0,0 +1,79 @@
+(in-package #:clnl-code-parser)
+
+; This is different from the general parser (in clnl-parser) in that
+; it's made for parsing the code section of nlogo files, and so works
+; outside of the constraints.  In NetLogo, I believe this is analagous
+; to the StructureParser, but I'm guessing there's weird overlap with
+; other things
+
+(defun parse (lexed-ast)
+ "PARSE LEXED-AST => AST
+
+ARGUMENTS AND VALUES:
+
+  LEXED-AST: An ambigious ast
+  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.
+
+  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."
+ (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))))
+
+; Due to the non expression style syntax of procedures, this must be special cased
+(defun parse-procedure (tokens)
+ (multiple-value-bind (in-block after-block) (find-end tokens)
+  (cons
+   in-block
+   (parse after-block))))
+
+(defun find-end (tokens)
+ (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))
+      (values (cons (car tokens) in-block) after-block)))))
+
+; 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"))
+ (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))))
+
+(defun find-closing-bracket (tokens)
+ (cond
+  ((not tokens) (error "Failed to find a matching closing bracket"))
+  ((eql :] (car tokens)) (values nil (cdr tokens)))
+  ((eql :[ (car tokens)) (error "Expected name or ]"))
+  (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
+      (values (cons (car tokens) in-block) after-block)))))
+
+(defun globals (code-parsed-ast)
+ "GLOBALS MODEL => GLOBALS
+
+  GLOBALS: GLOBAL*
+
+ARGUMENTS AND VALUES:
+
+  MODEL: An ast as created by clnl-code-parse:parse
+  GLOBAL: A symbol interned in clnl:*model-package*
+
+DESCRIPTION:
+
+  Returns the globals that get declared in the code."
+ (mapcar
+  (lambda (global) (list (symbol-name global) 0d0))
+  (cdr (second (find :globals code-parsed-ast :key #'car)))))

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 83179a0bb4f2e6abaae54724c1287af73e5eeaa9..a9de7be5081ac10b86555cc321f9c020ec8037d8 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -54,7 +54,7 @@ DESCRIPTION:
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model

-   :code (nth 0 sections)
+   :code (format nil "~{~A~^~%~}" (nth 0 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)


@@ -222,6 +222,10 @@ DESCRIPTION:
    :ymin (view-min-pycor view)
    :ymax (view-max-pycor view))))
 
    :ymin (view-min-pycor view)
    :ymax (view-max-pycor view))))
 

+(defun parse-code (model)
+ (clnl-code-parser:parse (clnl-lexer:lex (model-code model))))
+
+; For now, we keep the code hidden in this package

 (defun globals (model)
  "GLOBALS MODEL => GLOBALS
 
 (defun globals (model)
  "GLOBALS MODEL => GLOBALS
 


@@ -242,10 +246,12 @@ DESCRIPTION:
    (list
     (intern (string-upcase (car pair)) clnl:*model-package*)
     (cadr pair)))
    (list
     (intern (string-upcase (car pair)) clnl:*model-package*)
     (cadr pair)))

-  (remove nil
-   (mapcar
-    (lambda (widget)
-     (typecase widget
-      (slider (list (slider-varname widget) (slider-default widget)))
-      (switch (list (switch-varname widget) (switch-on widget)))))
-    (model-interface model)))))
+  (append
+   (clnl-code-parser:globals (parse-code model))
+   (remove nil
+    (mapcar
+     (lambda (widget)
+      (typecase widget
+       (slider (list (slider-varname widget) (slider-default widget)))
+       (switch (list (switch-varname widget) (switch-on widget)))))
+     (model-interface model))))))

diff --git a/src/main/package.lisp b/src/main/package.lisp
index 3998b00c27dc78a8b8102b93acb069ecc0bb7714..b115db657939ff95c143c3cd87a7b91b04b168a0 100644 (file)
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -15,6 +15,21 @@ the place that ties all the parts together into a cohesive whole."))
 All the code to convert the list of tokens coming from the lexer
 into an ast that can be transpiled later."))
 
 All the code to convert the list of tokens coming from the lexer
 into an ast that can be transpiled later."))
 

+(defpackage #:clnl-code-parser
+ (:use :common-lisp)
+ (:export #:parse #:globals)
+ (:documentation
+  "CLNL Code Parser
+
+A parser specifically for code from NetLogo models, that turns the lexed
+ast from an entire structured file into something more defined.
+
+This is different from the general parser (in clnl-parser) in that
+it's made for parsing the code section of nlogo files, and so works
+outside of the constraints.  In NetLogo, I believe this is analagous
+to the StructureParser, but I'm guessing there's weird overlap with
+other things."))
+

 (defpackage #:clnl-random
  (:use :common-lisp)
  (:shadow #:export)
 (defpackage #:clnl-random
  (:use :common-lisp)
  (:shadow #:export)

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index ae618d283027f336c6f5c7dbcd277168289be7c4..97588bb085d1ef9df51ad59aab4ab1a0f00165b4 100644 (file)
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -24,32 +24,34 @@
 ; prims that are created when compiling the netlogo file
 ; usually via procedures or top level things like breed declarations
 (defparameter *dynamic-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)

-(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-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 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 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 &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*

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

-  STRUCTURE: A boolean

   AST: An unambigious ast that can be transpiled
   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.
 
 
 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 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
 
   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,7 +65,7 @@ DESCRIPTION:
  (let
   ; could have defined this using the special variable, but didn't to make the
   ; function definition simpler, as well as the documentation.
  (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))
+  ((*dynamic-prims* dynamic-prims))

   (parse-internal lexed-ast)))
 
 (defun parse-internal (lexed-ast)
   (parse-internal lexed-ast)))
 
 (defun parse-internal (lexed-ast)


@@ -71,29 +73,15 @@ DESCRIPTION:
   ((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)))
   ((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))))
   ((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))
+    (when (prim-structure-prim prim)

      (error "This doesn't make sense here"))
      (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))))
+    (parse-prim prim lexed-ast)))

   (t (error "Couldn't parse ~S" 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)
+(defun parse-prim (prim lexed-ast)

  (let
   ((num-args (prim-num-args prim))
    (parsed-remainder (parse-internal (cdr lexed-ast))))
  (let
   ((num-args (prim-num-args prim))
    (parsed-remainder (parse-internal (cdr lexed-ast))))


@@ -135,36 +123,14 @@ DESCRIPTION:
       (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
       (values (cons (car tokens) in-block) after-block)))))
 
       (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)
- (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))
-      (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)
  `(push
    (list :name ,name :args ',args)
    *prims*))
 
 (defmacro defprim (name args)
  `(push
    (list :name ,name :args ',args)
    *prims*))
 

-(defmacro defstructureprim (name args)
+(defmacro defstructureprim (name)

  `(push
  `(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
    *prims*))
 
 ; This list of prims will get combined with the mapping to actual code later


@@ -180,7 +146,9 @@ DESCRIPTION:
 (defprim :show (t))
 (defprim :turtles ())
 
 (defprim :show (t))
 (defprim :turtles ())
 

-(defstructureprim :globals (:unevaluated-list))
-(defstructureprim :breed (:unevaluated-list))
-(defstructureprim :turtles-own (:unevaluated-list))
-(defstructureprim :patches-own (:unevaluated-list))
+(defstructureprim :globals)
+(defstructureprim :breed)
+(defstructureprim :turtles-own)
+(defstructureprim :patches-own)
+(defstructureprim :to)
+(defstructureprim :to-report)