From: Frank Duncan Date: Sun, 8 May 2016 20:36:35 +0000 (-0500) Subject: Code - procedures X-Git-Tag: v0.1.0~18 X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=commitdiff_plain;h=d5b1d2277655b8771cc22aba7828e0b373b7d024;p=clnl Code - procedures --- diff --git a/src/main/base.lisp b/src/main/base.lisp index f90c77f..667285c 100644 --- a/src/main/base.lisp +++ b/src/main/base.lisp @@ -1,6 +1,6 @@ (in-package #:clnl) -(defvar *model-package* (find-package :cl-user) +(defvar *model-package* (find-package :clnl-default-model-package) "*MODEL-PACKAGE* VALUE TYPE: @@ -9,13 +9,18 @@ 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 diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index e9b4d77..d1b30ee 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -53,18 +53,25 @@ DESCRIPTION: (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)) @@ -131,3 +138,24 @@ DESCRIPTION: (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))) diff --git a/src/main/main.lisp b/src/main/main.lisp index f20062b..9862515 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -92,26 +92,44 @@ DESCRIPTION: (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 @@ -154,6 +172,18 @@ DESCRIPTION: (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 diff --git a/src/main/package.lisp b/src/main/package.lisp index f3aef8a..675a70b 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -19,7 +19,7 @@ into an ast that can be transpiled later.")) (defpackage #:clnl-code-parser (:use :common-lisp) - (:export #:parse #:globals) + (:export #:parse #:globals #:procedures) (:documentation "CLNL Code Parser @@ -139,3 +139,7 @@ The representation, parsing, and serializing of NetLogo model files, including all of the sections, and subsections held within. This package houses not only the code to read and write .nlogo files, but also the living state of the model as clnl runs.")) + +(defpackage #:clnl-default-model-package + (:use :common-lisp) + (:shadow #:go)) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 0ec8d01..071aa09 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -11,3 +11,28 @@ "a" "5" "F8507A0D88D681CCBF01898FEA263791F9DDCE63") + +(defmodelcommandtest "to 1" + "globals [a] +to setup + set a 2 +end + +to go + crt a +end" + "setup go go" + "1A20E368DD101521791FB5D7C8461C1ED12EAE7A") + +(defmodelcommandtest "to 2" + "globals [a] +to setup + set a 2 +end + +to go + setup + crt a +end" + "go" + "46C620AB8995266C4A2094C461BE197BBACEB8C3")