93 lines
2.4 KiB
Common Lisp
93 lines
2.4 KiB
Common Lisp
;;; cl-scopes/forge - may the forge be with you!
|
|
|
|
;;;; A Forth-like interpreter implemented in Common Lisp.
|
|
|
|
(defpackage :scopes/forge
|
|
(:use :common-lisp)
|
|
(:export #:forge-env #:data-stack #:exec #:exec-str #:repl))
|
|
|
|
(in-package :scopes/forge)
|
|
|
|
(defvar *builtins* (make-hash-table :test 'equalp))
|
|
|
|
(defclass forge-env ()
|
|
((data-stack :initform nil
|
|
:reader data-stack
|
|
:accessor data-stack!)
|
|
(vocabulary :initform (list *builtins*)
|
|
:accessor vocabulary)))
|
|
|
|
(defun forge-env ()
|
|
(let ((fe (make-instance 'forge-env)))
|
|
(push (make-hash-table :test 'equalp) (vocabulary fe))
|
|
fe))
|
|
|
|
(defun exec-str (fe s)
|
|
(exec fe (read-from-string
|
|
(concatenate 'string "(" s ")"))))
|
|
|
|
(defun exec (fe code)
|
|
(dolist (x code)
|
|
(if (symbolp x)
|
|
(funcall (find-word (vocabulary fe) x) fe)
|
|
(pushd fe x))))
|
|
|
|
(defun register (voc key fn)
|
|
(let ((k (if (symbolp key) (symbol-name key) key)))
|
|
(setf (gethash (string-downcase k) voc) fn)))
|
|
|
|
(defun find-word (vocab key)
|
|
(let ((k (string-downcase (symbol-name key))) (result nil))
|
|
(dolist (voc vocab)
|
|
(let ((v (gethash k voc)))
|
|
(if v (return v))))))
|
|
|
|
(defun repl (fe)
|
|
(do ((input (read-line) (read-line))) ((string= input "q") nil)
|
|
(exec-str fe input)))
|
|
|
|
; built-in primitives
|
|
|
|
(defun reg-b (key fn) (register *builtins* key fn))
|
|
|
|
(reg-b "+" #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe)))))
|
|
(reg-b "*" #'(lambda (fe) (pushd fe (* (popd fe) (popd fe)))))
|
|
|
|
(reg-b "dup" #'(lambda (fe) (pushd fe (car (data-stack fe)))))
|
|
|
|
(reg-b "?" #'(lambda (fe) (format t "~a~%" (popd fe))))
|
|
(reg-b "??" #'(lambda (fe) (format t "~a~%" (data-stack fe))))
|
|
|
|
(reg-b "def" #'(lambda (fe)
|
|
(let ((name (popd fe))
|
|
(code (popd fe)))
|
|
(register (voc fe) name #'(lambda (fe) (exec fe code))))))
|
|
|
|
(reg-b "const" #'(lambda (fe)
|
|
(let ((name (popd fe))
|
|
(value (popd fe)))
|
|
(register (voc fe) name #'(lambda (fe) (pushd fe value))))))
|
|
|
|
(reg-b "var" #'(lambda (fe)
|
|
(let ((name (popd fe))
|
|
(var (list (popd fe))))
|
|
(register (voc fe) name #'(lambda (fe)
|
|
(pushd fe #'(lambda (fn)
|
|
(funcall fn var))))))))
|
|
|
|
(reg-b "get" #'(lambda (fe)
|
|
(funcall (popd fe) #'(lambda (x) (pushd fe (car x))))))
|
|
|
|
(reg-b "put" #'(lambda (fe)
|
|
(let ((fn (popd fe))
|
|
(vl (popd fe)))
|
|
(funcall fn #'(lambda (x) (setf (car x) vl))))))
|
|
|
|
; internal definitions
|
|
|
|
(defun voc (fe) (car (vocabulary fe)))
|
|
|
|
(defun popd (fe) (pop (data-stack! fe)))
|
|
|
|
(defun pushd (fe v) (push v (data-stack! fe)))
|
|
|