--- /dev/null
+(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)))))
; 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-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 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
- STRUCTURE: A boolean
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.
- 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
(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)
((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))))
- (when (and (not *in-structure*) (prim-in-structure prim))
+ (when (prim-structure-prim prim)
(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))))
-; 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))))
(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 defstructureprim (name args)
+(defmacro defstructureprim (name)
`(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
(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)
projects / clnl / commitdiff