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

   1 (in-package #:clnl-transpiler)
   2
   3 (defparameter *prims* nil)
   4 (defparameter *prim-aliases* nil)
   5
   6 (defvar *local-variables* 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 is-reporter (prim) (eql :reporter (getf prim :type)))
  12 (defun is-command (prim) (eql :command (getf prim :type)))
  13
  14 (defun find-prim (symb)
  15  (when symb
  16   (or
  17    (find symb *prims* :key #'prim-name)
  18    (find-prim (getf (find symb *prim-aliases* :key #'prim-name) :real-symb)))))
  19
  20 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
  21 ; For now, it's just a
  22 (defun transpile-commands (parsed-ast)
  23  "TRANSPILE-COMMANDS PARSED-AST => AST
  24
  25 ARGUMENTS AND VALUES:
  26
  27   PARSED-AST: An ast as returned by the parser
  28   AST: An common lisp AST that can be actually run in a common lisp instance
  29
  30 DESCRIPTION:
  31
  32   TRANSPILE-COMMANDS takes a unambigious PARSED-AST and converts it to
  33   Common Lisp code.
  34
  35   Calling eval on that code should work correctly as long as you have a
  36   running engine.  This is the entry point for commands, so it does
  37   extra checking to ensure that commands are actually in the PARSED-AST."
  38  `(progn
  39    ,@(transpile-commands-inner parsed-ast)))
  40
  41 (defun transpile-commands-inner (parsed-ast)
  42  (cond
  43   ((not parsed-ast) nil)
  44   ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast)))
  45   (t
  46    (cons
  47     (transpile-command (car parsed-ast))
  48     (transpile-commands-inner (cdr parsed-ast))))))
  49
  50 (defun handle-let (parsed-ast &optional vars)
  51  (if
  52   (and (listp (car parsed-ast)) (eql :let (caar parsed-ast)))
  53   (let
  54    ((*local-variables* (cons (second (car parsed-ast)) *local-variables*)))
  55    (handle-let
  56     (cdr parsed-ast)
  57     (cons
  58      (list
  59       (transpile-reporter (second (car parsed-ast)))
  60       (transpile-reporter (third (car parsed-ast))))
  61      vars)))
  62   `(let*
  63     ,vars
  64     ,@(transpile-commands-inner parsed-ast))))
  65
  66 (defun transpile-command (command)
  67  (cond
  68   ((not (listp command)) (error "Expected a statement of some sort"))
  69   ((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
  70   ((not (is-command (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
  71   (t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
  72
  73 (defun transpile-reporter (reporter)
  74  "TRANSPILE-REPORTER REPORTER => AST
  75
  76 ARGUMENTS AND VALUES:
  77
  78   REPORTER: An ast returned from the parser.
  79   AST: An common lisp AST that can be actually run in a common lisp instance
  80
  81 DESCRIPTION:
  82
  83   TRANSPILE-REPORTER takes a unambigious PARSED-AST and converts it to
  84   Common Lisp code.
  85
  86   Calling eval on that code should work correctly as long as you have a
  87   running engine.  This is the entry point for reporters, so it does
  88   extra checking to ensure that the reporter is actually in the REPORTER.
  89
  90   The Common lisp code that is returned, when run, will return some value."
  91  (cond
  92   ((numberp reporter) reporter) ; The parser converts to double for us
  93   ((stringp reporter) reporter)
  94   ; The parser should have checked that having a symbol here is ok
  95   ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*))
  96   ((not (listp reporter)) (error "Expected a statement of some sort"))
  97   ((eql :command-block (car reporter)) (transpile-command-block reporter))
  98   ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter))))
  99   ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter))
 100   ((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
 101    (intern (symbol-name (car reporter)) clnl:*model-package*))
 102   ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
 103   ((not (is-reporter (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
 104   (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
 105
 106 (defun transpile-command-block (block)
 107  `(lambda () ,@(transpile-commands-inner (cdr block))))
 108
 109 (defun transpile-reporter-block (block)
 110  (when (/= (length block) 2) (error "Reporter block invalid ~S" block))
 111  `(lambda ()
 112    ,(transpile-reporter (cadr block))))
 113
 114 ; Undoes the previous function :)
 115 (defun make-command-block-inline (block)
 116  (cddr block))
 117
 118 (defmacro defprim (name type func)
 119  `(push (list :name ,name :type ,type :func ,func) *prims*))
 120
 121 (defmacro defsimpleprim (name type simple-func)
 122  `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args))))
 123
 124 (defmacro defkeywordprim (name)
 125  `(defprim ,name :reporter (lambda () ',name)))
 126
 127 (defmacro defprim-alias (name real-symb)
 128  `(push (list :name ,name :real-symb ,real-symb) *prim-aliases*))
 129
 130 (defmacro defagentvalueprim (name)
 131  `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
 132
 133 ; We count on the parser to handle arguemnts for us, when collating things.
 134
 135 (defsimpleprim := :reporter cl:equalp)
 136 (defprim :!= :reporter (lambda (a b) `(not (equalp ,a ,b))))
 137 (defsimpleprim :<= :reporter cl:<=)
 138 (defsimpleprim :< :reporter cl:<)
 139 (defsimpleprim :- :reporter cl:-)
 140 (defsimpleprim :+ :reporter cl:+)
 141 (defsimpleprim :* :reporter cl:*)
 142 (defsimpleprim :/ :reporter cl:/)
 143 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
 144 (defsimpleprim :ask :command clnl-nvm:ask)
 145 (defagentvalueprim :color)
 146 (defsimpleprim :count :reporter clnl-nvm:count)
 147 (defsimpleprim :crt :command clnl-nvm:create-turtles)
 148 (defsimpleprim :die :command clnl-nvm:die)
 149 (defsimpleprim :fd :command clnl-nvm:forward)
 150 (defsimpleprim :hatch :command clnl-nvm:hatch)
 151 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
 152 (defprim :ifelse :command (lambda (pred a b)
 153                            `(if ,pred
 154                              ,@(make-command-block-inline a)
 155                              ,@(make-command-block-inline b))))
 156
 157 (defprim-alias :if-else :ifelse)
 158 (defagentvalueprim :label)
 159 (defagentvalueprim :label-color)
 160 (defsimpleprim :lt :command clnl-nvm:turn-left)
 161 (defsimpleprim :not :reporter cl:not)
 162 (defkeywordprim :nobody)
 163 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
 164 (defsimpleprim :of :reporter clnl-nvm:of)
 165 (defsimpleprim :patches :reporter clnl-nvm:patches)
 166 (defagentvalueprim :pcolor)
 167 (defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks)
 168 (defsimpleprim :random :reporter clnl-nvm:random)
 169 (defsimpleprim :random-float :reporter clnl-nvm:random-float)
 170 (defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor)
 171 (defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor)
 172 (defsimpleprim :rt :command clnl-nvm:turn-right)
 173 (defsimpleprim :set :command cl:setf)
 174 (defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape)
 175 (defsimpleprim :setxy :command clnl-nvm:setxy)
 176 (defsimpleprim :show :command clnl-nvm:show)
 177 (defagentvalueprim :size)
 178 (defsimpleprim :tick :command clnl-nvm:tick)
 179 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
 180 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
 181 (defagentvalueprim :who)
 182 (defsimpleprim :with :reporter clnl-nvm:with)
 183
 184 ; Colors
 185 (defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color))))
 186 (defcolorprim :black)
 187 (defcolorprim :blue)
 188 (defcolorprim :brown)
 189 (defcolorprim :green)
 190 (defcolorprim :white)