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    (car (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))
  63    (cons
  64     (list
  65      :name (cadr lexed-ast)
  66      :type :command
  67      :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*)))
  68     (procedures->prims (cddr lexed-ast))))
  69   (t (procedures->prims (cdr lexed-ast)))))
  70
  71 (defun parse-internal (lexed-ast)
  72  (cond
  73   ((not lexed-ast)
  74    (list *dynamic-prims*))
  75   ((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
  76   ((find (car lexed-ast) '(:globals :turtles-own :patches-own))
  77    (parse-with-unevaluated-list lexed-ast))
  78   ((eql (car lexed-ast) :breed) (parse-breed lexed-ast))))
  79
  80 ; Due to the non expression style syntax of procedures, this must be special cased
  81 (defun parse-procedure (tokens)
  82  (multiple-value-bind (in-block after-block) (find-end tokens)
  83   (cons
  84    (list
  85     (first in-block)
  86     (second in-block)
  87     (clnl-parser:parse (cddr in-block) *dynamic-prims*))
  88    (parse-internal after-block))))
  89
  90 (defun find-end (tokens)
  91  (cond
  92   ((not tokens) (error "Failed to find end"))
  93   ((eql :end (car tokens)) (values nil (cdr tokens)))
  94   (t (multiple-value-bind (in-block after-block) (find-end (cdr tokens))
  95       (values (cons (car tokens) in-block) after-block)))))
  96
  97 ; This is a special case but left with a little wiggle room for future
  98 ; enhancements, like code blocks
  99 (defun parse-with-unevaluated-list (lexed-ast)
 100  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
 101  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
 102   (cons
 103    (list (car lexed-ast) (cons :list-literal in-list))
 104    (let
 105     ((*dynamic-prims* (append (mapcar #'global->prim in-list) *dynamic-prims*)))
 106     (parse-internal after-list)))))
 107
 108 (defun parse-breed (lexed-ast)
 109  (when (not (eql :[ (cadr lexed-ast))) (error "Expected list literal here"))
 110  (multiple-value-bind (in-list after-list) (find-closing-bracket (cddr lexed-ast))
 111   (cons
 112    (list (car lexed-ast) (cons :list-literal in-list))
 113    (let
 114     ((*dynamic-prims* (append (breed->prims in-list) *dynamic-prims*)))
 115     (parse-internal after-list)))))
 116
 117 (defun find-closing-bracket (tokens)
 118  (cond
 119   ((not tokens) (error "Failed to find a matching closing bracket"))
 120   ((eql :] (car tokens)) (values nil (cdr tokens)))
 121   ((eql :[ (car tokens)) (error "Expected name or ]"))
 122   (t (multiple-value-bind (in-block after-block) (find-closing-bracket (cdr tokens))
 123       (values (cons (car tokens) in-block) after-block)))))
 124
 125 (defun globals (code-parsed-ast)
 126  "GLOBALS MODEL => GLOBALS
 127
 128   GLOBALS: GLOBAL*
 129
 130 ARGUMENTS AND VALUES:
 131
 132   MODEL: An ast as created by clnl-code-parse:parse
 133   GLOBAL: A symbol interned in :keyword
 134
 135 DESCRIPTION:
 136
 137   Returns the globals that get declared in the code."
 138  (mapcar
 139   (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
 140   (cdr (second (find :globals code-parsed-ast :key #'car)))))
 141
 142 (defun procedures (code-parsed-ast)
 143  "PROCEDURES MODEL => PROCEDURES
 144
 145   PROCEDURES: PROCEDURE*
 146   PROCEDURE: (NAME BODY)
 147
 148 ARGUMENTS AND VALUES:
 149
 150   MODEL: An ast as created by clnl-code-parse:parse
 151   NAME: A symbol interned in :keyword
 152   BODY: A list of lexed forms
 153
 154 DESCRIPTION:
 155
 156   Returns the procedures that were defined in the code.  These can
 157   then be translated into common lisp by using mapcar on the BODY, and
 158   set to some function defined by NAME"
 159  (mapcar
 160   (lambda (proc) (cdr proc))
 161   (remove-if-not (lambda (form) (find (car form) '(:to :to-report))) code-parsed-ast)))