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
|
(defpackage :scopes/forge
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:export #:*forge-env* #:setup-builtins #:activate-package
|
(:local-nicknames (:iter :scopes/util/iter)
|
||||||
#:forge-env #:dstack #:exec #:exec-str #:repl
|
(:util :scopes/util))
|
||||||
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add
|
(:export #:forge-env #:vocabulary #:stack #:current-package
|
||||||
#:with-trace))
|
#:*forge-env* #:*input* #:*code*
|
||||||
|
#:word #:comp-word
|
||||||
(defpackage :sf-builtin)
|
#:repl #:exec-list #:exec-string #:exec-input #:comp-input #:call
|
||||||
(defpackage :sf-user)
|
#:comp-item
|
||||||
|
#:next #:reg #:reg1 #:reg2 #:reg-code
|
||||||
|
#:pushd #:popd #:peekd))
|
||||||
|
|
||||||
(in-package :scopes/forge)
|
(in-package :scopes/forge)
|
||||||
|
|
||||||
(defmacro with-trace (&body body)
|
;;;; common definitions
|
||||||
`(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 ()
|
(defclass forge-env ()
|
||||||
((data-stack :initform nil :accessor data-stack)
|
((vocabulary :reader vocabulary :initform (make-hash-table))
|
||||||
(words :initform (make-hash-table :test #'eq))
|
(func-index :reader func-index :initform (make-hash-table))
|
||||||
(comp-words :initform (make-hash-table))
|
(stack :accessor stack :initform nil)
|
||||||
(words-rev :initform (make-hash-table))
|
(current-package :accessor current-package :initform :sf-builtin)))
|
||||||
(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 ()
|
(defvar *forge-env* (make-instance 'forge-env))
|
||||||
(make-instance 'forge-env))
|
|
||||||
|
|
||||||
(defvar *forge-env* (forge-env))
|
(defvar *input* nil)
|
||||||
|
(defvar *buffer* nil)
|
||||||
|
(defvar *code* nil)
|
||||||
|
|
||||||
(defun activate-package(p)
|
(defmethod print-object :around ((fn function) s)
|
||||||
(let ((old (current-package)))
|
(let ((sym (gethash fn (func-index *forge-env*))))
|
||||||
(setf (slot-value *forge-env* 'current-package) p)
|
(if sym
|
||||||
old))
|
(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)
|
;;;; class word
|
||||||
(register sym fn :slot 'comp-words :code code))
|
|
||||||
|
|
||||||
(defun register (sym fn &key (slot 'words) code)
|
(defclass word ()
|
||||||
(let* ((w (intern (string sym) (current-package)))
|
((func :reader func :initarg :func)))
|
||||||
(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
|
(defmethod exec-item ((w word))
|
||||||
|
(funcall (func w)))
|
||||||
|
|
||||||
(defmacro reg (sym &body body)
|
(defmethod comp-item ((w word))
|
||||||
`(register ',sym #'(lambda () ,@body)))
|
(push (func w) *buffer*))
|
||||||
|
|
||||||
(defun lit () (pushd (isq-next (fip))))
|
;;;; class comp-word
|
||||||
|
|
||||||
(defun do-reg (&optional (fn #'register))
|
(defclass comp-word (word) ())
|
||||||
(let* ((name (popd))
|
|
||||||
(code (popd)))
|
|
||||||
(funcall fn name #'(lambda () (call code)) :code code)))
|
|
||||||
|
|
||||||
(defun do-quote ()
|
(defmethod comp-item ((w comp-word))
|
||||||
(let ((quoted (read-next)))
|
(funcall (func w)))
|
||||||
#+forge-trace (format t " - do-quote: ~a" quoted)
|
|
||||||
(comp-item #'lit) (comp-item quoted)))
|
|
||||||
|
|
||||||
(defun do-comp ()
|
;;;; code compilation and execution
|
||||||
(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 ()
|
(defun repl ()
|
||||||
(do ((input (read-line) (read-line)))
|
(do ((input (read-line) (read-line)))
|
||||||
((string= input "q") (dstack))
|
((string= input "q") (stack *forge-env*))
|
||||||
(exec-str input)))
|
(exec-string input)))
|
||||||
|
|
||||||
(defun exec (code)
|
(defun exec-list (lst)
|
||||||
(call (comp code)))
|
(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)
|
(defun call (code)
|
||||||
#+forge-trace (trace-call code)
|
(util:lgi code)
|
||||||
(let ((old-ip (fip))
|
(let ((*code* code))
|
||||||
(ip (make-iseq code)))
|
(do ((fn (pop *code*) (pop *code*)))
|
||||||
(setf (slot-value *forge-env* 'ip) ip)
|
((null fn))
|
||||||
(do ((item (isq-next ip) (isq-next ip)))
|
(funcall fn))))
|
||||||
((null item))
|
|
||||||
(funcall item))
|
|
||||||
(setf (slot-value *forge-env* 'ip) old-ip)
|
|
||||||
#+forge-trace (format t "~% - stack: ~A" (dstack))
|
|
||||||
(dstack)))
|
|
||||||
|
|
||||||
(defun comp (slist)
|
(defun reg (sym fn &optional (cls 'word))
|
||||||
#+forge-trace (format t "~%comp: ~a" slist)
|
(let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
|
||||||
(let ((cp (make-iseq))
|
(setf (gethash sym (vocabulary *forge-env*)) (make-instance cls :func fn))
|
||||||
(inp (make-iseq slist)))
|
(setf (gethash fn (func-index *forge-env*)) sym)))
|
||||||
(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)
|
(defun reg1 (sym fn)
|
||||||
(let* ((w (get-word sym))
|
(reg sym #'(lambda () (pushd (funcall fn (popd))))))
|
||||||
(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)
|
(defun reg2 (sym fn)
|
||||||
(let ((name (string sym)))
|
(reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
|
||||||
(dolist (p (packages))
|
|
||||||
(let ((w (find-symbol name p)))
|
|
||||||
(if w
|
|
||||||
(return-from get-word w))))))
|
|
||||||
|
|
||||||
;;; 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