From 0679398f598f70056d19f2b80e61a2d37c4c7444 Mon Sep 17 00:00:00 2001 From: kitty Date: Tue, 21 Apr 2026 14:58:08 +1000 Subject: test stuff, also vocab works it looks like. lovely --- sanctuary.fs | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- sanctuary.s | 1 + 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 -- cgit v1.2.3