diff --git a/forge/forge.lisp b/forge/forge.lisp
index be7ed83..ff3c50c 100644
--- a/forge/forge.lisp
+++ b/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
+ #:))
-(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 ' #'(lambda () (iter:stop f:*input*)) 'f:comp-word)
+
+;;;; forge-code word definitions
diff --git a/forge/sf.lisp b/forge/sf.lisp
deleted file mode 100644
index 158820c..0000000
--- a/forge/sf.lisp
+++ /dev/null
@@ -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
- #:))
-
-(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 ' #'(lambda () (iter:stop f:*input*)) 'f:comp-word)
-
-;;;; forge-code word definitions
diff --git a/forge/x-forge.lisp b/forge/x-forge.lisp
new file mode 100644
index 0000000..be7ed83
--- /dev/null
+++ b/forge/x-forge.lisp
@@ -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))
+