X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fcode-parse.lisp;h=d1b30ee7ff93a78f7ff2643385b2a9d839ed5aa9;hb=d5b1d2277655b8771cc22aba7828e0b373b7d024;hp=69806ca529a71c1c0b68c0454c4be8249a108af4;hpb=72d7364634aec6c24803deb29bdfde0fbfa6e7ad;p=clnl

diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp
index 69806ca..d1b30ee 100644
--- a/src/main/code-parse.lisp
+++ b/src/main/code-parse.lisp
@@ -6,28 +6,76 @@
 ; 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 :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
+
+(defun breed->prims (breed-list)
+ (let
+  ((plural-name (symbol-name (car breed-list))))
+  (list
+   (list :name (car breed-list))
+   (list :name (intern (format nil "~A-HERE" plural-name) :keyword))
+   (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block)))))
+
+(defun parse (lexed-ast &optional external-globals)
+ "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
 
 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
+  PRIMS: Primitives that can be sent to the parser and transpiler
 
 DESCRIPTION:
 
   PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
+  It also returns the primitives that are defined in the code file, including
+  ones generated from the EXTERNAL-GLOBALS, that can then be passed to both
+  the parser and the transpiler.
+
+  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."
+ (let*
+  ((*dynamic-prims*
+    (append
+     (mapcar #'global->prim external-globals)
+     (procedures->prims lexed-ast)))
+   (parsed (parse-internal lexed-ast)))
+  (values
+   (butlast parsed)
+   (car (last parsed)))))
+
+(defun procedures->prims (lexed-ast)
  (cond
   ((not lexed-ast) nil)
+  ; We'll need argument handling here sometime :)
+  ((eql :to (car lexed-ast))
+   (cons
+    (list
+     :name (cadr lexed-ast)
+     :type :command
+     :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*)))
+    (procedures->prims (cddr lexed-ast))))
+  (t (procedures->prims (cdr lexed-ast)))))
+
+(defun parse-internal (lexed-ast)
+ (cond
+  ((not lexed-ast)
+   (list *dynamic-prims*))
   ((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)
@@ -36,8 +84,8 @@ DESCRIPTION:
    (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
@@ -49,12 +97,22 @@ 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)
- (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))
-   (parse after-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))
+   (let
+    ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
+    (parse-internal after-list)))))
 
 (defun find-closing-bracket (tokens)
  (cond
@@ -72,11 +130,32 @@ DESCRIPTION:
 ARGUMENTS AND VALUES:
 
   MODEL: An ast as created by clnl-code-parse:parse
-  GLOBAL: A symbol interned in clnl:*model-package*
+  GLOBAL: A symbol interned in :keyword
 
 DESCRIPTION:
 
   Returns the globals that get declared in the code."
  (mapcar
-  (lambda (global) (list (symbol-name global) 0d0))
+  (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
   (cdr (second (find :globals code-parsed-ast :key #'car)))))
+
+(defun procedures (code-parsed-ast)
+ "PROCEDURES MODEL => PROCEDURES
+
+  PROCEDURES: PROCEDURE*
+  PROCEDURE: (NAME BODY)
+
+ARGUMENTS AND VALUES:
+
+  MODEL: An ast as created by clnl-code-parse:parse
+  NAME: A symbol interned in :keyword
+  BODY: A list of lexed forms
+
+DESCRIPTION:
+
+  Returns the procedures that were defined in the code.  These can
+  then be translated into common lisp by using mapcar on the BODY, and
+  set to some function defined by NAME"
+ (mapcar
+  (lambda (proc) (cdr proc))
+  (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))