169 lines
4.1 KiB
Common Lisp
169 lines
4.1 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* #:setup-builtins #:activate-package
|
|
#:forge-env #:dstack #:exec #:exec-str #:repl
|
|
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
|
|
|
|
(defpackage :sf-builtin)
|
|
(defpackage :sf-user)
|
|
|
|
(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)))
|
|
|
|
;;; forge environment
|
|
|
|
(defclass forge-env ()
|
|
((data-stack :initform nil :accessor data-stack)
|
|
(words :initform (make-hash-table))
|
|
(comp-words :initform (make-hash-table))
|
|
(packages :initform '(:sf-user :sf-builtin))
|
|
(current-package :initform :sf-builtin)
|
|
(rp :initform (make-iseq))
|
|
(cp :initform (make-iseq))
|
|
(ip :initform (make-iseq))))
|
|
|
|
(defun forge-env ()
|
|
(make-instance 'forge-env))
|
|
|
|
(defvar *forge-env* (forge-env))
|
|
|
|
(defun activate-package(p)
|
|
(let ((old (current-package)))
|
|
(setf (slot-value *forge-env* 'current-package) p)
|
|
old))
|
|
|
|
(defun dstack() (data-stack *forge-env*))
|
|
|
|
(defun words () (slot-value *forge-env* 'words))
|
|
|
|
(defun comp-words () (slot-value *forge-env* 'comp-words))
|
|
|
|
(defun register-comp-word (sym fn)
|
|
(register sym fn 'comp-words))
|
|
|
|
(defun register (sym fn &optional (slot 'words))
|
|
(let* ((w (intern (string sym) (current-package)))
|
|
(words (slot-value *forge-env* slot)))
|
|
(setf (gethash w words) fn)))
|
|
|
|
;;; builtins
|
|
|
|
(defmacro reg (sym &body body)
|
|
`(register ',sym #'(lambda () ,@body)))
|
|
|
|
(defun lit () (pushd (isq-next (fip))))
|
|
|
|
(defun setup-builtins ()
|
|
|
|
(reg + (pushd (+ (popd) (popd))))
|
|
(reg * (pushd (* (popd) (popd))))
|
|
|
|
(reg dup (pushd (car (dstack))))
|
|
|
|
(register 'lit #'lit)
|
|
|
|
(register-comp-word 'def
|
|
#'(lambda ()
|
|
(let* ((name (read-next))
|
|
(code (comp (read-next))))
|
|
(register name #'(lambda () (call code))))))
|
|
|
|
(activate-package :sf-user))
|
|
|
|
;;; compiler, interpreter
|
|
|
|
(defun exec-str (s)
|
|
(exec (read-from-string
|
|
(concatenate 'string "(" s ")"))))
|
|
|
|
(defun repl ()
|
|
(do ((input (read-line) (read-line))) ((string= input "q") nil)
|
|
(exec-str input)))
|
|
|
|
(defun exec (code)
|
|
(call (comp code)))
|
|
|
|
(defun call (code)
|
|
(let ((ip (make-iseq code)))
|
|
(setf (slot-value *forge-env* 'ip) ip)
|
|
(do ((item (isq-next ip) (isq-next ip)))
|
|
((null item))
|
|
(funcall item))))
|
|
|
|
(defun comp (slist)
|
|
(setf (slot-value *forge-env* 'cp) (make-iseq))
|
|
(let ((inp (make-iseq slist)))
|
|
(setf (slot-value *forge-env* 'rp) inp)
|
|
(do ((item (isq-next inp) (isq-next inp)))
|
|
((null item))
|
|
(typecase item
|
|
(symbol (comp-symbol item))
|
|
(cons (comp-item #'lit) (comp-item (comp item)))
|
|
(t (comp-item #'lit) (comp-item item)))))
|
|
(isq-all (fcp)))
|
|
|
|
(defun comp-symbol (sym)
|
|
(let* ((w (get-word sym))
|
|
(comp-fn (gethash w (comp-words))))
|
|
(if comp-fn
|
|
(funcall comp-fn)
|
|
(comp-item (gethash w (words))))))
|
|
|
|
(defun get-word (sym)
|
|
(let ((name (string sym)))
|
|
(dolist (p (packages))
|
|
(let ((w (find-symbol name p)))
|
|
(if w
|
|
(return-from get-word w))))))
|
|
|
|
;;; internal definitions / forge-env pseudo-methods
|
|
|
|
(defun popd () (pop (data-stack *forge-env*)))
|
|
|
|
(defun pushd (v) (push v (data-stack *forge-env*)))
|
|
|
|
(defun fcp () (slot-value *forge-env* 'cp))
|
|
|
|
(defun comp-item (item) (isq-add (fcp) item))
|
|
|
|
(defun fip () (slot-value *forge-env* 'ip))
|
|
|
|
(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
|
|
|
|
(defun packages () (slot-value *forge-env* 'packages))
|
|
|
|
(defun current-package () (slot-value *forge-env* 'current-package))
|
|
|