screens

\ screen support     uho 2019-08-24 revicsed 2023-06-19

0 free [IF]
: free ( c-addr -- ior ) \ freeing 0 is ok 
    dup IF free THEN ;
[THEN]

[undefined] slurp-file [IF]
: slurp-file ( c-addr u -- )
  r/o bin open-file throw >r 
  r@ file-size throw Abort" file too large" 
  dup allocate throw swap 
  2dup r@ read-file throw over - Abort" could not read whole file"
  r> close-file throw ;
[THEN]


[undefined] save-mem [IF]
: save-mem ( c-addr1 u1 -- c-addr2 u2 )
   swap >r dup  allocate throw swap 2dup r> -rot move ;
[THEN]

[undefined] $/ [IF]
: $/ ( addr u char -- addr1 u1 addr2 u2 ) 
   >r 2dup r> scan dup >r dup IF  1 /string  ELSE nip 0  THEN 2swap r> - ; 
[THEN]

[undefined] parse-name [IF]

\ : parse-name ( <name> -- )
\    bl word count ;

: parse-name parse-word ;

[THEN]

10 Constant #linefeed
12 Constant #pagebreak

: (screen  ( addr1 u1 u -- addr2 u2 )
    0 max 0 ?DO   #pagebreak $/   2drop  LOOP  
    #pagebreak $/ 2swap 2drop ;

2Variable usefilename  0 0 usefilename 2! 
2Variable fromfilename 0 0 fromfilename 2!

2Variable usefile  0 0 usefile 2!

: file? ( -- ) ." Usefile: " usefilename 2@ type  ."   Fromfile: " fromfilename 2@ type ;

\ : slurp-file ( addr1 u1 -- addr2 u2 ) cr 2dup ." Slurping " type cr slurp-file ;

\ : free ( addr -- ior ) cr dup ." Freeing " u. cr free ;

: "use ( c-addr u -- )
   2dup slurp-file  
   usefile 2@ drop free >r  
   usefile 2!
   usefilename 2@ drop free >r
   fromfilename 2@ drop free >r
   2dup 
   save-mem usefilename 2!  
   save-mem fromfilename 2!
   r> throw r> throw r> throw ;

: use ( <filename> -- )
   parse-name 
   dup 0= IF  2drop  usefilename 2@ >r pad r@ move pad r> THEN 
   "use ;   

: from ( <filename> -- )
   parse-name  2dup  fromfilename 2@ compare 0=  \ same filename?
   IF 2drop EXIT THEN
   fromfilename 2@ drop free >r
   save-mem fromfilename 2!
   r> throw ;

: screen ( u -- )
   >r usefile 2@ r> (screen ;

: line ( addr1 u1 u2 -- addr3 u3 )
   0 max
   0 ?DO #linefeed $/ 2drop LOOP
   #linefeed $/ 2swap 2drop ;

Variable scr

: l ( -- )
     scr @ 0 max scr !  
     page ." Scr " scr @ . 
     scr @ screen 0
     BEGIN 
       >r 2dup r@ line over
     WHILE
       cr r@ 3 u.r space  type
       r> 1+
     REPEAT
     r> drop  2drop 2drop ;


: n ( -- )  1 scr +! l ;
: b ( -- )  -1 scr +! l ;

: list ( u -- ) scr ! l ;



use screenfile.fs


: (thru  ( from to -- )
   1+ swap ?DO
     I scr !  I screen ( c-addr u )
     BEGIN
        #linefeed $/ over 
     WHILE ( c-addr1 u1 c-addr2 u2 )
        2swap >r >r evaluate r> r>
     REPEAT
     2drop 2drop
   LOOP ;


: thru ( from to -- )
     usefilename 2@  fromfilename 2@ compare IF \ new file
        usefile 2@ >r >r usefilename 2@ >r >r         
        fromfilename 2@  slurp-file  usefile 2!
        fromfilename 2@  save-mem usefilename 2!
        scr @ >r
        ['] (thru catch  
        r> scr !
        usefilename 2@ drop free 
        usefile 2@ drop free
        fromfilename 2@ drop free
        r> r> 2dup usefilename 2! save-mem fromfilename 2!
        r> r> usefile 2!
        throw throw throw throw
     ELSE \ same file
        scr @ >r
        ['] (thru catch
        r> scr ! throw
     THEN ;
    
: load ( u -- ) dup thru ;

: +load ( u -- )  scr @ + load ;

: +thru ( +from +to )
   scr @ +  swap scr @ + thru ; 

: ld ( -- )  scr @ load ;

\ : \  10 parse 2drop ; immediate


: index ( from to -- )
     1+ swap ?DO
       cr  I 3 .R   space I screen  0 line   type
     LOOP ;

: qx ( -- )
    scr @  30 / 30 * dup 30 + index ;


: utility ( u <name> -- ) Constant ;

: loads ( u <name> -- ) Create , Does> @ load ;
: by ( u <name> -- )  Create , Does> @ load ;

0 by hi