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 (defun global->prim (global) (list :name global))
  11 (defun breed->prims (breed-list)
  12  (let
  13   ((plural-name (symbol-name (car breed-list))))
  14   (list
  15    (list :name (car breed-list))
  16    (list :name (intern (format nil "~A-HERE" plural-name) :keyword))
  17    (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block)))))
  18
  19 (defun parse (lexed-ast &optional external-globals)
  20  "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST
  21
  22 ARGUMENTS AND VALUES:
  23
  24   LEXED-AST: An ambigious ast
  25   EXTERNAL-GLOBALS: A list of symbols in keyword package
  26   AST: An unambigious ast that represents the code block of a model
  27
  28 DESCRIPTION:
  29
  30   PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
  31
  32   EXTERNAL-GLOBALS is a list of symbols representing global variables that
  33   are not defined within the code.  Normally these come from widgets defined
  34   in the model file, but could arguably come from elsewhere.
  35
  36   This parser, unlike CLNL-PARSE:PARSE, should not be fed into the transpiler.
  37
  38   Rather, the ast that's returned can be queried with other functions included
  39   in the CLNL-CODE-PARSER package to tease out necessary information.  Some of
  40   those things will involve code blocks that can then be transpiled."
  41  (let
  42   ((*dynamic-prims*
  43     (append
  44      (mapcar #'global->prim external-globals)
  45      (procedures->prims lexed-ast))))
  46   (parse-internal lexed-ast)))
  47
  48 (defun procedures->prims (lexed-ast)
  49  (cond
  50   ((not lexed-ast) nil)
  51   ; We'll need argument handling here sometime :)
  52   ((eql :to (car lexed-ast)) (cons (list :name (cadr lexed-ast)) (procedures-to-prims (cdr lexed-ast))))
  53   (t (procedures-to-prims (cdr lexed-ast)))))
  54
  55 (defun parse-internal (lexed-ast)
  56  (cond
  57   ((not lexed-ast) nil)
  58   ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
  59   ((find (car lexed-ast) '(:globals :turtles-own :patches-own))
  60    (parse-with-unevaluated-list lexed-ast))
  61   ((eql (car lexed-ast) :breed) (parse-breed lexed-ast))))
  62
  63 ; Due to the non expression style syntax of procedures, this must be special cased
  64 (defun parse-procedure (tokens)
  65  (multiple-value-bind (in-block after-block) (find-end tokens)
  66   (cons
  67    (list
  68     (first in-block)
  69     (second in-block)
  70     (clnl-parser:parse (cddr in-block) *dynamic-prims*))
  71    (parse-internal after-block))))
  72
  73 (defun find-end (tokens)
  74  (cond
  75   ((not tokens) (error "Failed to find end"))
  76   ((eql :end (car tokens)) (values nil (cdr tokens)))
  77   (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens))
  78       (values (cons (car tokens) in-block) after-block)))))
  79
  80 ; This is a special case but left with a little wiggle room for future
  81 ; enhancements, like code blocks
  82 (defun parse-with-unevaluated-list (lexed-ast)
  83  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
  84  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
  85   (cons
  86    (list (car lexed-ast) (cons :list-literal in-list))
  87    (let
  88     ((*dynamic-prims* (append (mapcar #'global->prim in-list) *dynamic-prims*)))
  89     (parse-internal after-list)))))
  90
  91 (defun parse-breed (lexed-ast)
  92  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
  93  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
  94   (cons
  95    (list (car lexed-ast) (cons :list-literal in-list))
  96    (let
  97     ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
  98     (parse-internal after-list)))))
  99
 100 (defun find-closing-bracket (tokens)
 101  (cond
 102   ((not tokens) (error "Failed to find a matching closing bracket"))
 103   ((eql :] (car tokens)) (values nil (cdr tokens)))
 104   ((eql :[ (car tokens)) (error "Expected name or ]"))
 105   (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
 106       (values (cons (car tokens) in-block) after-block)))))
 107
 108 (defun globals (code-parsed-ast)
 109  "GLOBALS MODEL => GLOBALS
 110
 111   GLOBALS: GLOBAL*
 112
 113 ARGUMENTS AND VALUES:
 114
 115   MODEL: An ast as created by clnl-code-parse:parse
 116   GLOBAL: A symbol interned in clnl:*model-package*
 117
 118 DESCRIPTION:
 119
 120   Returns the globals that get declared in the code."
 121  (mapcar
 122   (lambda (global) (list (symbol-name global) 0d0))
 123   (cdr (second (find :globals code-parsed-ast :key #'car)))))