mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-18 10:07:37 +01:00
add example: assertions
FossilOrigin-Name: 6697d5c785441718bd466c21148c38bdfcf9634d63f08c6517beaabcf596df79
This commit is contained in:
crc
parent
605587022e
commit
01d0728502
1 changed files with 163 additions and 0 deletions
163
example/Assertions.forth
Normal file
163
example/Assertions.forth
Normal file
|
|
@ -0,0 +1,163 @@
|
|||
# Assertion
|
||||
|
||||
Copyright [c] 2011, Marc Simpson
|
||||
Updated for RETRO 12 by Charles Childers, 2018
|
||||
|
||||
## Description
|
||||
|
||||
This vocabulary provides support for testing code in a clean, predicatable manner.
|
||||
|
||||
Assertion predicates first check the stack for underflow; if the stack is deep enough, their embedded predicates are applied; if not, the assertion fails.
|
||||
|
||||
The result of each assertion - including the underflow check - is ANDed with the assertionFlag which can then be tested after the containing thread has finished executing; this is handled by the .assertion word class.
|
||||
|
||||
For custom behaviour, revector preCond and/or postCond; by default the pre-condition is an effective nop while the post-condition simply prints 'Success' or 'Failure'.
|
||||
|
||||
Given that each assertion predicate mutates assertionFlag, use of the word class `class:assertion` is encouraged; this resets the `assertionFlag` before execution and push its final value to the stack before calling postCond when the thread exits.
|
||||
|
||||
NOTE: For simplicity of implementation, failure within a word of class `class:assertion` will not result in immediate termination; instead, the false value of `assertionFlag` is left to propagate.
|
||||
|
||||
|
||||
## Code & Commentary
|
||||
|
||||
~~~
|
||||
'assertionFlag var
|
||||
|
||||
:assert (f-)
|
||||
&assertionFlag [ and ] v:update-using ;
|
||||
|
||||
:deep? (n-f)
|
||||
n:inc depth lteq? dup assert ;
|
||||
|
||||
:assert:eq #2 deep? [ eq? assert ] if ;
|
||||
:assert:false #1 deep? [ n:zero? assert ] if ;
|
||||
:assert:true #1 deep? [ n:-zero? assert ] if ;
|
||||
:assert:gt #2 deep? [ gt? assert ] if ;
|
||||
:assert:gteq #2 deep? [ gteq? assert ] if ;
|
||||
:assert:lt #2 deep? [ lt? assert ] if ;
|
||||
:assert:lteq #2 deep? [ lteq? assert ] if ;
|
||||
|
||||
:putAssertion (f-)
|
||||
nl [ 'Success ] [ reset 'Failure ] choose s:put ;
|
||||
~~~
|
||||
|
||||
|
||||
~~~
|
||||
:hook #0 , #0 , ; immediate
|
||||
:set #1793 swap store-next store ;
|
||||
:unset #0 swap store-next #0 swap store ;
|
||||
~~~
|
||||
|
||||
~~~
|
||||
:preCond (-) hook ;
|
||||
:postCond (f-) hook putAssertion ;
|
||||
|
||||
{{
|
||||
:buildUp preCond &assertionFlag v:on ;
|
||||
:tearDown @assertionFlag &assertionFlag v:on postCond ;
|
||||
---reveal---
|
||||
:class:assertion (a-)
|
||||
&buildUp class:word class:word &tearDown class:word ;
|
||||
}}
|
||||
|
||||
:assertion (-) &class:assertion reclass ;
|
||||
~~~
|
||||
|
||||
|
||||
~~~
|
||||
:a1 (xyz-) #30 assert:eq #20 assert:eq #10 assert:eq ; assertion
|
||||
:a2 (xy-) assert:true assert:false ; assertion
|
||||
:a3 (x-) #5 assert:gt ; assertion
|
||||
|
||||
:go
|
||||
nl '---------- s:put
|
||||
#10 #20 #30 a1
|
||||
#30 #20 #10 a1
|
||||
nl '---------- s:put
|
||||
#10 a1
|
||||
nl '---------- s:put
|
||||
a1
|
||||
nl '---------- s:put
|
||||
#-1 #0 a2
|
||||
#0 #-1 a2
|
||||
#-1 #-1 a2
|
||||
#-1 a2
|
||||
nl '---------- s:put
|
||||
#3 a3
|
||||
#4 a3
|
||||
#5 a3
|
||||
a3
|
||||
nl '---------- s:put
|
||||
;
|
||||
|
||||
go
|
||||
~~~
|
||||
|
||||
|
||||
## Functions
|
||||
|
||||
+-----------------+-----+-----------------------+
|
||||
| Name |Stack| Usage |
|
||||
+=================+=====+=======================+
|
||||
| assertionFlag | -a | Variable. This holds a|
|
||||
| | | true (-1) or false (0)|
|
||||
| | | value indicating |
|
||||
| | | whether the current |
|
||||
| | | set of assertions have|
|
||||
| | | passed or failed. The |
|
||||
| | | **class:assertion** |
|
||||
| | | class will set this to|
|
||||
| | | true automatically. |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert | f- | Updates the |
|
||||
| | | **assertionFlag** |
|
||||
| | | using bitwise AND |
|
||||
+-----------------+-----+-----------------------+
|
||||
| deep? | n-f | Checks to see if there|
|
||||
| | | are at least *n* items|
|
||||
| | | on the stack. |
|
||||
| | | Returns true if there |
|
||||
| | | are, false otherwise. |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:eq | nn- | Check to see if two |
|
||||
| | | values are equal |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:false | f- | Check to see if flag |
|
||||
| | | is false (0) |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:true | f- | Check to see if flag |
|
||||
| | | is true (non-zero) |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:gt | nn- | Check to see if n1 is |
|
||||
| | | greather than n2 |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:gteq | nn- | Check to see if n1 is |
|
||||
| | | greater than or equal |
|
||||
| | | to n2 |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:lt | nn- | Check to see if n1 is |
|
||||
| | | less than n2 |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assert:lteq | nn- | Check to see if n1 is |
|
||||
| | | less than or equal to |
|
||||
| | | n2 |
|
||||
+-----------------+-----+-----------------------+
|
||||
| putAssertion | f- | Display 'Success' or |
|
||||
| | | 'Failure' based on |
|
||||
| | | flag |
|
||||
+-----------------+-----+-----------------------+
|
||||
| preCond | - | Hook, does nothing by |
|
||||
| | | default |
|
||||
+-----------------+-----+-----------------------+
|
||||
| postCond | f- | Hook, displays either |
|
||||
| | | 'Success' or 'Failure'|
|
||||
| | | by default |
|
||||
+-----------------+-----+-----------------------+
|
||||
| class:assertion | a- | Class handler for |
|
||||
| | | assertions |
|
||||
+-----------------+-----+-----------------------+
|
||||
| assertion | - | Change the class of a |
|
||||
| | | function to |
|
||||
| | | class:asssertion |
|
||||
+-----------------+-----+-----------------------+
|
||||
|
||||
Loading…
Reference in a new issue