cl-scopes/forge/forge.lisp

;;;; cl-scopes/forge - may the forge be with you!

;;;; A Forth-like interpreter implemented in Common Lisp.

(defpackage :scopes/forge
  (:use :common-lisp)
  (:local-nicknames (:iter :scopes/util/iter)
                    (:util :scopes/util))
  (:export #:forge-env #:vocabulary #:stack #:current-package
           #:*forge-env* #:*input* #:*code*
           #:word #:comp-word
           #:repl #:exec-list #:exec-string #:exec-stream 
           #:exec-input #:comp-input #:call
           #:comp-item
           #:next #:reg #:reg1 #:reg2 #:reg-code
           #:pushd #:popd #:peekd))

(in-package :scopes/forge)

;;;; common definitions

(defclass forge-env ()
  ((vocabulary :reader vocabulary :initform (make-hash-table))
   (func-index :reader func-index :initform (make-hash-table))
   (stack :accessor stack :initform nil)
   (current-package :accessor current-package :initform :sf-builtin)))

(defvar *forge-env* (make-instance 'forge-env))

(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))))

(defgeneric exec-item (it)
  (:method ((it t))
    (pushd it))
  (:method ((it symbol))
    (let ((v (find-word it)))
      (when v
        (exec-item v)))))

(defgeneric comp-item (it)
  (:method ((it t))
    (push #'next *buffer*)
    (push it *buffer*))
  (:method ((it symbol))
    (let ((v (find-word it)))
      (when v
        ;(util:lgi it v)
        (comp-item v)))))

(defun find-word (sym)
  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
    (multiple-value-bind (val found) (gethash sym (vocabulary *forge-env*))
      (when (not found)
        (util:lgw "not found" sym))
      val)))

;;;; 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)))

;;;; code compilation and execution

(defun repl ()
  (do ((input (read-line) (read-line))) 
      ((string= input "q") (stack *forge-env*))
    (exec-string input)))

(defun exec-list (lst)
  (let ((*input* (iter:list-iterator lst)))
    (exec-input)))

(defun exec-string (s)
  (let ((*input* (iter:string-iterator s)))
    (exec-input)))

(defun exec-stream (s)
  (let ((*input* (iter:stream-iterator s)))
    (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)
  ;(util:lgi code)
  (let ((*code* code))
    (do ((fn (pop *code*) (pop *code*)))
        ((null fn))
      (funcall fn))))

(defun reg (sym fn &optional (cls 'word))
  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
    (setf (gethash sym (vocabulary *forge-env*)) (make-instance cls :func fn))
    (setf (gethash fn (func-index *forge-env*)) sym)))

(defun reg1 (sym fn)
  (reg sym #'(lambda () (pushd (funcall fn (popd))))))

(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 *forge-env*)))

(defun popd ()
  (pop (stack *forge-env*)))

(defun peekd ()
  (car (stack *forge-env*)))

(defun next () 
  (pushd (pop *code*)))

;;;; builtins

(defpackage :sf-builtin
  (:use :common-lisp)
  (:local-nicknames (:f :scopes/forge)
                    (:iter :scopes/util/iter)
                    (:util :scopes/util))
  (:export #:add #:mul #:drop #:dup #:swp 
           #:? #:??
           #:ptr #:get #:put
           #:in #:next 
           #:call #:call-if #:call-while #:comp #:val
           #:<comp #:reg #:regc #:/>))

(in-package :sf-builtin)

;;;; implementation functions

(defun call-if ()
  (let ((code (f:popd)))
    (if (f:popd)
      (f:call code))))

(defun call-while ()
  (let ((code (f:popd)))
    (do ((cond (f:popd) (f:popd)))
        ((not cond))
      (f:call code))))

;;;; lisp-code word definitions

(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 'drop #'f:popd)

(f:reg '? #'(lambda () (format t "~a~%" (f:popd))))
(f:reg '?? #'(lambda () (format t "~a~%" (f:stack f:*forge-env*))))

(f:reg1 'ptr #'util:ptr)
(f:reg1 'get #'aref)
(f:reg 'put #'(lambda () (setf (aref (f:popd)) (f:popd))))

(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
(f:reg 'next #'f:next)

(f:reg 'comp #'(lambda () (cons (f:popd) f::*buffer*)))
(f:reg 'call #'(lambda () (f:call (f:popd))))
(f:reg 'call-if #'call-if)
(f:reg 'call-while #'call-while)
(f:reg 'val #'(lambda () (f:pushd (list #'f:next (f:popd)))))

(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)

;;;; forge-code word definitions