80 lines
2.7 KiB
Common Lisp
80 lines
2.7 KiB
Common Lisp
|
(in-package #:cl-forth)
|
||
|
|
|
||
|
|
(defun with-stack-args (interpreter func)
|
||
|
|
"Pop two values from the stack and apply FUNC to them."
|
||
|
|
(let ((b (pop-from-stack (stack-of interpreter)))
|
||
|
|
(a (pop-from-stack (stack-of interpreter))))
|
||
|
|
(funcall func a b)))
|
||
|
|
|
||
|
|
(defun dup (interpreter)
|
||
|
|
"Duplicate the top number on the stack."
|
||
|
|
(let ((top (peek-stack (stack-of interpreter))))
|
||
|
|
(push-to-stack (stack-of interpreter) top)))
|
||
|
|
|
||
|
|
(defun swap (interpreter)
|
||
|
|
"Swap the top two numbers on the stack."
|
||
|
|
(let ((a (pop-from-stack (stack-of interpreter)))
|
||
|
|
(b (pop-from-stack (stack-of interpreter))))
|
||
|
|
(push-to-stack (stack-of interpreter) a)
|
||
|
|
(push-to-stack (stack-of interpreter) b)))
|
||
|
|
|
||
|
|
(defun add (interpreter)
|
||
|
|
"Add the top two numbers on the stack."
|
||
|
|
(with-stack-args interpreter
|
||
|
|
(lambda (a b)
|
||
|
|
(push-to-stack (stack-of interpreter) (+ a b)))))
|
||
|
|
|
||
|
|
(defun subtract (interpreter)
|
||
|
|
"Subtract the top two numbers on the stack."
|
||
|
|
(with-stack-args interpreter
|
||
|
|
(lambda (a b)
|
||
|
|
(push-to-stack (stack-of interpreter) (- a b)))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
(defun multiply (interpreter)
|
||
|
|
"Multiply the top two numbers on the stack."
|
||
|
|
(with-stack-args interpreter
|
||
|
|
(lambda (a b)
|
||
|
|
(push-to-stack (stack-of interpreter) (* a b)))))
|
||
|
|
|
||
|
|
(defun divide (interpreter)
|
||
|
|
"Divide the second top number by the top number on the stack."
|
||
|
|
(with-stack-args interpreter
|
||
|
|
(lambda (a b)
|
||
|
|
(if (zerop a)
|
||
|
|
(error "Division by zero")
|
||
|
|
(push-to-stack (stack-of interpreter) (/ b a))))))
|
||
|
|
|
||
|
|
(defun my-mod (interpreter)
|
||
|
|
"Compute the modulus of the second top number by the top number on the stack."
|
||
|
|
(with-stack-args interpreter
|
||
|
|
(lambda (a b)
|
||
|
|
(if (zerop a)
|
||
|
|
(error "Division by zero")
|
||
|
|
(push-to-stack (stack-of interpreter) (mod b a))))))
|
||
|
|
|
||
|
|
(defun negate (interpreter)
|
||
|
|
"Negate the top number on the stack."
|
||
|
|
(let ((top (pop-from-stack (stack-of interpreter))))
|
||
|
|
(push-to-stack (stack-of interpreter) (- top))))
|
||
|
|
|
||
|
|
(defun drop (interpreter)
|
||
|
|
"Remove the top number from the stack."
|
||
|
|
(pop-from-stack (stack-of interpreter)))
|
||
|
|
|
||
|
|
(defun over (interpreter)
|
||
|
|
"Copy the second top number to the top of the stack."
|
||
|
|
(let ((a (pop-from-stack (stack-of interpreter)))
|
||
|
|
(b (peek-stack (stack-of interpreter))))
|
||
|
|
(push-to-stack (stack-of interpreter) a)
|
||
|
|
(push-to-stack (stack-of interpreter) b)))
|
||
|
|
|
||
|
|
(defun rot (interpreter)
|
||
|
|
"Rotate the top three numbers on the stack."
|
||
|
|
(let ((a (pop-from-stack (stack-of interpreter)))
|
||
|
|
(b (pop-from-stack (stack-of interpreter)))
|
||
|
|
(c (pop-from-stack (stack-of interpreter))))
|
||
|
|
(push-to-stack (stack-of interpreter) b)
|
||
|
|
(push-to-stack (stack-of interpreter) a)
|
||
|
|
(push-to-stack (stack-of interpreter) c)))
|