code.consxy.com Git - clnl/blob - src/main/clnl/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  (let
  53   ((*dynamic-prims*
  54     (mapcar
  55      (lambda (prim)
  56       (if (getf prim :macro)
  57        (append (list :func (getf prim :macro)) prim)
  58        (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim)))
  59      dynamic-prims)))
  60   (let
  61    ((deoptionalized-ast (deoptionalize parsed-ast)))
  62    (cond
  63     ((command-list-p deoptionalized-ast) (transpile-commands deoptionalized-ast))
  64     ((and (listp deoptionalized-ast) (= 1 (length deoptionalized-ast)) (reporter-p (car deoptionalized-ast)))
  65      (transpile-reporter (car deoptionalized-ast)))
  66     (t (error "Is neither a list of commands nor a reporter: ~S" deoptionalized-ast))))))
  67
  68 (defun command-list-p (parsed-ast)
  69  "COMMAND-LIST-P PARSED-AST => RESULT
  70
  71 ARGUMENTS AND VALUES:
  72
  73   PARSED-AST: An ast as returned by the parser
  74   RESULT: A boolean
  75
  76 DESCRIPTION:
  77
  78   COMMAND-LIST-P returns whether the parsed-ast is a valid list
  79   of commands."
  80  (every #'command-p parsed-ast))
  81
  82 (defun command-p (parsed-ast)
  83  (and
  84   (listp parsed-ast)
  85   (prim-command-p (find-prim (car parsed-ast)))))
  86
  87 (defun reporter-p (parsed-ast)
  88  "REPORTER-P PARSED-AST => RESULT
  89
  90 ARGUMENTS AND VALUES:
  91
  92   PARSED-AST: An ast as returned by the parser
  93   RESULT: A boolean
  94
  95 DESCRIPTION:
  96
  97   REPORTER-P returns whether the parsed-ast is a valid reporter."
  98  (and
  99   (listp parsed-ast)
 100   (symbolp (car parsed-ast))
 101   (prim-reporter-p (find-prim (car parsed-ast)))))
 102
 103 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
 104 ; For now, it's just a
 105 (defun transpile-commands (parsed-ast)
 106  `(progn
 107    ,@(transpile-commands-inner parsed-ast)))
 108
 109 ; This makes some assumptions about the precedence of optionality
 110 ; Consider the following:
 111 ; - command-1 <optional> <optional>
 112 ; - reporter-1 <optional>
 113 ;
 114 ; And consider:
 115 ; - command-1 reporter-1 "foo"
 116 ;
 117 ; Does the "foo" belong to command-1 or reporter-1?
 118 ;
 119 ; I'm not sure how netlogo answers this at this time, but for the purposes
 120 ; of this deoptionalizer, "foo" belongs to reporter-1.  In the case that the
 121 ; language tests treat this as incorrect, I'll fix it.  I'm not sure if this
 122 ; case exists in the base netlogo language, and I don't feel like creating
 123 ; a specific test case at this time to find out.
 124 (defun deoptionalize (parsed-ast)
 125  (let
 126   ((first-thing (car parsed-ast)))
 127   (cond
 128    ((not parsed-ast) nil)
 129    ((not (listp first-thing)) (cons first-thing (deoptionalize (cdr parsed-ast))))
 130    ((and
 131      (find :optional first-thing)
 132      (cadr parsed-ast)
 133      (not (command-p (cadr parsed-ast))))
 134     (let
 135      ((deoptionalized-rest (deoptionalize (cdr parsed-ast)))
 136       (optional-pos (position :optional first-thing)))
 137      (deoptionalize
 138       (cons
 139        (append
 140         (subseq first-thing 0 optional-pos)
 141         (list (car deoptionalized-rest))
 142         (subseq first-thing (1+ optional-pos)))
 143        (cdr deoptionalized-rest)))))
 144    ((find :optional first-thing)
 145     (deoptionalize
 146      (cons
 147       (subseq first-thing 0 (position :optional first-thing))
 148       (cdr parsed-ast))))
 149    (t
 150     (cons
 151      (deoptionalize first-thing)
 152      (deoptionalize (cdr parsed-ast)))))))
 153
 154 (defun transpile-commands-inner (parsed-ast)
 155  (cond
 156   ((not parsed-ast) nil)
 157   ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast)))
 158   (t
 159    (cons
 160     (transpile-command (car parsed-ast))
 161     (transpile-commands-inner (cdr parsed-ast))))))
 162
 163 (defun handle-let (parsed-ast &optional vars)
 164  (if
 165   (and (listp (car parsed-ast)) (eql :let (caar parsed-ast)))
 166   (let
 167    ((*local-variables* (cons (second (car parsed-ast)) *local-variables*)))
 168    (handle-let
 169     (cdr parsed-ast)
 170     (cons
 171      (list
 172       (transpile-reporter (second (car parsed-ast)))
 173       (transpile-reporter (third (car parsed-ast))))
 174      vars)))
 175   `(let*
 176     ,vars
 177     ,@(transpile-commands-inner parsed-ast))))
 178
 179 (defun transpile-command (command)
 180  (cond
 181   ((not (listp command)) (error "Expected a statement of some sort"))
 182   ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
 183   ((not (prim-command-p (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
 184   (t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
 185
 186 (defun transpile-reporter (reporter)
 187  (cond
 188   ((numberp reporter) reporter) ; The parser converts to double for us
 189   ((stringp reporter) reporter)
 190   ; The parser should have checked that having a symbol here is ok
 191   ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*))
 192   ((not (listp reporter)) (error "Expected a statement of some sort"))
 193   ((eql :command-block (car reporter)) (transpile-command-block reporter))
 194   ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter))))
 195   ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter))
 196   ((eql :token (car reporter)) (cadr reporter))
 197   ((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
 198    (intern (symbol-name (car reporter)) clnl:*model-package*))
 199   ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
 200   ((not (prim-reporter-p (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
 201   (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
 202
 203 (defun transpile-command-block (block)
 204  `(lambda () ,@(transpile-commands-inner (cdr block))))
 205
 206 (defun transpile-reporter-block (block)
 207  (when (/= (length block) 2) (error "Reporter block invalid ~S" block))
 208  `(lambda ()
 209    ,(transpile-reporter (cadr block))))
 210
 211 ; Undoes the previous function :)
 212 (defun make-command-block-inline (block)
 213  (cddr block))
 214
 215 (defmacro defprim (name type func)
 216  `(push (list :name ,name :type ,type :func ,func) *prims*))
 217
 218 (defmacro defsimpleprim (name type simple-func)
 219  `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args))))
 220
 221 (defmacro defkeywordprim (name)
 222  `(defprim ,name :reporter (lambda () ',name)))
 223
 224 (defmacro defagentvalueprim (name)
 225  `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
 226
 227 ; We count on the parser to handle arguemnts for us, when collating things.
 228
 229 (defsimpleprim := :reporter cl:equalp)
 230 (defprim :!= :reporter (lambda (a b) `(not (equalp ,a ,b))))
 231 (defsimpleprim :<= :reporter cl:<=)
 232 (defsimpleprim :< :reporter cl:<)
 233 (defsimpleprim :- :reporter cl:-)
 234 (defsimpleprim :+ :reporter cl:+)
 235 (defsimpleprim :* :reporter cl:*)
 236 (defsimpleprim :/ :reporter cl:/)
 237 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
 238 (defsimpleprim :ask :command clnl-nvm:ask)
 239 (defagentvalueprim :color)
 240 (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
 241 (defsimpleprim :count :reporter clnl-nvm:count)
 242 (defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn)))
 243 (defsimpleprim :die :command clnl-nvm:die)
 244 (defsimpleprim :display :command clnl-nvm:display)
 245 (defsimpleprim :fd :command clnl-nvm:forward)
 246 (defsimpleprim :hatch :command clnl-nvm:hatch)
 247 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
 248 (defprim '(:ifelse :if-else)
 249  :command (lambda (pred a b)
 250            (let
 251             ((then (make-command-block-inline a))
 252              (else (make-command-block-inline b)))
 253             `(if ,pred
 254               ,@(if (= (length then) 1) then `((progn ,@then)))
 255               ,@(if (= (length else) 1) else `((progn ,@else)))))))
 256
 257 (defagentvalueprim :label)
 258 (defagentvalueprim :label-color)
 259 (defsimpleprim :let :command nil)
 260 (defsimpleprim :lt :command clnl-nvm:turn-left)
 261 (defsimpleprim :not :reporter cl:not)
 262 (defkeywordprim :nobody)
 263 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
 264 (defsimpleprim :of :reporter clnl-nvm:of)
 265 (defsimpleprim :patches :reporter clnl-nvm:patches)
 266 (defagentvalueprim :pcolor)
 267 (defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks)
 268 (defsimpleprim :random :reporter clnl-nvm:random)
 269 (defsimpleprim :random-float :reporter clnl-nvm:random-float)
 270 (defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor)
 271 (defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor)
 272 (defprim :round :reporter (lambda (n) `(ffloor (+ ,n 0.5d0))))
 273 (defsimpleprim :rt :command clnl-nvm:turn-right)
 274 (defsimpleprim :set :command cl:setf)
 275 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
 276 (defsimpleprim :setxy :command clnl-nvm:setxy)
 277 (defsimpleprim :show :command clnl-nvm:show)
 278 (defsimpleprim :stop :command clnl-nvm:stop)
 279 (defagentvalueprim :size)
 280 (defsimpleprim :tick :command clnl-nvm:tick)
 281 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
 282 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
 283 (defsimpleprim :turtles-here :reporter clnl-nvm:turtles-here)
 284 (defagentvalueprim :who)
 285 (defsimpleprim :with :reporter clnl-nvm:with)
 286
 287 ; Colors
 288 (defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color))))
 289 (defcolorprim :black)
 290 (defcolorprim :blue)
 291 (defcolorprim :brown)
 292 (defcolorprim :green)
 293 (defcolorprim :white)
 294
 295 ; Boleans
 296 (defprim :true :reporter (lambda () t))
 297 (defprim :false :reporter (lambda () nil))