My goal is to write an interpreter, which uses a state machine and not the
Common Lisp call stack, because then it is easier to translate it to VHDL.
I think I can simplify the source below a bit, but I like some ideas, which
are inspired from SECD and other implementations:
- there is a variables stack, which stores variable/value pairs, where the
car of a pair is the variable name and the cdr is the value.
- functions are stored in the form (parameterlist . body), e.g. ((list) .
(car (cdr list))) for the cadr function
- if a list instead of a symbol is the car of an expression, it is
interpreted as a function, so you could write this:
(@eval '(((a b) . (cons a b)) 1 2))
and it returns (1 . 2). This is the same like "lambda". I wonder why Common
Lisp has an extra lambda macro for this?
I think with the lambda construct in theory it should be possible to define
a "let" semantic and with this you can write everything you need. But I'll
add a "let" operator (with implicit progn) and a "set" function, to make
programming for this system a bit easier.
What do you think about it?
(defun test ()
(assert (equalp 1 (@eval 1)))
(assert (equalp 3 (@eval '(car (cdr (cdr '(1 2 3)))))))
(assert (equalp '(1 . 2) (@eval '(cons 1 2))))
(assert (equalp '(1 . 2) (@eval '(((a b) . (cons)) 1 2)))))
(defparameter *variables* nil)
(defparameter *data-stack* nil)
(defparameter *state-stack* nil)
(defparameter *eval-stack* nil)
(defparameter *state* nil)
(defparameter *eval-state* nil)
(defparameter *expression* nil)
(defparameter *stop* nil)
(defun lookup-variable (search-name)
(loop for (name . value) in *variables* do
(when (eql name search-name)
(return-from lookup-variable value))))
(defstruct eval-state
parameters
parameter-names
parameter
parameter-name
body
variables-before-function
variables-for-function
function-name)
(defun init-machine ()
(setf *variables* '())
(setf *data-stack* '())
(setf *state-stack* '())
(setf *eval-stack* '())
(setf *state* 'start)
(setf *stop* nil)
(setf *eval-state* nil)
(push '(car . ((list))) *variables*)
(push '(cdr . ((list))) *variables*)
(push '(cadr . ((list) . (car (cdr list)))) *variables*)
(push '(cons . ((a b))) *variables*)
(push '(quote . ((a))) *variables*))
(defun start-state ()
(let ((pop-state t))
(if (atom *expression*)
(if (numberp *expression*)
(push *expression* *data-stack*)
(push (lookup-variable *expression*) *data-stack*))
(let ((function-or-function-name (car *expression*)))
(cond ((consp function-or-function-name)
(let ((parameter-names (car function-or-function-name))
(body (cdr function-or-function-name))
(parameters (cdr *expression*)))
(push *eval-state* *eval-stack*)
(setf *eval-state* (make-eval-state
:function-name nil
:parameters parameters
:parameter-names parameter-names
:body body
:variables-before-function *variables*
:variables-for-function *variables*)
*state* 'eval-parameters
pop-state nil)))
((eql function-or-function-name 'quote)
(push (cadr *expression*) *data-stack*))
(t
(let ((parameters (cdr *expression*))
(function (lookup-variable
function-or-function-name)))
(push *eval-state* *eval-stack*)
(setf *eval-state* (make-eval-state
:function-name function-or-function-name
:parameters parameters
:parameter-names (car function)
:body (cdr function)
:variables-before-function *variables*
:variables-for-function *variables*)
*state* 'eval-parameters
pop-state nil))))))
(when pop-state
(let ((next-state (pop *state-stack*)))
(unless next-state (setf *stop* t))
(setf *state* next-state)))))
(defun eval-parameters-state ()
(setf (eval-state-parameter *eval-state*) (pop (eval-state-parameters
*eval-state*))
(eval-state-parameter-name *eval-state*) (pop
(eval-state-parameter-names *eval-state*)))
(if (and (eval-state-parameter *eval-state*) (eval-state-parameter-name
*eval-state*))
(progn
(push 'set-parameter *state-stack*)
(setf *state* 'start
*expression* (eval-state-parameter *eval-state*)))
(progn
(setf *variables* (eval-state-variables-for-function *eval-state*))
(let ((function-name (eval-state-function-name *eval-state*))
(pop-state t))
(cond ((eql function-name 'car)
(let ((list (lookup-variable 'list)))
(push (car list) *data-stack*)))
((eql function-name 'cdr)
(let ((list (lookup-variable 'list)))
(push (cdr list) *data-stack*)))
((eql function-name 'cons)
(let ((a (lookup-variable 'a))
(b (lookup-variable 'b)))
(push (cons a b) *data-stack*)))
(t
(setf *state* 'start
pop-state nil
*expression* (eval-state-body *eval-state*))))
(when pop-state
(setf *variables* (eval-state-variables-before-function
*eval-state*))
(setf *eval-state* (pop *eval-stack*))
(if *eval-state*
(let ((next-state (pop *state-stack*)))
(unless next-state (setf *stop* t))
(setf *state* next-state))
(setf *stop* t)))))))
(defun set-parameter-state ()
(let ((variable (cons (eval-state-parameter-name *eval-state*) (pop
*data-stack*))))
(push variable (eval-state-variables-for-function *eval-state*)))
(setf *state* 'eval-parameters))
(defun @eval (expression)
(init-machine)
(setf *expression* expression)
(loop with count = 0 do
(incf count)
(when (> count 1000) (return-from @eval "endless loop"))
(cond ((eql *state* 'start)
(start-state))
((eql *state* 'eval-parameters)
(eval-parameters-state))
((eql *state* 'set-parameter)
(set-parameter-state)))
(when *stop* (loop-finish)))
(pop *data-stack*))
--
Frank Buss, ··@frank-buss.de
http://www.frank-buss.de, http://www.it4-systems.de