X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Ftranspile.lisp;h=3feedc2df85292309b56f95bc8d997647fbce667;hp=4a6a5a007423e14f1f7966fbfc430014f4f10582;hb=9eef8ecae4fad1e01413807ebc80ae45b5990706;hpb=2c338ef0bdabd1e327bbf474221239c2eead88e4 diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 4a6a5a0..3feedc2 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -1,6 +1,9 @@ (in-package #:clnl-transpiler) (defparameter *prims* nil) +(defparameter *prim-aliases* nil) + +(defvar *local-variables* nil) (defun prim-name (prim) (getf prim :name)) (defun prim-type (prim) (getf prim :type)) @@ -8,7 +11,11 @@ (defun is-reporter (prim) (eql :reporter (getf prim :type))) (defun is-command (prim) (eql :command (getf prim :type))) -(defun find-prim (symb) (find symb *prims* :key #'prim-name)) +(defun find-prim (symb) + (when symb + (or + (find symb *prims* :key #'prim-name) + (find-prim (getf (find symb *prim-aliases* :key #'prim-name) :real-symb))))) ; Let this grow, slowly but surely, eventually taking on calling context, etc. ; For now, it's just a @@ -29,7 +36,32 @@ DESCRIPTION: running engine. This is the entry point for commands, so it does extra checking to ensure that commands are actually in the PARSED-AST." `(progn - ,@(mapcar #'transpile-command parsed-ast))) + ,@(transpile-commands-inner parsed-ast))) + +(defun transpile-commands-inner (parsed-ast) + (cond + ((not parsed-ast) nil) + ((and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) (list (handle-let parsed-ast))) + (t + (cons + (transpile-command (car parsed-ast)) + (transpile-commands-inner (cdr parsed-ast)))))) + +(defun handle-let (parsed-ast &optional vars) + (if + (and (listp (car parsed-ast)) (eql :let (caar parsed-ast))) + (let + ((*local-variables* (cons (second (car parsed-ast)) *local-variables*))) + (handle-let + (cdr parsed-ast) + (cons + (list + (transpile-reporter (second (car parsed-ast))) + (transpile-reporter (third (car parsed-ast)))) + vars))) + `(let* + ,vars + ,@(transpile-commands-inner parsed-ast)))) (defun transpile-command (command) (cond @@ -58,15 +90,30 @@ DESCRIPTION: The Common lisp code that is returned, when run, will return some value." (cond ((numberp reporter) reporter) ; The parser converts to double for us - ((symbolp reporter) reporter) ; The parser should have checked that having a symbol here is ok + ((stringp reporter) reporter) + ; The parser should have checked that having a symbol here is ok + ((symbolp reporter) (intern (symbol-name reporter) clnl:*model-package*)) ((not (listp reporter)) (error "Expected a statement of some sort")) ((eql :command-block (car reporter)) (transpile-command-block reporter)) + ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter)))) + ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter)) + ((and (symbolp (car reporter)) (find (car reporter) *local-variables*)) + (intern (symbol-name (car reporter)) clnl:*model-package*)) ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter))) ((not (is-reporter (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter))) (t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter)))))) (defun transpile-command-block (block) - `(lambda () ,@(mapcar #'transpile-command (cdr block)))) + `(lambda () ,@(transpile-commands-inner (cdr block)))) + +(defun transpile-reporter-block (block) + (when (/= (length block) 2) (error "Reporter block invalid ~S" block)) + `(lambda () + ,(transpile-reporter (cadr block)))) + +; Undoes the previous function :) +(defun make-command-block-inline (block) + (cddr block)) (defmacro defprim (name type func) `(push (list :name ,name :type ,type :func ,func) *prims*)) @@ -74,6 +121,15 @@ DESCRIPTION: (defmacro defsimpleprim (name type simple-func) `(defprim ,name ,type (lambda (&rest args) `(,',simple-func ,@args)))) +(defmacro defkeywordprim (name) + `(defprim ,name :reporter (lambda () ',name))) + +(defmacro defprim-alias (name real-symb) + `(push (list :name ,name :real-symb ,real-symb) *prim-aliases*)) + +(defmacro defagentvalueprim (name) + `(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name)))) + ; We count on the parser to handle arguemnts for us, when collating things. (defsimpleprim := :reporter cl:equalp) @@ -84,13 +140,51 @@ DESCRIPTION: (defsimpleprim :+ :reporter cl:+) (defsimpleprim :* :reporter cl:*) (defsimpleprim :/ :reporter cl:/) -(defprim :any? :reporter (lambda (agentset) `(> (length ,agentset) 0))) +(defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0))) (defsimpleprim :ask :command clnl-nvm:ask) +(defagentvalueprim :color) +(defsimpleprim :count :reporter clnl-nvm:count) (defsimpleprim :crt :command clnl-nvm:create-turtles) (defsimpleprim :die :command clnl-nvm:die) (defsimpleprim :fd :command clnl-nvm:forward) +(defsimpleprim :hatch :command clnl-nvm:hatch) +(defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a)))) +(defprim :ifelse :command (lambda (pred a b) + `(if ,pred + ,@(make-command-block-inline a) + ,@(make-command-block-inline b)))) + +(defprim-alias :if-else :ifelse) +(defagentvalueprim :label) +(defagentvalueprim :label-color) (defsimpleprim :lt :command clnl-nvm:turn-left) +(defsimpleprim :not :reporter cl:not) +(defkeywordprim :nobody) +(defsimpleprim :one-of :reporter clnl-nvm:one-of) +(defsimpleprim :of :reporter clnl-nvm:of) +(defsimpleprim :patches :reporter clnl-nvm:patches) +(defagentvalueprim :pcolor) +(defsimpleprim :reset-ticks :command clnl-nvm:reset-ticks) +(defsimpleprim :random :reporter clnl-nvm:random) (defsimpleprim :random-float :reporter clnl-nvm:random-float) +(defsimpleprim :random-xcor :reporter clnl-nvm:random-xcor) +(defsimpleprim :random-ycor :reporter clnl-nvm:random-ycor) (defsimpleprim :rt :command clnl-nvm:turn-right) +(defsimpleprim :set :command cl:setf) +(defsimpleprim :set-default-shape :command clnl-nvm:set-default-shape) +(defsimpleprim :setxy :command clnl-nvm:setxy) (defsimpleprim :show :command clnl-nvm:show) +(defagentvalueprim :size) +(defsimpleprim :tick :command clnl-nvm:tick) +(defsimpleprim :ticks :reporter clnl-nvm:ticks) (defsimpleprim :turtles :reporter clnl-nvm:turtles) +(defagentvalueprim :who) +(defsimpleprim :with :reporter clnl-nvm:with) + +; Colors +(defmacro defcolorprim (color) `(defprim ,color :reporter (lambda () `(clnl-nvm:lookup-color ,,color)))) +(defcolorprim :black) +(defcolorprim :blue) +(defcolorprim :brown) +(defcolorprim :green) +(defcolorprim :white)