code.consxy.com Git - clnl/blob - src/main/code-parse.lisp

   1 (in-package #:clnl-code-parser)
   2
   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
   7 ; other things
   8
   9 (defvar *dynamic-prims* nil)
  10
  11 (defun global->prim (global)
  12  (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
  13
  14 (defun turtles-own->prim (symb)
  15  (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb))))
  16
  17 (defun breed->prims (breed-list)
  18  (let
  19   ((plural-name (symbol-name (car breed-list))))
  20   (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)))))
  24
  25 (defun parse (lexed-ast &optional external-globals)
  26  "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
  27
  28 ARGUMENTS AND VALUES:
  29
  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
  34
  35 DESCRIPTION:
  36
  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.
  41
  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.
  45
  46   This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
  47
  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."
  51  (let*
  52   ((*dynamic-prims*
  53     (append
  54      (mapcar #'global->prim external-globals)
  55      (procedures->prims lexed-ast)))
  56    (parsed (parse-internal lexed-ast)))
  57   (values
  58    (butlast parsed)
  59    (car (last parsed)))))
  60
  61 (defun procedures->prims (lexed-ast)
  62  (cond
  63   ((not lexed-ast) nil)
  64   ; We'll need argument handling here sometime :)
  65   ((eql :to (car lexed-ast))
  66    (cons
  67     (list
  68      :name (cadr lexed-ast)
  69      :type :command
  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)))))
  73
  74 (defun parse-internal (lexed-ast)
  75  (cond
  76   ((not 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))))
  82
  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)
  86   (cons
  87    (list
  88     (first in-block)
  89     (second in-block)
  90     (clnl-parser:parse (cddr in-block) *dynamic-prims*))
  91    (parse-internal after-block))))
  92
  93 (defun find-end (tokens)
  94  (cond
  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)))))
  99
 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))
 105   (cons
 106    (list (car lexed-ast) (cons :list-literal in-list))
 107    (let
 108     ((*dynamic-prims*
 109       (append
 110        (mapcar
 111         (case (car lexed-ast)
 112          (:globals #'global->prim)
 113          (:turtles-own #'turtles-own->prim)
 114          (t #'global->prim))
 115         in-list) *dynamic-prims*)))
 116     (parse-internal after-list)))))
 117
 118 (defun parse-breed (lexed-ast)
 119  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
 120  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
 121   (cons
 122    (list (car lexed-ast) (cons :list-literal in-list))
 123    (let
 124     ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
 125     (parse-internal after-list)))))
 126
 127 (defun find-closing-bracket (tokens)
 128  (cond
 129   ((not tokens) (error "Failed to find a matching closing bracket"))
 130   ((eql :] (car tokens)) (values nil (cdr tokens)))
 131   ((eql :[ (car tokens)) (error "Expected name or ]"))
 132   (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
 133       (values (cons (car tokens) in-block) after-block)))))
 134
 135 (defun globals (code-parsed-ast)
 136  "GLOBALS CODE-PARSED-AST => GLOBALS
 137
 138   GLOBALS: GLOBAL*
 139
 140 ARGUMENTS AND VALUES:
 141
 142   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 143   GLOBAL: A symbol interned in :keyword
 144
 145 DESCRIPTION:
 146
 147   Returns the globals that get declared in the code."
 148  (mapcar
 149   (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
 150   (cdr (second (find :globals code-parsed-ast :key #'car)))))
 151
 152 (defun turtles-own-vars (code-parsed-ast)
 153  "TURTLES-OWN-VARS CODE-PARSED-AST => TURTLES-OWN-VARS
 154
 155   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
 156
 157 ARGUMENTS AND VALUES:
 158
 159   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 160   TURTLES-OWN-VAR: A symbol interned in :keyword
 161
 162 DESCRIPTION:
 163
 164   Returns the turtles own variables that get declared in the code."
 165  (mapcar
 166   (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword))
 167   (cdr (second (find :turtles-own code-parsed-ast :key #'car)))))
 168
 169 (defun procedures (code-parsed-ast)
 170  "PROCEDURES CODE-PARSED-AST => PROCEDURES
 171
 172   PROCEDURES: PROCEDURE*
 173   PROCEDURE: (NAME BODY)
 174
 175 ARGUMENTS AND VALUES:
 176
 177   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 178   NAME: A symbol interned in :keyword
 179   BODY: A list of lexed forms
 180
 181 DESCRIPTION:
 182
 183   Returns the procedures that were defined in the code.  These can
 184   then be translated into common lisp by using mapcar on the BODY, and
 185   set to some function defined by NAME"
 186  (mapcar
 187   (lambda (proc) (cdr proc))
 188   (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))