From: Frank Duncan Date: Fri, 22 Apr 2016 21:24:47 +0000 (-0500) Subject: Code - globals X-Git-Tag: v0.1.0~55 X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=commitdiff_plain;h=3abea7023574532423fa24d5f97154db474b50a0;p=clnl Code - globals --- diff --git a/src/main/clnl.asd b/src/main/clnl.asd index d03aee3..476728e 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -7,6 +7,7 @@ (:file "model") (:file "lex") (:file "parse") + (:file "code-parse") (:file "nvm/base") (:file "nvm/utils") (:file "nvm/nvm") diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp new file mode 100644 index 0000000..182e4af --- /dev/null +++ b/src/main/code-parse.lisp @@ -0,0 +1,79 @@ +(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))))) diff --git a/src/main/model.lisp b/src/main/model.lisp index 83179a0..a9de7be 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -54,7 +54,7 @@ DESCRIPTION: (read-sections (append section (list line)))))))) (read-sections)))) (make-model - :code (nth 0 sections) + :code (format nil "~{~A~^~%~}" (nth 0 sections)) :interface (parse-interface (nth 1 sections)) :info (nth 2 sections) :turtle-shapes (nth 3 sections) @@ -222,6 +222,10 @@ DESCRIPTION: :ymin (view-min-pycor view) :ymax (view-max-pycor view)))) +(defun parse-code (model) + (clnl-code-parser:parse (clnl-lexer:lex (model-code model)))) + +; For now, we keep the code hidden in this package (defun globals (model) "GLOBALS MODEL => GLOBALS @@ -242,10 +246,12 @@ DESCRIPTION: (list (intern (string-upcase (car pair)) clnl:*model-package*) (cadr pair))) - (remove nil - (mapcar - (lambda (widget) - (typecase widget - (slider (list (slider-varname widget) (slider-default widget))) - (switch (list (switch-varname widget) (switch-on widget))))) - (model-interface model))))) + (append + (clnl-code-parser:globals (parse-code model)) + (remove nil + (mapcar + (lambda (widget) + (typecase widget + (slider (list (slider-varname widget) (slider-default widget))) + (switch (list (switch-varname widget) (switch-on widget))))) + (model-interface model)))))) diff --git a/src/main/package.lisp b/src/main/package.lisp index 3998b00..b115db6 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -15,6 +15,21 @@ the place that ties all the parts together into a cohesive whole.")) All the code to convert the list of tokens coming from the lexer into an ast that can be transpiled later.")) +(defpackage #:clnl-code-parser + (:use :common-lisp) + (:export #:parse #:globals) + (:documentation + "CLNL Code Parser + +A parser specifically for code from NetLogo models, that turns the lexed +ast from an entire structured file into something more defined. + +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.")) + (defpackage #:clnl-random (:use :common-lisp) (:shadow #:export) diff --git a/src/main/parse.lisp b/src/main/parse.lisp index ae618d2..97588bb 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -24,32 +24,34 @@ ; 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 @@ -63,7 +65,7 @@ DESCRIPTION: (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) @@ -71,29 +73,15 @@ DESCRIPTION: ((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)))) @@ -135,36 +123,14 @@ DESCRIPTION: (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 @@ -180,7 +146,9 @@ DESCRIPTION: (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)