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