(in-package #:clnl)
-(defvar *model-package* (find-package :cl-user)
+(defvar *model-package* (find-package :clnl-default-model-package)
"*MODEL-PACKAGE*
VALUE TYPE:
INITIAL VALUE:
- The common-lisp-user package
+ The package named by :clnl-default-model-package
DESCRIPTION:
*MODEL-PACKAGE* is used for interning symbols as a NetLogo code
gets compiled.
+ :clnl-default-model-package is used because it's set up to shadow
+ common overlaps between the :cl package and netlogo programs, most
+ notably GO. When you set this to a package of your choosing, be
+ aware of those overlaps in the case that use :use :common-lisp
+
Any local symbols are interned in this package, for use either
by other code, or in order to have all symbols interned in the
same placakge. This is also the package in which a model should
(parsed (parse-internal lexed-ast)))
(values
(butlast parsed)
- (last 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)) (procedures->prims (cdr lexed-ast))))
+ ((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) *dynamic-prims*)
+ ((not lexed-ast)
+ (list *dynamic-prims*))
((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
((find (car lexed-ast) '(:globals :turtles-own :patches-own))
(parse-with-unevaluated-list lexed-ast))
(mapcar
(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)))
(append
(clnl-model:widget-globals model)
(clnl-code-parser:globals code-ast))))
- `(let
- ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
+ `(prog ()
+ ; First declare is in case we don't use it, it shows up in export correctly
(declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
- (clnl-random:set-seed ,seed)
- (clnl-nvm:create-world
- :dims ',(clnl-model:world-dimensions model)
- :globals (list
- ,@(mapcar
- (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
- globals)))
- ,@(when netlogo-callback
- `((funcall ,netlogo-callback
- (lambda (netlogo-code)
- (eval
- (clnl-transpiler:transpile
- (clnl-parser:parse
- (clnl-lexer:lex netlogo-code)
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))
- ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))
+ (let
+ ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
+ ; We declare twice rather than once and doing a bunch of setfs
+ (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
+ (labels
+ ,(mapcar
+ (lambda (proc)
+ `(,(intern (string-upcase (car proc)) *model-package*) ()
+ ,@(cdr ; remove the progn, cuz it looks nicer
+ (clnl-transpiler:transpile (cadr proc)
+ (mapcar
+ (lambda (prim)
+ (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
+ ; this scope while preserving them for the generational purposes below
+ (append (list :macro (eval (getf prim :macro))) prim)
+ prim)) prims)))))
+ (clnl-code-parser:procedures code-ast))
+ (clnl-random:set-seed ,seed)
+ (clnl-nvm:create-world
+ :dims ',(clnl-model:world-dimensions model)
+ :globals (list
+ ,@(mapcar
+ (lambda (pair)
+ `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
+ globals)))
+ ,@(when netlogo-callback
+ `((funcall ,netlogo-callback
+ (lambda (netlogo-code)
+ (eval
+ (clnl-transpiler:transpile
+ (clnl-parser:parse
+ (clnl-lexer:lex netlogo-code)
+ (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
+ (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))
+ ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))))
(setf (documentation 'model->single-form-lisp 'function)
"MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
(lambda (pair)
`(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
globals)
+ ,@(mapcar
+ (lambda (proc)
+ `(defun ,(intern (string-upcase (car proc)) *model-package*) ()
+ ,@(cdr ; remove the progn, cuz it looks nicer
+ (clnl-transpiler:transpile (cadr proc)
+ (mapcar
+ (lambda (prim)
+ (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
+ ; this scope while preserving them for the generational purposes below
+ (append (list :macro (eval (getf prim :macro))) prim)
+ prim)) prims)))))
+ (clnl-code-parser:procedures code-ast))
(defun ,boot-fn ()
(clnl-random:set-seed ,seed)
(clnl-nvm:create-world
projects / clnl / commitdiff