103 lines
2.2 KiB
Common Lisp
103 lines
2.2 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*
|
|
#:forge-env #:dstack #:exec #:exec-str #:repl
|
|
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
|
|
|
|
(in-package :scopes/forge)
|
|
|
|
;;; iseq: iterable sequence
|
|
|
|
(defclass iseq ()
|
|
((start :reader start :initform (list nil) :initarg :start)
|
|
(cur :accessor cur)
|
|
(end :accessor end)))
|
|
|
|
(defun make-iseq (&optional start)
|
|
(let* ((start (cons nil start))
|
|
(seq (make-instance 'iseq :start start)))
|
|
(setf (cur seq) (setf (end seq) start))
|
|
seq))
|
|
|
|
(defun isq-all (seq)
|
|
(cdr (start seq)))
|
|
|
|
(defun isq-cur (seq)
|
|
(car (cur seq)))
|
|
|
|
(defun isq-end (seq)
|
|
(car (end seq)))
|
|
|
|
(defun isq-next (seq)
|
|
(pop (cur seq))
|
|
(car (cur seq)))
|
|
|
|
(defun isq-add (seq v)
|
|
(setf (cdr (end seq)) (list v))
|
|
(pop (end seq)))
|
|
(defclass forge-env ()
|
|
((data-stack :initform nil
|
|
:accessor data-stack)
|
|
(cp :initform (make-iseq)
|
|
:accessor cp)
|
|
(ip :initform (make-iseq)
|
|
:accessor ip)))
|
|
|
|
;;; forge environment
|
|
|
|
(defun forge-env ()
|
|
(let ((fe (make-instance 'forge-env)))
|
|
fe))
|
|
|
|
(defvar *forge-env* (forge-env))
|
|
|
|
(defun dstack()
|
|
(data-stack *forge-env*))
|
|
|
|
(defun exec-str (s)
|
|
(exec (read-from-string
|
|
(concatenate 'string "(" s ")"))))
|
|
|
|
(defun exec (code)
|
|
(dolist (x code)
|
|
(typecase x
|
|
(symbol (funcall (comp1 x)))
|
|
(compiled-function (funcall x))
|
|
(t (pushd x)))))
|
|
|
|
(defun call (code)
|
|
(dolist (x code)
|
|
(funcall x)))
|
|
|
|
(defun repl ()
|
|
(do ((input (read-line) (read-line))) ((string= input "q") nil)
|
|
(exec-str input)))
|
|
|
|
(defun find-word (key))
|
|
|
|
(defun comp (inp)
|
|
(let ((code nil))
|
|
(dolist (item inp)
|
|
(setf code (cons (comp1 item) code)))
|
|
(reverse code)))
|
|
|
|
(defun comp1 (item)
|
|
(typecase item
|
|
(symbol (find-word item))
|
|
(cons (comp item))
|
|
(t item)))
|
|
|
|
(defun register (voc key fn)
|
|
(let ((k (if (symbolp key) (symbol-name key) key)))
|
|
(setf (gethash (string-downcase k) voc) fn)))
|
|
|
|
; internal definitions
|
|
|
|
(defun popd () (pop (data-stack *forge-env*)))
|
|
|
|
(defun pushd (v) (push v (data-stack *forge-env*)))
|
|
|