test stuff, also vocab works it looks like. lovely

2 files changed, 65 insertions, 4 deletions

diff --git a/sanctuary.fs b/sanctuary.fs
index ad743d2..44153d0 100644
--- a/sanctuary.fs
+++ b/sanctuary.fs
@@ -98,6 +98,9 @@ decimal
 \ todo doc
 : /string ( a1 u1 n -- a2 u2 )  tuck - >r + r> ;
 
+\ todo doc
+: depth  sp0 @ sp - cell- 8 / ;
+
 \ DEFER {{{
 \ todo ['] abort → ['] ?defer or something (where ?defer yields an appropriate error)
 : defer  parse-name (header) latest !
@@ -290,6 +293,9 @@ create line-buffers->in		#buffers cells allot
 	cbuffer cbuffer->in @ + c@
 	cbuffer->in @ 1+ cbuffer->in ! ;
 
+\ todo doc
+: source ( -- a u )  cline cline-used @ ;
+
 private{
 0 value #read
 0 value #read-limit
@@ -386,7 +392,6 @@ privatise
 : unloop  postpone rdrop postpone rdrop ; immediate compile-only
 \ }}}
 
-\ todo doc
 \ VOCABULARY {{{
 \ todo doc
 \ based on the forth standard word list reference implementations
@@ -430,7 +435,7 @@ defer default-wordlist
 : set-current ( wid -- )  current ! ;
 
 : discard ( x1 xn u -- )  0 ?do drop loop ;
-: definitions  get-order swap set-current discard ;
+: definitions  get-order swap set-current 1- discard ;
 : previous  get-order nip 1- set-order ;
 : only  -1 set-order ;
 : also  get-order over swap 1+ set-order ;
@@ -450,8 +455,6 @@ forth-wordlist (vocabulary) forth
 	until
 	2drop 0 ;
 
-\ find (header) : ; smudge immediate compile-only
-
 : (find) ( a u -- a u 0 | ht -1 )
 	#order @ 0 ?do
 		2dup i cells context + @ ( a u a u wid )
@@ -489,6 +492,63 @@ execute
 \ drop
 \ }}}
 
+\ TEST SUITE {{{
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ modified tho:
+\ - put into lowercase
+\ - { } → T{ }T
+
+hex
+
+\ set the following flag to true for more verbose output; this may
+\ allow you to tell which test caused your system to hang.
+variable verbose
+   false verbose !
+
+: empty-stack	\ ( ... -- ) empty stack: handles underflowed stack too.
+   depth ?dup if dup 0< if negate 0 do 0 loop else 0 do drop loop then then ;
+
+: error		\ ( c-addr u -- ) display an error message followed by
+		\ the line that had the error.
+   type source type cr			\ display line corresponding to error
+   empty-stack				\ throw away every thing else
+;
+
+variable actual-depth			\ stack record
+create actual-results 20 cells allot
+
+: t{		\ ( -- ) syntactic sugar.
+   ;
+
+: ->		\ ( ... -- ) record depth and content of stack.
+   depth dup actual-depth !		\ record depth
+   ?dup if				\ if there is something on stack
+      0 do actual-results i cells + ! loop \ save them
+   then ;
+
+: }t		\ ( ... -- ) compare stack (expected) contents with saved
+		\ (actual) contents.
+   depth actual-depth @ = if		\ if depths match
+      depth ?dup if			\ if there is something on the stack
+         0 do				\ for each stack item
+	    actual-results i cells + @	\ compare actual with expected
+	    <> if s" incorrect result: " error leave then
+	 loop
+      then
+   else					\ depth mismatch
+      s" wrong number of results: " error
+   then ;
+
+: testing	\ ( -- ) talking comment.
+   source verbose @
+   if dup >r type cr r> >in !
+   else >in ! drop
+   then ;
+
+decimal
+\ }}}
+
 \ PROGRAMMING TOOLS {{{
 \ should write top of stack on right
 \ : .s  ;
diff --git a/sanctuary.s b/sanctuary.s
index 83b924e..3df31ba 100644
--- a/sanctuary.s
+++ b/sanctuary.s
@@ -1288,6 +1288,7 @@ defcode "HEREDUMP", heredump, 0
 
 defvar "state", state, 0, INTERPRET
 defvar "base", base, 0, 10
+defvar "sp0", sp0, 0, wstk ; todo doc
 defvar "rp0", rp0, 0, 0
 defvar "dp", dp, 0, 0
 defvar "dp0", dp0, 0, 0