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

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