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

   1 (in-package #:clnl-transpiler)
   2
   3 (defparameter *prims* nil)
   4
   5 (defvar *local-variables* nil)
   6 (defvar *dynamic-prims* nil)
   7
   8 (defun prim-name (prim) (getf prim :name))
   9 (defun prim-type (prim) (getf prim :type))
  10 (defun prim-func (prim) (getf prim :func))
  11 (defun prim-reporter-p (prim) (eql :reporter (getf prim :type)))
  12 (defun prim-command-p (prim) (eql :command (getf prim :type)))
  13
  14 (defun find-prim (symb)
  15  (when symb
  16   (find-if
  17    (lambda (prim-name) (or (eql symb prim-name) (and (listp prim-name) (find symb prim-name))))
  18    (append *prims* *dynamic-prims*)
  19    :key #'prim-name)))
  20
  21 (defun transpile (parsed-ast &optional dynamic-prims)
  22  "TRANSPILE PARSED-AST &optional DYNAMIC-PRIMS => AST
  23
  24   DYNAMIC-PRIMS: DYNAMIC-PRIM*
  25   DYNAMIC-PRIM: (:name NAME :type TYPE :macro MACRO :func FUNC)
  26   TYPE: :reporter | :command
  27
  28 ARGUMENTS AND VALUES:
  29
  30   PARSED-AST: An ast as returned by the parser
  31   AST: An common lisp AST that can be actually run in a common lisp instance
  32   NAME: A symbol in the keyword package
  33   MACRO: A macro that will be called with the arguments ast
  34   FUNC: A function that will be called with the transpiled arguments
  35
  36 DESCRIPTION:
  37
  38   TRANSPILE takes a unambigious PARSED-AST and converts it to
  39   Common Lisp code.  The PARSED-AST must be either a list of commands,
  40   or a single reporter.
  41
  42   When a set of DYNAMIC-PRIMS is included, external language constructs
  43   can be also transpiled.  The provided functions will be inserted into
  44   the returned AST with a call to FUNCALL.  If :macro is included, instead
  45   of having a call to FUNCALL provided, the macro will be run at netlogo
  46   transpile time, with the arguments it should have specified to the
  47   parser.  The result of that function call will then be dropped into
  48   the ast.
  49
  50   Calling eval on that code should work correctly as long as you have a
  51   running engine."
  52
  53  (let
  54   ((*dynamic-prims*
  55     (mapcar
  56      (lambda (prim)
  57       (if (getf prim :macro)
  58        (append (list :func (getf prim :macro)) prim)
  59        (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim)))
  60      dynamic-prims)))
  61   (cond
  62    ((command-list-p parsed-ast) (transpile-commands parsed-ast))
  63    ((and (listp parsed-ast) (= 1 (length parsed-ast)) (reporter-p (car parsed-ast)))
  64     (transpile-reporter (car parsed-ast)))
  65    (t (error "Is neither a list of commands nor a reporter: ~S" parsed-ast)))))
  66
  67 (defun command-list-p (parsed-ast)
  68  "COMMAND-LIST-P PARSED-AST => RESULT
  69
  70 ARGUMENTS AND VALUES:
  71
  72   PARSED-AST: An ast as returned by the parser
  73   RESULT: A boolean
  74
  75 DESCRIPTION:
  76
  77   COMMAND-LIST-P returns whether the parsed-ast is a valid list
  78   of commands."
  79  (and
  80   (every #'listp parsed-ast)
  81   (every #'prim-command-p (mapcar #'find-prim (mapcar #'car parsed-ast)))))
  82
  83 (defun reporter-p (parsed-ast)
  84  "REPORTER-P PARSED-AST => RESULT
  85
  86 ARGUMENTS AND VALUES:
  87
  88   PARSED-AST: An ast as returned by the parser
  89   RESULT: A boolean
  90
  91 DESCRIPTION:
  92
  93   REPORTER-P returns whether the parsed-ast is a valid reporter."
  94  (and
  95   (symbolp (car parsed-ast))
  96   (prim-reporter-p (find-prim (car parsed-ast)))))
  97
  98 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
  99 ; For now, it's just a
 100 (defun transpile-commands (parsed-ast)
 101  `(progn
 102    ,@(transpile-commands-inner parsed-ast)))
 103
 104 (defun transpile-commands-inner (parsed-ast)
 105  (cond
 106   ((not parsed-ast) nil)
 107   ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast)))
 108   (t
 109    (cons
 110     (transpile-command (car parsed-ast))
 111     (transpile-commands-inner (cdr parsed-ast))))))
 112
 113 (defun handle-let (parsed-ast &optional vars)
 114  (if
 115   (and (listp (car parsed-ast)) (eql :let (caar parsed-ast)))
 116   (let
 117    ((*local-variables* (cons (second (car parsed-ast)) *local-variables*)))
 118    (handle-let
 119     (cdr parsed-ast)
 120     (cons
 121      (list
 122       (transpile-reporter (second (car parsed-ast)))
 123       (transpile-reporter (third (car parsed-ast))))
 124      vars)))
 125   `(let*
 126     ,vars
 127     ,@(transpile-commands-inner parsed-ast))))
 128
 129 (defun transpile-command (command)
 130  (cond
 131   ((not (listp command)) (error "Expected a statement of some sort"))
 132   ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
 133   ((not (prim-command-p (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
 134   (t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
 135
 136 (defun transpile-reporter (reporter)
 137  (cond
 138   ((numberp reporter) reporter) ; The parser converts to double for us
 139   ((stringp reporter) reporter)
 140   ; The parser should have checked that having a symbol here is ok
 141   ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*))
 142   ((not (listp reporter)) (error "Expected a statement of some sort"))
 143   ((eql :command-block (car reporter)) (transpile-command-block reporter))
 144   ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter))))
 145   ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter))
 146   ((eql :token (car reporter)) (cadr reporter))
 147   ((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
 148    (intern (symbol-name (car reporter)) clnl:*model-package*))
 149   ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
 150   ((not (prim-reporter-p (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
 151   (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
 152
 153 (defun transpile-command-block (block)
 154  `(lambda () ,@(transpile-commands-inner (cdr block))))
 155
 156 (defun transpile-reporter-block (block)
 157  (when (/= (length block) 2) (error "Reporter block invalid ~S" block))
 158  `(lambda ()
 159    ,(transpile-reporter (cadr block))))
 160
 161 ; Undoes the previous function :)
 162 (defun make-command-block-inline (block)
 163  (cddr block))
 164
 165 (defmacro defprim (name type func)
 166  `(push (list :name ,name :type ,type :func ,func) *prims*))
 167
 168 (defmacro defsimpleprim (name type simple-func)
 169  `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args))))
 170
 171 (defmacro defkeywordprim (name)
 172  `(defprim ,name :reporter (lambda () ',name)))
 173
 174 (defmacro defagentvalueprim (name)
 175  `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
 176
 177 ; We count on the parser to handle arguemnts for us, when collating things.
 178
 179 (defsimpleprim := :reporter cl:equalp)
 180 (defprim :!= :reporter (lambda (a b) `(not (equalp ,a ,b))))
 181 (defsimpleprim :<= :reporter cl:<=)
 182 (defsimpleprim :< :reporter cl:<)
 183 (defsimpleprim :- :reporter cl:-)
 184 (defsimpleprim :+ :reporter cl:+)
 185 (defsimpleprim :* :reporter cl:*)
 186 (defsimpleprim :/ :reporter cl:/)
 187 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
 188 (defsimpleprim :ask :command clnl-nvm:ask)
 189 (defagentvalueprim :color)
 190 (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
 191 (defsimpleprim :count :reporter clnl-nvm:count)
 192 (defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn)))
 193 (defsimpleprim :die :command clnl-nvm:die)
 194 (defsimpleprim :display :command clnl-nvm:display)
 195 (defsimpleprim :fd :command clnl-nvm:forward)
 196 (defsimpleprim :hatch :command clnl-nvm:hatch)
 197 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
 198 (defprim '(:ifelse :if-else)
 199  :command (lambda (pred a b)
 200            (let
 201             ((then (make-command-block-inline a))
 202              (else (make-command-block-inline b)))
 203             `(if ,pred
 204               ,@(if (= (length then) 1) then `((progn ,@then)))
 205               ,@(if (= (length else) 1) else `((progn ,@else)))))))
 206
 207 (defagentvalueprim :label)
 208 (defagentvalueprim :label-color)
 209 (defsimpleprim :let :command nil)
 210 (defsimpleprim :lt :command clnl-nvm:turn-left)
 211 (defsimpleprim :not :reporter cl:not)
 212 (defkeywordprim :nobody)
 213 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
 214 (defsimpleprim :of :reporter clnl-nvm:of)
 215 (defsimpleprim :patches :reporter clnl-nvm:patches)
 216 (defagentvalueprim :pcolor)
 217 (defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks)
 218 (defsimpleprim :random :reporter clnl-nvm:random)
 219 (defsimpleprim :random-float :reporter clnl-nvm:random-float)
 220 (defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor)
 221 (defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor)
 222 (defprim :round :reporter (lambda (n) `(ffloor (+ ,n 0.5d0))))
 223 (defsimpleprim :rt :command clnl-nvm:turn-right)
 224 (defsimpleprim :set :command cl:setf)
 225 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
 226 (defsimpleprim :setxy :command clnl-nvm:setxy)
 227 (defsimpleprim :show :command clnl-nvm:show)
 228 (defsimpleprim :stop :command clnl-nvm:stop)
 229 (defagentvalueprim :size)
 230 (defsimpleprim :tick :command clnl-nvm:tick)
 231 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
 232 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
 233 (defsimpleprim :turtles-here :reporter clnl-nvm:turtles-here)
 234 (defagentvalueprim :who)
 235 (defsimpleprim :with :reporter clnl-nvm:with)
 236
 237 ; Colors
 238 (defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color))))
 239 (defcolorprim :black)
 240 (defcolorprim :blue)
 241 (defcolorprim :brown)
 242 (defcolorprim :green)
 243 (defcolorprim :white)