diff --git a/8080/CPM/Makefile b/8080/CPM/Makefile index fffa3cf..92cc781 100644 --- a/8080/CPM/Makefile +++ b/8080/CPM/Makefile @@ -80,7 +80,8 @@ inctest.log: \ $(cpmfilesdir)/v4th.com: \ $(patsubst %, $(cpmfilesdir)/%, volks4th.com \ - include.fb log2file.fb target.fb source.fb v4th.fth vf-core.fth) \ + include.fb log2file.fb target.fb source.fb \ + v4th.fth vf-core.fth vf-io.fth) \ Makefile | emu rm -f $(runcpmdir)/A/0/V4TH.COM $@ ./emulator/run-in-runcpm.sh \ diff --git a/8080/CPM/src/v4th.fth b/8080/CPM/src/v4th.fth index c2e9993..1735014 100644 --- a/8080/CPM/src/v4th.fth +++ b/8080/CPM/src/v4th.fth @@ -4,8 +4,9 @@ Onlyforth Target definitions $100 here! include vf-core.fth + include vf-io.fth use source.fb - $54 $75 thru \ Standard 8080-System + $5e $75 thru \ Standard 8080-System cr .( unresolved: ) .unresolved ( ' .blk is .status ) diff --git a/8080/CPM/src/vf-io.fth b/8080/CPM/src/vf-io.fth new file mode 100644 index 0000000..61860ee --- /dev/null +++ b/8080/CPM/src/vf-io.fth @@ -0,0 +1,189 @@ +\ *** Block No. 84, Hexblock 54 + +\ .status push load 20Oct86 + +Defer .status ' noop Is .status + +| Create: pull r> r> ! ; + +: push ( addr -- ) r> swap dup >r @ >r pull >r >r ; + restrict + +: (load ( blk offset -- ) + isfile push loadfile push fromfile push blk push >in push + >in ! blk ! isfile@ loadfile ! .status interpret ; + +: load ( blk --) ?dup 0=exit 0 (load ; + + + +\ *** Block No. 85, Hexblock 55 + +\ +load thru +thru --> rdepth depth 20Oct86 + +: +load ( offset --) blk @ + load ; + +: thru ( from to --) 1+ swap DO I load LOOP ; +: +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; + +: --> 1 blk +! >in off .status ; immediate + +: rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; +: depth ( -- +n) sp@ s0 @ swap - 2/ ; + + + + + + +\ *** Block No. 86, Hexblock 56 + +\ quit (quit abort UH 25Jan88 + +: (prompt ( -- ) + state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; + +Defer prompt ' (prompt Is prompt + +: (quit BEGIN prompt query interpret REPEAT ; + +Defer 'quit ' (quit Is 'quit +: quit r0 @ rp! level off [compile] [ 'quit ; + +: standardi/o [ output ] Literal output 4 cmove ; + +Defer 'abort ' noop Is 'abort +: abort end-trace clearstack 'abort standardi/o quit ; + +\ *** Block No. 87, Hexblock 57 + +\ (error Abort" Error" 20Oct86 18Nov87 + +Variable scr 1 scr ! Variable r# 0 r# ! + +: (error ( string -- ) standardi/o space here .name + count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; +' (error errorhandler ! + +: (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (err" "lit swap IF errorhandler perform exit THEN + drop ; restrict +: Abort" compile (abort" ," align ; immediate restrict +: Error" compile (err" ," align ; immediate restrict + +\ *** Block No. 88, Hexblock 58 + +\ -trailing 30Jun86 18Nov87 + +Code -trailing ( addr n1 -- addr n2 ) + D pop H pop H push + D dad xchg D dcx +Label -trail H A mov L ora hpush jz + D ldax BL cpi hpush jnz + H dcx D dcx -trail jmp end-code + +\ \\ +\ : -trailing ( addr n1 -- addr n2) +\ 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + + + + +\ *** Block No. 89, Hexblock 59 + +\ space spaces 30Jun86 + +$20 Constant bl + +: space bl emit ; +: spaces ( u --) 0 ?DO space LOOP ; + + + + + + + + + + + +\ *** Block No. 90, Hexblock 5a + +\ hold <# #> sign # #s 17Oct86 + +| : hld ( -- addr) pad 2- ; + +: hold ( char -- ) -1 hld +! hld @ c! ; + +: <# hld hld ! ; + +: #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + +: sign ( n -- ) 0< IF Ascii - hold THEN ; + +: # ( +d1 -- +d2) base @ ud/mod rot 9 over < + IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; + +: #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; + +\ *** Block No. 91, Hexblock 5b + +\ print numbers 24Dec83 + +: d.r -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + +: .r swap extend rot d.r ; + +: u.r 0 swap d.r ; + +: d. 0 d.r space ; + +: . extend d. ; + +: u. 0 d. ; + + + +\ *** Block No. 92, Hexblock 5c + +\ .s list c/l l/s 05Oct87 + +: .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + +$40 Constant c/l \ Screen line length +$10 Constant l/s \ lines per screen + +: list ( blk -- ) + scr ! ." Scr " scr @ u. + l/s 0 DO + cr I 2 .r space scr @ block I c/l * + c/l -trailing type + LOOP cr ; + + + + + +\ *** Block No. 93, Hexblock 5d + +\ multitasker primitives 20Nov87 + +Code end-trace \ patch Next to its original state + $0A A mvi ( IP ldax ) >next sta + $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code + +Code pause >next here 2- ! end-code + +: lock ( addr -- ) dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + +: unlock ( addr -- ) dup lock off ; + +Label wake H pop H dcx UP shld + 6 D lxi D dad M A mov H inx M H mov A L mov sphl + H pop RP shld IP pop Next end-code