VolksForth/8080/CPM/cpmfiles/vf-io.fth

\ *** 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