Frank Buss wrote:
> 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, f...@frank-buss.de
> http://www.frank-buss.de, http://www.it4-systems.de
