1 (in-package #:clnl-code-parser)
3 ; This is different from the general parser (in clnl-parser) in that
4 ; it's made for parsing the code section of nlogo files, and so works
5 ; outside of the constraints. In NetLogo, I believe this is analagous
6 ; to the StructureParser, but I'm guessing there's weird overlap with
9 (defvar *dynamic-prims* nil)
11 (defun global->prim (global)
12 (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
14 (defun own->prim (symb)
15 (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb))))
17 (defun breed->prims (breed-list)
19 ((plural-name (symbol-name (car breed-list))))
21 (list :name (car breed-list))
22 (list :name (intern (format nil "~A-HERE" plural-name) :keyword))
23 (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block)))))
25 (defun parse (lexed-ast &optional external-globals)
26 "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
30 LEXED-AST: An ambigious ast
31 EXTERNAL-GLOBALS: A list of symbols in keyword package
32 AST: An unambigious ast that represents the code block of a model
33 PRIMS: Primitives that can be sent to the parser and transpiler
37 PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
38 It also returns the primitives that are defined in the code file, including
39 ones generated from the EXTERNAL-GLOBALS, that can then be passed to both
40 the parser and the transpiler.
42 EXTERNAL-GLOBALS is a list of symbols representing global variables that
43 are not defined within the code. Normally these come from widgets defined
44 in the model file, but could arguably come from elsewhere.
46 This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
48 Rather, the ast that's returned can be queried with other functions included
49 in the CLNL-CODE-PARSER package to tease out necessary information. Some of
50 those things will involve code blocks that can then be transpiled."
54 (mapcar #'global->prim external-globals)
55 (procedures->prims lexed-ast)))
56 (parsed (parse-internal lexed-ast)))
59 (car (last parsed)))))
61 (defun procedures->prims (lexed-ast)
64 ; We'll need argument handling here sometime :)
65 ((eql :to (car lexed-ast))
68 :name (cadr lexed-ast)
70 :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*)))
71 (procedures->prims (cddr lexed-ast))))
72 (t (procedures->prims (cdr lexed-ast)))))
74 (defun parse-internal (lexed-ast)
77 (list *dynamic-prims*))
78 ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
79 ((find (car lexed-ast) '(:globals :turtles-own :patches-own))
80 (parse-with-unevaluated-list lexed-ast))
81 ((eql (car lexed-ast) :breed) (parse-breed lexed-ast))))
83 ; Due to the non expression style syntax of procedures, this must be special cased
84 (defun parse-procedure (tokens)
85 (multiple-value-bind (in-block after-block) (find-end tokens)
90 (clnl-parser:parse (cddr in-block) *dynamic-prims*))
91 (parse-internal after-block))))
93 (defun find-end (tokens)
95 ((not tokens) (error "Failed to find end"))
96 ((eql :end (car tokens)) (values nil (cdr tokens)))
97 (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens))
98 (values (cons (car tokens) in-block) after-block)))))
100 ; This is a special case but left with a little wiggle room for future
101 ; enhancements, like code blocks
102 (defun parse-with-unevaluated-list (lexed-ast)
103 (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
104 (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
106 (list (car lexed-ast) (cons :list-literal in-list))
111 (case (car lexed-ast)
112 (:globals #'global->prim)
113 (:turtles-own #'own->prim)
114 (:patches-own #'own->prim)
116 in-list) *dynamic-prims*)))
117 (parse-internal after-list)))))
119 (defun parse-breed (lexed-ast)
120 (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
121 (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
123 (list (car lexed-ast) (cons :list-literal in-list))
125 ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
126 (parse-internal after-list)))))
128 (defun find-closing-bracket (tokens)
130 ((not tokens) (error "Failed to find a matching closing bracket"))
131 ((eql :] (car tokens)) (values nil (cdr tokens)))
132 ((eql :[ (car tokens)) (error "Expected name or ]"))
133 (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
134 (values (cons (car tokens) in-block) after-block)))))
136 (defun globals (code-parsed-ast)
137 "GLOBALS CODE-PARSED-AST => GLOBALS
141 ARGUMENTS AND VALUES:
143 CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
144 GLOBAL: A symbol interned in :keyword
148 Returns the globals that get declared in the code."
150 (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
151 (cdr (second (find :globals code-parsed-ast :key #'car)))))
153 (defun turtles-own-vars (code-parsed-ast)
154 "TURTLES-OWN-VARS CODE-PARSED-AST => TURTLES-OWN-VARS
156 TURTLES-OWN-VARS: TURTLES-OWN-VAR*
158 ARGUMENTS AND VALUES:
160 CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
161 TURTLES-OWN-VAR: A symbol interned in :keyword
165 Returns the turtles own variables that get declared in the code."
167 (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword))
168 (cdr (second (find :turtles-own code-parsed-ast :key #'car)))))
170 (defun patches-own-vars (code-parsed-ast)
171 "PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS
173 PATCHES-OWN-VARS: PATCHES-OWN-VAR*
175 ARGUMENTS AND VALUES:
177 CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
178 PATCHES-OWN-VAR: A symbol interned in :keyword
182 Returns the turtles own variables that get declared in the code."
184 (lambda (patches-own-var) (intern (symbol-name patches-own-var) :keyword))
185 (cdr (second (find :patches-own code-parsed-ast :key #'car)))))
187 (defun procedures (code-parsed-ast)
188 "PROCEDURES CODE-PARSED-AST => PROCEDURES
190 PROCEDURES: PROCEDURE*
191 PROCEDURE: (NAME BODY)
193 ARGUMENTS AND VALUES:
195 CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
196 NAME: A symbol interned in :keyword
197 BODY: A list of lexed forms
201 Returns the procedures that were defined in the code. These can
202 then be translated into common lisp by using mapcar on the BODY, and
203 set to some function defined by NAME"
205 (lambda (proc) (cdr proc))
206 (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))