Move target v4th.com into cpmfiles/ and check in cpmfiles/

8080/CPM/Makefile

@@ -9,6 +9,8 @@ whitch_runcpm = $(shell which RunCPM)
 runcpmdir = runcpm
 cpmfilesdir = cpmfiles
 
+bin: $(cpmfilesdir)/v4th.com
+
 fth: $(fthfiles)
 
 clean:
@@ -17,9 +19,9 @@ clean:
 	rm -f msdos
 
 veryclean: clean
-	rm -rf cpmfiles
+	rm -rf $(cpmfilesdir)
 
-test: logtest.result inctest.result test-min.result
+test: logtest.result inctest.result test-min.result test-v4th.result
 
 run-editor: | msdos
 	FORTHPATH="f:\\src;f:\\tests;f:\\msdos" \
@@ -74,7 +76,7 @@ inctest.log: \
 	    "exit"
 	dos2unix -n $(runcpmdir)/logfile.txt $@
 
-v4th.com: \
+$(cpmfilesdir)/v4th.com: \
     $(patsubst %, $(cpmfilesdir)/%, volks4th.com \
     include.fb log2file.fb target.fb source.fb v4th.fth) Makefile \
     | emu

8080/CPM/cpmfiles/ans-shim.fth

@@ -0,0 +1,102 @@
+
+: cells  2* ;
+
+: s"  [compile] " compile count ; immediate restrict
+: c"  [compile] " ; immediate restrict
+
+: [char]  [compile] ascii ; immediate
+: char  [compile] ascii ;
+
+: invert  not ;
+
+: lshift  0 ?DO 2* LOOP ;
+
+: rshift  0 ?DO 2/ 32767 and LOOP ;
+
+\ : 2over  3 pick 3 pick ;
+
+: s>d  extend ;
+
+: fm/mod  m/mod ;
+
+: sm/rem  dup >r  2dup xor >r  m/mod
+    over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN
+    ELSE rdrop rdrop THEN ;
+
+: postpone  ' dup >name c@ $40 and
+    IF , ELSE [compile] compile compile , THEN ; immediate
+
+\ : align ;
+: aligned ;
+: cell+  2+ ;
+: char+  1+ ;
+: chars ;
+
+\ : 2@  dup 2+ @ swap @ ;
+\ : 2!  under ! 2+ ! ;
+
+: recurse  last @ name> , ; immediate
+
+' endloop alias unloop
+
+: >number  ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
+ BEGIN  dup 0= IF exit THEN
+ >r  count digit? WHILE accumulate r> 1- REPEAT 1- r> ;
+
+: accept  expect span @ ;
+
+: tuck  under ;
+
+: :noname  here  ['] tuck @ ,  0 ] ;
+
+: <>  = not ;
+
+: 2>r  r> -rot swap >r >r >r ;
+: 2r>  r> r> r> swap rot >r ;
+: 2r@  r> r> r> 2dup >r >r swap rot >r ;
+
+: WITHIN ( test low high -- flag ) OVER - >R - R> U< ;
+
+: unused  sp@ here - ;
+: again  [compile] repeat ; immediate restrict
+
+: BUFFER:  CREATE ALLOT ;
+
+: compile,  , ;
+
+: defer!  >body ! ;
+: defer@  >body @ ;
+: action-of
+ STATE @ IF
+     POSTPONE ['] POSTPONE DEFER@
+   ELSE
+     ' DEFER@
+   THEN ; IMMEDIATE
+
+ : HOLDS ( addr u -- )
+   BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;
+
+: 2Variable  ( --)   Create 4 allot ;
+             ( -- adr)
+
+: 2Constant  ( d --)   Create , ,
+  Does> ( -- d)   2@ ;
+
+: 2literal  swap [compile] literal [compile] literal ;
+immediate restrict
+
+: d-  dnegate d+ ;
+: d0<  0. d< ;
+: d2*  2dup d+ ;
+: d2/  dup 1 and -rot 2/ >r
+  1 rshift  swap IF $8000 or THEN r> ;
+
+: 2over  3 pick 3 pick ;
+: dmax  2over 2over d< IF 2swap THEN 2drop ;
+: dmin  2over 2over 2swap d< IF 2swap THEN 2drop ;
+
+: d>s  drop ;
+
+: m+  extend d+ ;
+
+: 2rot  5 roll 5 roll ;

8080/CPM/cpmfiles/inctest.fth

@@ -0,0 +1 @@
+ .( included from stream file: "1 2 + 4 * .": ) 1 2 + 4 * . cr

8080/CPM/cpmfiles/prelim.fth

@@ -0,0 +1,233 @@
+CR CR SOURCE TYPE ( Preliminary test ) CR
+SOURCE ( These lines test SOURCE, TYPE, CR and parenthetic comments ) TYPE CR
+( The next line of output should be blank to test CR ) SOURCE TYPE CR CR
+
+( It is now assumed that SOURCE, TYPE, CR and comments work. SOURCE and      )
+( TYPE will be used to report test passes until something better can be      )
+( defined to report errors. Until then reporting failures will depend on the )
+( system under test and will usually be via reporting an unrecognised word   )
+( or possibly the system crashing. Tests will be numbered by #n from now on  )
+( to assist fault finding. Test successes will be indicated by               )
+( 'Pass: #n ...' and failures by 'Error: #n ...'                             )
+
+( Initial tests of >IN +! and 1+ )
+( Check that n >IN +! acts as an interpretive IF, where n >= 0 )
+( Pass #1: testing 0 >IN +! ) 0 >IN +! SOURCE TYPE CR
+( Pass #2: testing 1 >IN +! ) 1 >IN +! xSOURCE TYPE CR
+( Pass #3: testing 1+ ) 1 1+ >IN +! xxSOURCE TYPE CR
+
+( Test results can now be reported using the >IN +! trick to skip )
+( 1 or more characters )
+
+( The value of BASE is unknown so it is not safe to use digits > 1, therefore )
+( it will be set it to binary and then decimal, this also tests @ and ! )
+
+( Pass #4: testing @ ! BASE ) 0 1+ 1+ BASE ! BASE @ >IN +! xxSOURCE TYPE CR
+( Set BASE to decimal ) 1010 BASE !
+( Pass #5: testing decimal BASE ) BASE @ >IN +! xxxxxxxxxxSOURCE TYPE CR
+
+( Now in decimal mode and digits >1 can be used )
+
+( A better error reporting word is needed, much like .( which can't  )
+( be used as it is in the Core Extension word set, similarly PARSE can't be )
+( used either, only WORD is available to parse a message and must be used   )
+( in a colon definition. Therefore a simple colon definition is tested next )
+
+( Pass #6: testing : ; ) : .SRC SOURCE TYPE CR ; 6 >IN +! xxxxxx.SRC
+( Pass #7: testing number input ) 19 >IN +! xxxxxxxxxxxxxxxxxxx.SRC
+
+( VARIABLE is now tested as one will be used instead of DROP e.g. Y ! )
+
+( Pass #8: testing VARIABLE ) VARIABLE Y 2 Y ! Y @ >IN +! xx.SRC
+
+: MSG 41 WORD COUNT ;  ( 41 is the ASCII code for right parenthesis )
+( The next tests MSG leaves 2 items on the data stack )
+( Pass #9: testing WORD COUNT ) 5 MSG abcdef) Y ! Y ! >IN +! xxxxx.SRC
+( Pass #10: testing WORD COUNT ) MSG ab) >IN +! xxY ! .SRC
+
+( For reporting success .MSG( is now defined )
+: .MSG( MSG TYPE ; .MSG( Pass #11: testing WORD COUNT .MSG) CR
+
+( To define an error reporting word, = 2* AND will be needed, test them first )
+( This assumes 2's complement arithmetic )
+1 1 = 1+ 1+ >IN +! x.MSG( Pass #12: testing = returns all 1's for true) CR
+1 0 = 1+ >IN +! x.MSG( Pass #13: testing = returns 0 for false) CR
+1 1 = -1 = 1+ 1+ >IN +! x.MSG( Pass #14: testing -1 interpreted correctly) CR
+
+1 2* >IN +! xx.MSG( Pass #15: testing 2*) CR
+-1 2* 1+ 1+ 1+ >IN +! x.MSG( Pass #16: testing 2*) CR
+
+-1 -1 AND 1+ 1+ >IN +! x.MSG( Pass #17: testing AND) CR
+-1  0 AND 1+ >IN +! x.MSG( Pass #18: testing AND) CR
+6  -1 AND >IN +! xxxxxx.MSG( Pass #19: testing AND) CR
+
+( Define ~ to use as a 'to end of line' comment. \ cannot be used as it a )
+( Core Extension word )
+: ~  ( -- )  SOURCE >IN ! Y ! ;
+
+( Rather than relying on a pass message test words can now be defined to )
+( report errors in the event of a failure. For convenience words ?T~ and )
+( ?F~ are defined together with a helper ?~~ to test for TRUE and FALSE  )
+( Usage is: <test> ?T~ Error #n: <message>                               )
+( Success makes >IN index the ~ in ?T~ or ?F~ to skip the error message. )
+( Hence it is essential there is only 1 space between ?T~ and Error      )
+
+: ?~~  ( -1 | 0 -- )  2* >IN +! ;
+: ?F~ ( f -- )   0 = ?~~ ;
+: ?T~ ( f -- )  -1 = ?~~ ;
+
+( Errors will be counted )
+VARIABLE #ERRS 0 #ERRS !
+: Error  1 #ERRS +! -6 >IN +! .MSG( CR ;
+: Pass  -1 #ERRS +! 1 >IN +! Error ;  ~ Pass is defined solely to test Error
+
+-1 ?F~ Pass #20: testing ?F~ ?~~ Pass Error
+-1 ?T~ Error #1: testing ?T~ ?~~ ~
+
+0  0 = 0= ?F~ Error #2: testing 0=
+1  0 = 0= ?T~ Error #3: testing 0=
+-1 0 = 0= ?T~ Error #4: testing 0=
+
+0  0 = ?T~ Error #5: testing =
+0  1 = ?F~ Error #6: testing =
+1  0 = ?F~ Error #7: testing =
+-1 1 = ?F~ Error #8: testing =
+1 -1 = ?F~ Error #9: testing =
+
+-1 0< ?T~ Error #10: testing 0<
+0  0< ?F~ Error #11: testing 0<
+1  0< ?F~ Error #12: testing 0<
+
+ DEPTH 1+ DEPTH = ?~~ Error #13: testing DEPTH
+ ~ Up to now whether the data stack was empty or not hasn't mattered as
+ ~ long as it didn't overflow. Now it will be emptied - also
+ ~ removing any unreported underflow
+ DEPTH 0< 0= 1+ >IN +! ~ 0 0 >IN ! Remove any underflow
+ DEPTH 0= 1+ >IN +! ~ Y !  0 >IN ! Empty the stack
+ DEPTH 0= ?T~ Error #14: data stack not emptied
+
+ 4 -5 SWAP 4 = SWAP -5 = = ?T~ Error #15: testing SWAP
+ 111 222 333 444
+ DEPTH 4 = ?T~ Error #16: testing DEPTH
+ 444 = SWAP 333 = = DEPTH 3 = = ?T~ Error #17: testing SWAP DEPTH
+ 222 = SWAP 111 = = DEPTH 1 = = ?T~ Error #18: testing SWAP DEPTH
+ DEPTH 0= ?T~ Error #19: testing DEPTH = 0
+
+~ From now on the stack is expected to be empty after a test so
+~ ?~ will be defined to include a check on the stack depth. Note
+~ that ?~~ was defined and used earlier instead of ?~ to avoid
+~ (irritating) redefinition messages that many systems display had
+~ ?~ simply been redefined
+
+: ?~  ( -1 | 0 -- )  DEPTH 1 = AND ?~~ ; ~ -1 test success, 0 test failure
+
+123 -1 ?~ Pass #21: testing ?~
+Y !   ~ equivalent to DROP
+
+~ Testing the remaining Core words used in the Hayes tester, with the above
+~ definitions these are straightforward
+
+1 DROP DEPTH 0= ?~ Error #20: testing DROP
+123 DUP  = ?~ Error #21: testing DUP
+123 ?DUP = ?~ Error #22: testing ?DUP
+0  ?DUP 0= ?~ Error #23: testing ?DUP
+123  111  + 234  = ?~ Error #24: testing +
+123  -111 + 12   = ?~ Error #25: testing +
+-123 111  + -12  = ?~ Error #26: testing +
+-123 -111 + -234 = ?~ Error #27: testing +
+-1 NEGATE 1 = ?~ Error #28: testing NEGATE
+0  NEGATE 0=  ?~ Error #29: testing NEGATE
+987 NEGATE -987 = ?~ Error #30: testing NEGATE
+HERE DEPTH SWAP DROP 1 = ?~ Error #31: testing HERE
+CREATE TST1 HERE TST1 = ?~ Error #32: testing CREATE HERE
+16  ALLOT HERE TST1 NEGATE + 16 = ?~ Error #33: testing ALLOT
+-16 ALLOT HERE TST1 = ?~ Error #34: testing ALLOT
+0 CELLS 0= ?~ Error #35: testing CELLS
+1 CELLS ALLOT HERE TST1 NEGATE + VARIABLE CSZ CSZ !
+CSZ @ 0= 0= ?~ Error #36: testing CELLS
+3 CELLS CSZ @ DUP 2* + = ?~ Error #37: testing CELLS
+-3 CELLS CSZ @ DUP 2* + + 0= ?~ Error #38: testing CELLS
+: TST2  ( f -- n )  DUP IF 1+ THEN ;
+0 TST2 0=  ?~ Error #39: testing IF THEN
+1 TST2 2 = ?~ Error #40: testing IF THEN
+: TST3  ( n1 -- n2 )  IF 123 ELSE 234 THEN ;
+0 TST3 234 = ?~ Error #41: testing IF ELSE THEN
+1 TST3 123 = ?~ Error #42: testing IF ELSE THEN
+: TST4  ( -- n )  0 5 0 DO 1+ LOOP ;
+TST4 5 = ?~ Error #43: testing DO LOOP
+: TST5  ( -- n )  0 10 0 DO I + LOOP ;
+TST5 45 = ?~ Error #44: testing I
+: TST6  ( -- n )  0 10 0 DO DUP 5 = IF LEAVE ELSE 1+ THEN LOOP ;
+TST6 5 = ?~ Error #45: testing LEAVE
+: TST7  ( -- n1 n2 ) 123 >R 234 R> ;
+TST7 NEGATE + 111 = ?~ Error #46: testing >R R>
+: TST8  ( -- ch )  [CHAR] A ;
+TST8 65 = ?~ Error #47: testing [CHAR]
+: TST9  ( -- )  [CHAR] s [CHAR] s [CHAR] a [CHAR] P 4 0 DO EMIT LOOP ;
+TST9 .MSG(  #22: testing EMIT) CR
+: TST10  ( -- )  S" Pass #23: testing S" TYPE [CHAR] " EMIT CR ; TST10
+
+~ The Hayes core test core.fr uses CONSTANT before it is tested therefore
+~ we test CONSTANT here
+
+1234 CONSTANT CTEST
+CTEST 1234 = ?~ Error #48: testing CONSTANT
+
+~ The Hayes tester uses some words from the Core extension word set
+~ These will be conditionally defined following definition of a
+~ word called ?DEFINED to determine whether these are already defined
+
+VARIABLE TIMM1 0 TIMM1 !
+: TIMM2  123 TIMM1 ! ; IMMEDIATE
+: TIMM3 TIMM2 ; TIMM1 @ 123 = ?~ Error #49: testing IMMEDIATE
+
+: ?DEFINED  ( "name" -- 0 | -1 )  32 WORD FIND SWAP DROP 0= 0= ;
+?DEFINED SWAP ?~ Error #50: testing FIND ?DEFINED
+?DEFINED <<no-such-word-hopefully>> 0= ?~ Error #51 testing FIND ?DEFINED
+
+?DEFINED \ ?~ : \ ~ ; IMMEDIATE
+\ Error #52: testing \
+: TIMM4  \ Error #53: testing \ is IMMEDIATE
+;
+
+~ TRUE and FALSE are defined as colon definitions as they have been used
+~ more than CONSTANT above
+
+?DEFINED TRUE  ?~ : TRUE 1 NEGATE ;
+?DEFINED FALSE ?~ : FALSE 0 ;
+?DEFINED HEX   ?~ : HEX 16 BASE ! ;
+
+TRUE -1 = ?~ Error #54: testing TRUE
+FALSE 0=  ?~ Error #55: testing FALSE
+10 HEX 0A = ?~ Error #56: testing HEX
+AB 0A BASE ! 171 = ?~ Error #57: testing hex number
+
+~ Delete the ~ on the next 2 lines to check the final error report
+~ Error #998: testing a deliberate failure
+~ Error #999: testing a deliberate failure
+
+~ Describe the messages that should be seen. The previously defined .MSG(
+~ can be used for text messages
+
+CR .MSG( Results: ) CR
+CR .MSG( Pass messages #1 to #23 should be displayed above)
+CR .MSG( and no error messages) CR
+
+~ Finally display a message giving the number of tests that failed.
+~ This is complicated by the fact that untested words including .( ." and .
+~ cannot be used. Also more colon definitions shouldn't be defined than are
+~ needed. To display a number, note that the number of errors will have
+~ one or two digits at most and an interpretive loop can be used to
+~ display those.
+
+CR
+0 #ERRS @
+~ Loop to calculate the 10's digit (if any)
+DUP NEGATE 9 + 0< NEGATE >IN +! ( -10 + SWAP 1+ SWAP 0 >IN ! )
+~ Display the error count
+SWAP ?DUP 0= 1+ >IN +! ( 48 + EMIT ( ) 48 + EMIT
+
+.MSG(  test) #ERRS @ 1 = 1+ >IN +! ~ .MSG( s)
+.MSG(  failed out of 57 additional tests) CR
+
+CR CR .MSG( --- End of Preliminary Tests --- ) CR

8080/CPM/cpmfiles/test-min.fth

@@ -0,0 +1,14 @@
+
+include log2file.fb
+logopen
+
+include ans-shim.fth
+: \vf  [compile] \ ; immediate
+
+include prelim.fth
+include tester.fth
+
+\ 1 verbose !
+include core.fr
+
+logclose

8080/CPM/cpmfiles/tester.fth

@@ -0,0 +1,66 @@
+\ From: John Hayes S1I
+\ Subject: tester.fr
+\ Date: Mon, 27 Nov 95 13:10:09 PST  
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.2
+
+\ 24/11/2015 Replaced Core Ext word <> with = 0=
+\ 31/3/2015 Variable #ERRORS added and incremented for each error reported.
+\ 22/1/09 The words { and } have been changed to T{ and }T respectively to
+\ agree with the Forth 200X file ttester.fs. This avoids clashes with
+\ locals using { ... } and the FSL use of } 
+
+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 !
+\   TRUE 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 ;
+
+VARIABLE #ERRORS 0 #ERRORS !
+
+: ERROR      \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
+      \ THE LINE THAT HAD THE ERROR.
+   CR TYPE SOURCE TYPE       \ DISPLAY LINE CORRESPONDING TO ERROR
+   EMPTY-STACK               \ THROW AWAY EVERY THING ELSE
+   #ERRORS @ 1 + #ERRORS !
+\   QUIT  \ *** Uncomment this line to QUIT on an error
+;
+
+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
+           = 0= 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 [CHAR] * EMIT
+   THEN ;
+

8080/CPM/cpmfiles/v4th.fth

@@ -0,0 +1,11 @@
+
+Onlyforth
+    $9000 displace !
+Target definitions   $100 here!
+
+  use source.fb
+  2 $75 thru    \ Standard 8080-System
+
+cr .( unresolved: )  .unresolved   ( ' .blk is .status )
+
+save-target  V4TH.COM