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 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 #'own->prim)
 114          (:patches-own #'own->prim)
 115          (t #'global->prim))
 116         in-list) *dynamic-prims*)))
 117     (parse-internal after-list)))))
 118
 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))
 122   (cons
 123    (list (car lexed-ast) (cons :list-literal in-list))
 124    (let
 125     ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
 126     (parse-internal after-list)))))
 127
 128 (defun find-closing-bracket (tokens)
 129  (cond
 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)))))
 135
 136 (defun globals (code-parsed-ast)
 137  "GLOBALS CODE-PARSED-AST => GLOBALS
 138
 139   GLOBALS: GLOBAL*
 140
 141 ARGUMENTS AND VALUES:
 142
 143   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 144   GLOBAL: A symbol interned in :keyword
 145
 146 DESCRIPTION:
 147
 148   Returns the globals that get declared in the code."
 149  (mapcar
 150   (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
 151   (cdr (second (find :globals code-parsed-ast :key #'car)))))
 152
 153 (defun turtles-own-vars (code-parsed-ast)
 154  "TURTLES-OWN-VARS CODE-PARSED-AST => TURTLES-OWN-VARS
 155
 156   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
 157
 158 ARGUMENTS AND VALUES:
 159
 160   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 161   TURTLES-OWN-VAR: A symbol interned in :keyword
 162
 163 DESCRIPTION:
 164
 165   Returns the turtles own variables that get declared in the code."
 166  (mapcar
 167   (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword))
 168   (cdr (second (find :turtles-own code-parsed-ast :key #'car)))))
 169
 170 (defun patches-own-vars (code-parsed-ast)
 171  "PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS
 172
 173   PATCHES-OWN-VARS: PATCHES-OWN-VAR*
 174
 175 ARGUMENTS AND VALUES:
 176
 177   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 178   PATCHES-OWN-VAR: A symbol interned in :keyword
 179
 180 DESCRIPTION:
 181
 182   Returns the turtles own variables that get declared in the code."
 183  (mapcar
 184   (lambda (patches-own-var) (intern (symbol-name patches-own-var) :keyword))
 185   (cdr (second (find :patches-own code-parsed-ast :key #'car)))))
 186
 187 (defun procedures (code-parsed-ast)
 188  "PROCEDURES CODE-PARSED-AST => PROCEDURES
 189
 190   PROCEDURES: PROCEDURE*
 191   PROCEDURE: (NAME BODY)
 192
 193 ARGUMENTS AND VALUES:
 194
 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
 198
 199 DESCRIPTION:
 200
 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"
 204  (mapcar
 205   (lambda (proc) (cdr proc))
 206   (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))