changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > demo / fig/tests/tester.fr

changeset 10: 79737134254d
author: ellis <ellis@rwest.io>
date: Fri, 12 May 2023 22:58:05 -0400
permissions: -rw-r--r--
description: messing with UI and rust codegen 
     1 \ From: John Hayes S1I
     2 \ Subject: tester.fr
     3 \ Date: Mon, 27 Nov 95 13:10:09 PST  
     4 
     5 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
     6 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
     7 \ VERSION 1.2
     8 
     9 \ 24/11/2015 Replaced Core Ext word <> with = 0=
    10 \ 31/3/2015 Variable #ERRORS added and incremented for each error reported.
    11 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
    12 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
    13 \ locals using { ... } and the FSL use of } 
    14 
    15 HEX
    16 
    17 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
    18 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
    19 VARIABLE VERBOSE
    20    FALSE VERBOSE !
    21 \   TRUE VERBOSE !
    22 
    23 : EMPTY-STACK   \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
    24    DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
    25 
    26 VARIABLE #ERRORS 0 #ERRORS !
    27 
    28 : ERROR      \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
    29       \ THE LINE THAT HAD THE ERROR.
    30    CR TYPE SOURCE TYPE       \ DISPLAY LINE CORRESPONDING TO ERROR
    31    EMPTY-STACK               \ THROW AWAY EVERY THING ELSE
    32    #ERRORS @ 1 + #ERRORS !
    33 \   QUIT  \ *** Uncomment this line to QUIT on an error
    34 ;
    35 
    36 VARIABLE ACTUAL-DEPTH         \ STACK RECORD
    37 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
    38 
    39 : T{      \ ( -- ) SYNTACTIC SUGAR.
    40    ;
    41 
    42 : ->      \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
    43    DEPTH DUP ACTUAL-DEPTH !      \ RECORD DEPTH
    44    ?DUP IF            \ IF THERE IS SOMETHING ON STACK
    45       0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
    46    THEN ;
    47 
    48 : }T      \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
    49       \ (ACTUAL) CONTENTS.
    50    DEPTH ACTUAL-DEPTH @ = IF      \ IF DEPTHS MATCH
    51       DEPTH ?DUP IF         \ IF THERE IS SOMETHING ON THE STACK
    52          0  DO            \ FOR EACH STACK ITEM
    53            ACTUAL-RESULTS I CELLS + @   \ COMPARE ACTUAL WITH EXPECTED
    54            = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN
    55          LOOP
    56       THEN
    57    ELSE               \ DEPTH MISMATCH
    58       S" WRONG NUMBER OF RESULTS: " ERROR
    59    THEN ;
    60 
    61 : TESTING   \ ( -- ) TALKING COMMENT.
    62   SOURCE VERBOSE @
    63    IF DUP >R TYPE CR R> >IN !
    64    ELSE >IN ! DROP [CHAR] * EMIT
    65    THEN ;
    66