forge: make forge/sf the standard forge package; keep old files as x-... for reference
This commit is contained in:
parent
78b7eb0e1b
commit
6ed436f94f
3 changed files with 380 additions and 380 deletions
336
forge/forge.lisp
336
forge/forge.lisp
|
|
@ -4,221 +4,197 @@
|
|||
|
||||
(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
|
||||
#:with-trace))
|
||||
|
||||
(defpackage :sf-builtin)
|
||||
(defpackage :sf-user)
|
||||
(: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-input #:comp-input #:call
|
||||
#:comp-item
|
||||
#:next #:reg #:reg1 #:reg2 #:reg-code
|
||||
#:pushd #:popd #:peekd))
|
||||
|
||||
(in-package :scopes/forge)
|
||||
|
||||
(defmacro with-trace (&body body)
|
||||
`(let ((*features* (cons :forge-trace *features*))) ,@body))
|
||||
|
||||
;;; 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
|
||||
;;;; common definitions
|
||||
|
||||
(defclass forge-env ()
|
||||
((data-stack :initform nil :accessor data-stack)
|
||||
(words :initform (make-hash-table :test #'eq))
|
||||
(comp-words :initform (make-hash-table))
|
||||
(words-rev :initform (make-hash-table))
|
||||
(words-meta :initform (make-hash-table))
|
||||
(packages :initform '(:sf-user :sf-builtin))
|
||||
(current-package :initform :sf-builtin)
|
||||
(ip :initform (make-iseq))
|
||||
(rp) (cp)))
|
||||
((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)))
|
||||
|
||||
(defun forge-env ()
|
||||
(make-instance 'forge-env))
|
||||
(defvar *forge-env* (make-instance 'forge-env))
|
||||
|
||||
(defvar *forge-env* (forge-env))
|
||||
(defvar *input* nil)
|
||||
(defvar *buffer* nil)
|
||||
(defvar *code* nil)
|
||||
|
||||
(defun activate-package(p)
|
||||
(let ((old (current-package)))
|
||||
(setf (slot-value *forge-env* 'current-package) p)
|
||||
old))
|
||||
(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))))
|
||||
|
||||
(defun dstack() (data-stack *forge-env*))
|
||||
(defgeneric exec-item (it)
|
||||
(:method ((it t))
|
||||
(pushd it))
|
||||
(:method ((it symbol))
|
||||
(let ((v (find-word it)))
|
||||
(when v
|
||||
(exec-item v)))))
|
||||
|
||||
(defun words () (slot-value *forge-env* 'words))
|
||||
(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 comp-words () (slot-value *forge-env* 'comp-words))
|
||||
(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)))
|
||||
|
||||
(defun register-comp-word (sym fn &key code)
|
||||
(register sym fn :slot 'comp-words :code code))
|
||||
;;;; class word
|
||||
|
||||
(defun register (sym fn &key (slot 'words) code)
|
||||
(let* ((w (intern (string sym) (current-package)))
|
||||
(words (slot-value *forge-env* slot)))
|
||||
(setf (gethash w words) fn)
|
||||
(setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
|
||||
(if code
|
||||
(setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
|
||||
(defclass word ()
|
||||
((func :reader func :initarg :func)))
|
||||
|
||||
;;; builtins
|
||||
(defmethod exec-item ((w word))
|
||||
(funcall (func w)))
|
||||
|
||||
(defmacro reg (sym &body body)
|
||||
`(register ',sym #'(lambda () ,@body)))
|
||||
(defmethod comp-item ((w word))
|
||||
(push (func w) *buffer*))
|
||||
|
||||
(defun lit () (pushd (isq-next (fip))))
|
||||
;;;; class comp-word
|
||||
|
||||
(defun do-reg (&optional (fn #'register))
|
||||
(let* ((name (popd))
|
||||
(code (popd)))
|
||||
(funcall fn name #'(lambda () (call code)) :code code)))
|
||||
(defclass comp-word (word) ())
|
||||
|
||||
(defun do-quote ()
|
||||
(let ((quoted (read-next)))
|
||||
#+forge-trace (format t " - do-quote: ~a" quoted)
|
||||
(comp-item #'lit) (comp-item quoted)))
|
||||
(defmethod comp-item ((w comp-word))
|
||||
(funcall (func w)))
|
||||
|
||||
(defun do-comp ()
|
||||
(let* ((sym (read-next))
|
||||
(w (get-word sym)))
|
||||
;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
|
||||
(comp-item (gethash w (comp-words)))))
|
||||
|
||||
(defun setup-builtins ()
|
||||
(register 'lit #'lit)
|
||||
(register 'reg #'do-reg)
|
||||
|
||||
(reg + (pushd (+ (popd) (popd))))
|
||||
(reg * (pushd (* (popd) (popd))))
|
||||
(reg dup (pushd (car (dstack))))
|
||||
(reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
|
||||
(reg ? (format t "~a~%" (popd)))
|
||||
(reg ?? (format t "~a~%" (dstack)))
|
||||
(reg get (pushd (cadr (popd))))
|
||||
(reg set (setf (cadr (popd)) (popd)))
|
||||
(reg wrap (pushd (list #'lit (popd))))
|
||||
(reg defer (comp-item (isq-next (fip))))
|
||||
(reg regc (do-reg #'register-comp-word))
|
||||
|
||||
(register-comp-word 'quote #'do-quote)
|
||||
(register-comp-word 'comp #'do-comp)
|
||||
|
||||
(activate-package :sf-user))
|
||||
|
||||
;;; trace functionality
|
||||
|
||||
(defun decompile-item (item)
|
||||
(or (gethash item (slot-value *forge-env* 'words-rev))
|
||||
(typecase item
|
||||
(cons (decompile item))
|
||||
(t item))))
|
||||
|
||||
(defun decompile (code)
|
||||
(mapcar #'decompile-item code))
|
||||
|
||||
(defun trace-call (code)
|
||||
(format t "~%call: ~a" (decompile code)))
|
||||
|
||||
;;; compiler, interpreter
|
||||
|
||||
(defun exec-str (s)
|
||||
(exec (read-from-string
|
||||
(concatenate 'string "(" s ")"))))
|
||||
;;;; code compilation and execution
|
||||
|
||||
(defun repl ()
|
||||
(do ((input (read-line) (read-line)))
|
||||
((string= input "q") (dstack))
|
||||
(exec-str input)))
|
||||
((string= input "q") (stack *forge-env*))
|
||||
(exec-string input)))
|
||||
|
||||
(defun exec (code)
|
||||
(call (comp code)))
|
||||
(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-input ()
|
||||
(iter:process *input* #'exec-item))
|
||||
|
||||
(defun comp-input ()
|
||||
(let ((*buffer* nil))
|
||||
(iter:process *input* #'comp-item)
|
||||
(pushd (reverse *buffer*))))
|
||||
|
||||
(defun call (code)
|
||||
#+forge-trace (trace-call code)
|
||||
(let ((old-ip (fip))
|
||||
(ip (make-iseq code)))
|
||||
(setf (slot-value *forge-env* 'ip) ip)
|
||||
(do ((item (isq-next ip) (isq-next ip)))
|
||||
((null item))
|
||||
(funcall item))
|
||||
(setf (slot-value *forge-env* 'ip) old-ip)
|
||||
#+forge-trace (format t "~% - stack: ~A" (dstack))
|
||||
(dstack)))
|
||||
(util:lgi code)
|
||||
(let ((*code* code))
|
||||
(do ((fn (pop *code*) (pop *code*)))
|
||||
((null fn))
|
||||
(funcall fn))))
|
||||
|
||||
(defun comp (slist)
|
||||
#+forge-trace (format t "~%comp: ~a" slist)
|
||||
(let ((cp (make-iseq))
|
||||
(inp (make-iseq slist)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(do ((item (isq-next inp) (isq-next inp)))
|
||||
((null item))
|
||||
(typecase item
|
||||
(symbol (comp-symbol item))
|
||||
(cons (let ((sub (comp item)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(comp-item #'lit)
|
||||
(comp-item sub)))
|
||||
(t (comp-item #'lit) (comp-item item)))))
|
||||
(isq-all (fcp)))
|
||||
(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 comp-symbol (sym)
|
||||
(let* ((w (get-word sym))
|
||||
(comp-fn (gethash w (comp-words))))
|
||||
;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
|
||||
(if comp-fn
|
||||
(funcall comp-fn)
|
||||
(comp-item (gethash w (words))))))
|
||||
(defun reg1 (sym fn)
|
||||
(reg sym #'(lambda () (pushd (funcall fn (popd))))))
|
||||
|
||||
(defun get-word (sym)
|
||||
(let ((name (string sym)))
|
||||
(dolist (p (packages))
|
||||
(let ((w (find-symbol name p)))
|
||||
(if w
|
||||
(return-from get-word w))))))
|
||||
(defun reg2 (sym fn)
|
||||
(reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
|
||||
|
||||
;;; internal definitions / forge-env pseudo-methods
|
||||
(defun reg-code (&optional (cls 'word))
|
||||
(let* ((name (popd))
|
||||
(code (popd)))
|
||||
(reg name #'(lambda () (call code)) cls)))
|
||||
|
||||
(defun popd () (pop (data-stack *forge-env*)))
|
||||
(defun pushd (v)
|
||||
(push v (stack *forge-env*)))
|
||||
|
||||
(defun pushd (v) (push v (data-stack *forge-env*)))
|
||||
(defun popd ()
|
||||
(pop (stack *forge-env*)))
|
||||
|
||||
(defun fcp () (slot-value *forge-env* 'cp))
|
||||
(defun peekd ()
|
||||
(car (stack *forge-env*)))
|
||||
|
||||
(defun comp-item (item) (isq-add (fcp) item))
|
||||
(defun next ()
|
||||
(pushd (pop *code*)))
|
||||
|
||||
(defun fip () (slot-value *forge-env* 'ip))
|
||||
;;;; builtins
|
||||
|
||||
(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
|
||||
(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 #:val
|
||||
#:<comp #:reg #:regc #:/>))
|
||||
|
||||
(defun packages () (slot-value *forge-env* 'packages))
|
||||
(in-package :sf-builtin)
|
||||
|
||||
(defun current-package () (slot-value *forge-env* 'current-package))
|
||||
;;;; 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 'call #'(lambda () (f:call (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
|
||||
|
|
|
|||
200
forge/sf.lisp
200
forge/sf.lisp
|
|
@ -1,200 +0,0 @@
|
|||
;;;; 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 #:current-package
|
||||
#:*forge-env* #:*input* #:*code*
|
||||
#:word #:comp-word
|
||||
#:repl #:exec-list #:exec-string #:exec-input #:comp-input #:call
|
||||
#:comp-item
|
||||
#:next #:reg #:reg1 #:reg2 #:reg-code
|
||||
#:pushd #:popd #:peekd))
|
||||
|
||||
(in-package :scopes/forge/sf)
|
||||
|
||||
;;;; 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-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/sf)
|
||||
(:iter :scopes/util/iter)
|
||||
(:util :scopes/util))
|
||||
(:export #:add #:mul #:drop #:dup #:swp
|
||||
#:? #:??
|
||||
#:ptr #:get #:put
|
||||
#:in #:next
|
||||
#:call #:call-if #:call-while #: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 'call #'(lambda () (f:call (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
|
||||
224
forge/x-forge.lisp
Normal file
224
forge/x-forge.lisp
Normal file
|
|
@ -0,0 +1,224 @@
|
|||
;;;; 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
|
||||
#:with-trace))
|
||||
|
||||
(defpackage :sf-builtin)
|
||||
(defpackage :sf-user)
|
||||
|
||||
(in-package :scopes/forge)
|
||||
|
||||
(defmacro with-trace (&body body)
|
||||
`(let ((*features* (cons :forge-trace *features*))) ,@body))
|
||||
|
||||
;;; 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 :test #'eq))
|
||||
(comp-words :initform (make-hash-table))
|
||||
(words-rev :initform (make-hash-table))
|
||||
(words-meta :initform (make-hash-table))
|
||||
(packages :initform '(:sf-user :sf-builtin))
|
||||
(current-package :initform :sf-builtin)
|
||||
(ip :initform (make-iseq))
|
||||
(rp) (cp)))
|
||||
|
||||
(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 &key code)
|
||||
(register sym fn :slot 'comp-words :code code))
|
||||
|
||||
(defun register (sym fn &key (slot 'words) code)
|
||||
(let* ((w (intern (string sym) (current-package)))
|
||||
(words (slot-value *forge-env* slot)))
|
||||
(setf (gethash w words) fn)
|
||||
(setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
|
||||
(if code
|
||||
(setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
|
||||
|
||||
;;; builtins
|
||||
|
||||
(defmacro reg (sym &body body)
|
||||
`(register ',sym #'(lambda () ,@body)))
|
||||
|
||||
(defun lit () (pushd (isq-next (fip))))
|
||||
|
||||
(defun do-reg (&optional (fn #'register))
|
||||
(let* ((name (popd))
|
||||
(code (popd)))
|
||||
(funcall fn name #'(lambda () (call code)) :code code)))
|
||||
|
||||
(defun do-quote ()
|
||||
(let ((quoted (read-next)))
|
||||
#+forge-trace (format t " - do-quote: ~a" quoted)
|
||||
(comp-item #'lit) (comp-item quoted)))
|
||||
|
||||
(defun do-comp ()
|
||||
(let* ((sym (read-next))
|
||||
(w (get-word sym)))
|
||||
;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
|
||||
(comp-item (gethash w (comp-words)))))
|
||||
|
||||
(defun setup-builtins ()
|
||||
(register 'lit #'lit)
|
||||
(register 'reg #'do-reg)
|
||||
|
||||
(reg + (pushd (+ (popd) (popd))))
|
||||
(reg * (pushd (* (popd) (popd))))
|
||||
(reg dup (pushd (car (dstack))))
|
||||
(reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
|
||||
(reg ? (format t "~a~%" (popd)))
|
||||
(reg ?? (format t "~a~%" (dstack)))
|
||||
(reg get (pushd (cadr (popd))))
|
||||
(reg set (setf (cadr (popd)) (popd)))
|
||||
(reg wrap (pushd (list #'lit (popd))))
|
||||
(reg defer (comp-item (isq-next (fip))))
|
||||
(reg regc (do-reg #'register-comp-word))
|
||||
|
||||
(register-comp-word 'quote #'do-quote)
|
||||
(register-comp-word 'comp #'do-comp)
|
||||
|
||||
(activate-package :sf-user))
|
||||
|
||||
;;; trace functionality
|
||||
|
||||
(defun decompile-item (item)
|
||||
(or (gethash item (slot-value *forge-env* 'words-rev))
|
||||
(typecase item
|
||||
(cons (decompile item))
|
||||
(t item))))
|
||||
|
||||
(defun decompile (code)
|
||||
(mapcar #'decompile-item code))
|
||||
|
||||
(defun trace-call (code)
|
||||
(format t "~%call: ~a" (decompile code)))
|
||||
|
||||
;;; compiler, interpreter
|
||||
|
||||
(defun exec-str (s)
|
||||
(exec (read-from-string
|
||||
(concatenate 'string "(" s ")"))))
|
||||
|
||||
(defun repl ()
|
||||
(do ((input (read-line) (read-line)))
|
||||
((string= input "q") (dstack))
|
||||
(exec-str input)))
|
||||
|
||||
(defun exec (code)
|
||||
(call (comp code)))
|
||||
|
||||
(defun call (code)
|
||||
#+forge-trace (trace-call code)
|
||||
(let ((old-ip (fip))
|
||||
(ip (make-iseq code)))
|
||||
(setf (slot-value *forge-env* 'ip) ip)
|
||||
(do ((item (isq-next ip) (isq-next ip)))
|
||||
((null item))
|
||||
(funcall item))
|
||||
(setf (slot-value *forge-env* 'ip) old-ip)
|
||||
#+forge-trace (format t "~% - stack: ~A" (dstack))
|
||||
(dstack)))
|
||||
|
||||
(defun comp (slist)
|
||||
#+forge-trace (format t "~%comp: ~a" slist)
|
||||
(let ((cp (make-iseq))
|
||||
(inp (make-iseq slist)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(do ((item (isq-next inp) (isq-next inp)))
|
||||
((null item))
|
||||
(typecase item
|
||||
(symbol (comp-symbol item))
|
||||
(cons (let ((sub (comp item)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(comp-item #'lit)
|
||||
(comp-item sub)))
|
||||
(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))))
|
||||
;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
|
||||
(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))
|
||||
|
||||
Loading…
Add table
Reference in a new issue