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

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