148 lines
3.6 KiB
Common Lisp
148 lines
3.6 KiB
Common Lisp
;;;; cl-scopes/forge - may the forge be with you!
|
|
|
|
;;;; A Forth-like interpreter implemented in Common Lisp.
|
|
|
|
(defpackage :scopes/forge/sf
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:iter :scopes/util/iter)
|
|
(:util :scopes/util))
|
|
(:export #:forge-env #:vocabulary #:stack
|
|
#:*forge-env* #:*stack* #:*input* #:*code*
|
|
#:word #:comp-word
|
|
#:exec-list #:exec-input #:comp-input #:call
|
|
#:comp-item
|
|
#:lit #:reg #:reg2 #:reg-code
|
|
#:pushd #:popd #:peekd))
|
|
|
|
(in-package :scopes/forge/sf)
|
|
|
|
(defclass forge-env ()
|
|
((vocabulary :reader vocabulary :initform (make-hash-table))
|
|
(func-index :reader func-index :initform (make-hash-table))
|
|
(stack :reader stack :initform nil)))
|
|
|
|
(defvar *forge-env* (make-instance 'forge-env))
|
|
|
|
(defvar *stack* nil)
|
|
(defvar *input* nil)
|
|
(defvar *buffer* nil)
|
|
(defvar *code* nil)
|
|
|
|
(defmethod print-object :around ((fn function) s)
|
|
(let ((sym (gethash fn (func-index *forge-env*))))
|
|
(if sym
|
|
(print-unreadable-object (fn s) (format s "~s" sym))
|
|
(call-next-method))))
|
|
|
|
;;;; core definitions
|
|
|
|
(defgeneric exec-item (it)
|
|
(:method ((it t))
|
|
(pushd it))
|
|
(:method ((it symbol))
|
|
(let ((v (symbol-value it)))
|
|
(when v
|
|
(exec-item v)))))
|
|
|
|
(defgeneric comp-item (it)
|
|
(:method ((it t))
|
|
(push #'lit *buffer*)
|
|
(push it *buffer*))
|
|
(:method ((it symbol))
|
|
(let ((v (symbol-value it)))
|
|
(when v
|
|
;(util:lgi it v)
|
|
(comp-item v)))))
|
|
|
|
;;;; class word*
|
|
|
|
(defclass word ()
|
|
((func :reader func :initarg :func)))
|
|
|
|
(defmethod exec-item ((w word))
|
|
(funcall (func w)))
|
|
|
|
(defmethod comp-item ((w word))
|
|
(push (func w) *buffer*))
|
|
|
|
;;;; class comp-word
|
|
|
|
(defclass comp-word (word) ())
|
|
|
|
(defmethod comp-item ((w comp-word))
|
|
(funcall (func w)))
|
|
|
|
;;;; functions
|
|
|
|
(defun exec-list (lst)
|
|
(let ((*input* (make-instance 'iter:list-iterator :data lst)))
|
|
(exec-input)))
|
|
|
|
(defun exec-input ()
|
|
(iter:process *input* #'exec-item))
|
|
|
|
(defun comp-input ()
|
|
(let ((*buffer* nil))
|
|
(iter:process *input* #'comp-item)
|
|
(pushd (reverse *buffer*))))
|
|
|
|
(defun call (code)
|
|
(let ((*code* (make-instance 'iter:list-iterator :data code)))
|
|
;(util:lgi code)
|
|
(iter:process *code* #'funcall)))
|
|
|
|
(defun reg (sym fn &optional (cls 'word))
|
|
(setf (symbol-value sym) (make-instance cls :func fn))
|
|
(setf (gethash fn (func-index *forge-env*)) sym))
|
|
|
|
(defun reg2 (sym fn)
|
|
(reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
|
|
|
|
(defun reg-code (&optional (cls 'word))
|
|
(let* ((name (popd))
|
|
(code (popd)))
|
|
(reg name #'(lambda () (call code)) cls)))
|
|
|
|
(defun pushd (v)
|
|
(push v *stack*))
|
|
|
|
(defun popd ()
|
|
(pop *stack*))
|
|
|
|
(defun peekd ()
|
|
(car *stack*))
|
|
|
|
(defun lit ()
|
|
(pushd (iter:next-value *code*)))
|
|
|
|
;;;; builtins
|
|
|
|
(defpackage :sf-builtin
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:f :scopes/forge/sf)
|
|
(:iter :scopes/util/iter))
|
|
(:export #:add #:mul #:dup #:swp #:in #:? #:lit
|
|
#:comp-pop #:comp-in #:comp
|
|
#:<comp #:reg #:regc #:/>))
|
|
|
|
(in-package :sf-builtin)
|
|
|
|
(f:reg2 'add #'+)
|
|
(f:reg2 'mul #'*)
|
|
|
|
(f:reg 'dup #'(lambda () (f:pushd (f:peekd))))
|
|
(f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b))))
|
|
|
|
(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
|
|
(f:reg 'lit #'f:lit)
|
|
|
|
(f:reg 'comp-pop #'(lambda () (f:comp-item (popd))))
|
|
(f:reg 'comp-in #'(lambda () (f:comp-item (iter:next-value f:*input*))))
|
|
(f:reg 'comp #'(lambda () (f:comp-item (iter:next-value f:*code*))))
|
|
|
|
(f:reg '<comp #'f:comp-input)
|
|
|
|
(f:reg 'reg #'f:reg-code)
|
|
(f:reg 'regc #'(lambda () (f:reg-code 'f:comp-word)))
|
|
|
|
(f:reg '/> #'(lambda () (iter:stop f:*input*)) 'f:comp-word)
|