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
  13   :name global
  14   :type :reporter
  15   :precedence 10
  16   :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
  17
  18 (defun own->prim (symb)
  19  (list :name symb :type :reporter :precedence 10 :macro `(lambda () '(clnl-nvm:agent-value ,symb))))
  20
  21 (defun breed->prims (breed-list)
  22  (let*
  23   ((plural (car breed-list))
  24    (plural-name (symbol-name plural)))
  25   (list
  26    (list :name plural :type :reporter :precedence 10 :macro `(lambda () ,plural))
  27    (list
  28     :name (intern (format nil "~A-HERE" plural-name) :keyword)
  29     :type :reporter
  30     :precedence 10
  31     :macro `(lambda () '(clnl-nvm:turtles-here ,plural)))
  32    (list
  33     :name (intern (format nil "CREATE-~A" plural-name) :keyword)
  34     :type :command
  35     :args '(:number (:command-block :optional))
  36     :precedence 0
  37     :macro `(lambda (num &optional command-block)
  38              `(clnl-nvm:create-turtles ,num ,,plural ,command-block))))))
  39
  40 (defun parse (lexed-ast &optional external-globals)
  41  "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
  42
  43 ARGUMENTS AND VALUES:
  44
  45   LEXED-AST: An ambigious ast
  46   EXTERNAL-GLOBALS: A list of symbols in keyword package
  47   AST: An unambigious ast that represents the code block of a model
  48   PRIMS: Primitives that can be sent to the parser and transpiler
  49
  50 DESCRIPTION:
  51
  52   PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
  53   It also returns the primitives that are defined in the code file, including
  54   ones generated from the EXTERNAL-GLOBALS, that can then be passed to both
  55   the parser and the transpiler.
  56
  57   EXTERNAL-GLOBALS is a list of symbols representing global variables that
  58   are not defined within the code.  Normally these come from widgets defined
  59   in the model file, but could arguably come from elsewhere.
  60
  61   This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
  62
  63   Rather, the ast that's returned can be queried with other functions included
  64   in the CLNL-CODE-PARSER package to tease out necessary information.  Some of
  65   those things will involve code blocks that can then be transpiled."
  66  (let*
  67   ((*dynamic-prims*
  68     (append
  69      (mapcar #'global->prim (mapcar #'car external-globals))
  70      (procedures->prims lexed-ast)
  71      (clnl-extensions:load-extension :cli)))
  72    (parsed (parse-internal lexed-ast)))
  73   (values
  74    (butlast parsed)
  75    (car (last parsed)))))
  76
  77 (defun procedures->prims (lexed-ast)
  78  (cond
  79   ((not lexed-ast) nil)
  80   ; We'll need argument handling here sometime :)
  81   ((eql :to (car lexed-ast))
  82    (cons
  83     (list
  84      :name (cadr lexed-ast)
  85      :type :command
  86      :precedence 0
  87      :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*)))
  88     (procedures->prims (cddr lexed-ast))))
  89   (t (procedures->prims (cdr lexed-ast)))))
  90
  91 (defun parse-internal (lexed-ast)
  92  (cond
  93   ((not lexed-ast)
  94    (list *dynamic-prims*))
  95   ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
  96   ((find (car lexed-ast) '(:globals :turtles-own :patches-own))
  97    (parse-with-unevaluated-list lexed-ast))
  98   ((eql (car lexed-ast) :breed) (parse-breed lexed-ast))))
  99
 100 ; Due to the non expression style syntax of procedures, this must be special cased
 101 (defun parse-procedure (tokens)
 102  (multiple-value-bind (in-block after-block) (find-end tokens)
 103   (cons
 104    (list
 105     (first in-block)
 106     (second in-block)
 107     (clnl-parser:parse (cddr in-block) *dynamic-prims*))
 108    (parse-internal after-block))))
 109
 110 (defun find-end (tokens)
 111  (cond
 112   ((not tokens) (error "Failed to find end"))
 113   ((eql :end (car tokens)) (values nil (cdr tokens)))
 114   (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens))
 115       (values (cons (car tokens) in-block) after-block)))))
 116
 117 ; This is a special case but left with a little wiggle room for future
 118 ; enhancements, like code blocks
 119 (defun parse-with-unevaluated-list (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*
 126       (append
 127        (mapcar
 128         (case (car lexed-ast)
 129          (:globals #'global->prim)
 130          (:turtles-own #'own->prim)
 131          (:patches-own #'own->prim)
 132          (t #'global->prim))
 133         in-list) *dynamic-prims*)))
 134     (parse-internal after-list)))))
 135
 136 (defun parse-breed (lexed-ast)
 137  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
 138  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
 139   (cons
 140    (list (car lexed-ast) (cons :list-literal in-list))
 141    (let
 142     ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
 143     (parse-internal after-list)))))
 144
 145 (defun find-closing-bracket (tokens)
 146  (cond
 147   ((not tokens) (error "Failed to find a matching closing bracket"))
 148   ((eql :] (car tokens)) (values nil (cdr tokens)))
 149   ((eql :[ (car tokens)) (error "Expected name or ]"))
 150   (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
 151       (values (cons (car tokens) in-block) after-block)))))
 152
 153 (defun globals (code-parsed-ast)
 154  "GLOBALS CODE-PARSED-AST => GLOBALS
 155
 156   GLOBALS: GLOBAL*
 157
 158 ARGUMENTS AND VALUES:
 159
 160   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 161   GLOBAL: A symbol interned in :keyword
 162
 163 DESCRIPTION:
 164
 165   Returns the globals that get declared in the code."
 166  (mapcar
 167   (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
 168   (cdr (second (find :globals code-parsed-ast :key #'car)))))
 169
 170 (defun turtles-own-vars (code-parsed-ast)
 171  "TURTLES-OWN-VARS CODE-PARSED-AST => TURTLES-OWN-VARS
 172
 173   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
 174
 175 ARGUMENTS AND VALUES:
 176
 177   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 178   TURTLES-OWN-VAR: A symbol interned in :keyword
 179
 180 DESCRIPTION:
 181
 182   Returns the turtles own variables that get declared in the code."
 183  (cdr (second (find :turtles-own code-parsed-ast :key #'car))))
 184
 185 (defun patches-own-vars (code-parsed-ast)
 186  "PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS
 187
 188   PATCHES-OWN-VARS: PATCHES-OWN-VAR*
 189
 190 ARGUMENTS AND VALUES:
 191
 192   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 193   PATCHES-OWN-VAR: A symbol interned in :keyword
 194
 195 DESCRIPTION:
 196
 197   Returns the turtles own variables that get declared in the code."
 198  (cdr (second (find :patches-own code-parsed-ast :key #'car))))
 199
 200 (defun breeds (code-parsed-ast)
 201  "BREEDS CODE-PARSED-AST => BREEDS
 202
 203   BREEDS: BREED*
 204
 205 ARGUMENTS AND VALUES:
 206
 207   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 208   BREED: A symbol interned in :keyword
 209
 210 DESCRIPTION:
 211
 212   Returns the breeds that get declared in the code."
 213  (mapcar #'cadadr (remove :breed code-parsed-ast :test-not #'equal :key #'car)))
 214
 215 (defun procedures (code-parsed-ast)
 216  "PROCEDURES CODE-PARSED-AST => PROCEDURES
 217
 218   PROCEDURES: PROCEDURE*
 219   PROCEDURE: (NAME BODY)
 220
 221 ARGUMENTS AND VALUES:
 222
 223   CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
 224   NAME: A symbol interned in :keyword
 225   BODY: A list of lexed forms
 226
 227 DESCRIPTION:
 228
 229   Returns the procedures that were defined in the code.  These can
 230   then be translated into common lisp by using mapcar on the BODY, and
 231   set to some function defined by NAME"
 232  (mapcar
 233   (lambda (proc) (cdr proc))
 234   (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))