kolibrios/programs/develop/SPForth/devel/~mak/utils_.f

CR .( UTILS_.F)
REQUIRE [IF] ~MAK\CompIF.f
\ WINAPI: GetCurrentDirectoryA         KERNEL32.DLL
\ WINAPI: MoveFileA                    KERNEL32.DLL

: DEFER VECT ;

80 CONSTANT MAXSTRING

C" PLACE" FIND NIP 0=
[IF]

255 CONSTANT MAXCOUNTED   \ maximum length of contents of a counted string


: "CLIP"        ( a1 n1 -- a1 n1' )   \ clip a string to between 0 and MAXCOUNTED
                MAXCOUNTED MIN 0 MAX ;

: PLACE         ( addr len dest -- )
                SWAP "CLIP" SWAP
                2DUP 2>R
                CHAR+ SWAP MOVE
                2R> C! ;

: +PLACE        ( addr len dest -- ) \ append string addr,len to counted
                                     \ string dest
                >R "CLIP" MAXCOUNTED  R@ C@ -  MIN R>
                                        \ clip total to MAXCOUNTED string
                2DUP 2>R

                COUNT CHARS + SWAP MOVE
                2R> +! ;

: C+PLACE       ( c1 a1 -- )    \ append char c1 to the counted string at a1
                DUP 1+! COUNT + 1- C! ;
[THEN]
: OFF     0! ;

: BLANK         ( addr len -- )     \ fill addr for len with spaces (blanks)
                BL FILL ;

: START/STOP   ( -- )
                KEY?
                IF KEY  27 = IF ABORT THEN
                THEN ;

: .S            ( -- )
     S0 @ SP@ CELL+ 2DUP =
     IF  ." EMPTY"  2DROP 
     ELSE DO I @ . START/STOP 1 CELLS +LOOP
     THEN ;

C" TUCK" FIND NIP 0=
[IF]
: TUCK       ( n1 n2 -- n2 n1 n2 ) \ copy top data stack to under second item
   SWAP OVER ;
[THEN]


128 CONSTANT SPCS-MAX  ( optimization for SPACES )

CREATE SPCS
       SPCS-MAX ALLOT
 SPCS  SPCS-MAX BLANK

: (D.)          ( d -- addr len )       TUCK DABS  <# #S ROT SIGN #> ;

C" WITHIN" FIND NIP 0=
[IF]
: WITHIN  ( n1 low high -- f1 ) \ f1=true if ((n1 >= low) & (n1 < high))
  OVER - >R - R> U< ;
[THEN]
: BETWEEN 1+ WITHIN ;

80 VALUE COLS

: H.R           ( n1 n2 -- )    \ display n1 as a hex number right
                                \ justified in a field of n2 characters
                BASE @ >R HEX >R
                0 <# #S #> R> OVER - SPACES TYPE
                R> BASE ! ;

: H.N           ( n1 n2 -- )    \ display n1 as a HEX number of n2 digits
                BASE @ >R HEX >R
                0 <# R> 0 ?DO # LOOP #> TYPE
                R> BASE ! ;
: COL ( N -- )
      DROP 9 EMIT ;

: UPC [ CHAR A CHAR a XOR INVERT ] LITERAL AND ;

: 2,  ( D -- )
  HERE 2! 2 CELLS ALLOT ;

: VOC-STATE,
   CONTEXT @ ,
   CONTEXT @ @ ,
  VOC-LIST @ VOC-LIST 2,
   CURRENT @  CURRENT 2,
      LAST @     LAST 2,
  VOC-LIST @
  BEGIN  ?DUP
  WHILE  DUP CELL+ DUP @ SWAP 2, @
  REPEAT
;
: INCLUDE BL WORD COUNT INCLUDED ;

: CELLS+ CELLS + ;

: ? @ . ;
: DEFINED       ( -- str 0 | cfa flag )
                BL WORD FIND ;
                
: [IFUNDEF] DEFINED NIP 0= POSTPONE [IF] ;
\ C" CELL-"  FIND NIP 0=
1
[IF] : CELL- 1 CELLS - ; 
[THEN]

\ C" LCOUNT" FIND NIP 0=
1
[IF] : LCOUNT   CELL+ DUP CELL- @ ; 
[THEN]
: INCR   1 SWAP +! ;
: FIELD+ -- ;
0 [IF]
: CUR_DIR PAD 256 GetCurrentDirectoryA PAD SWAP  ;
CREATE FIRST-PATH-BUF CUR_DIR NIP 1+ ALLOT
CUR_DIR  FIRST-PATH-BUF PLACE
: FIRST-PATH" FIRST-PATH-BUF COUNT ;
: RENAME-FILE ( adr1 len adr2 len -- ior )
   4DUP + DUP @ 2>R + DUP @ 2>R
   4DUP + 0! + 0!
   DROP NIP SWAP MoveFileA
   2R> SWAP !  2R> SWAP !
;

[THEN]
: FILE-APPEND   ( fileid -- ior )
     DUP >R  FILE-SIZE DROP
          R> RESIZE-FILE  ;

C" U>" FIND NIP 0=
[IF]
: U> ( U1 U2  -- FLAG )
     SWAP U< ;
[THEN]

C" FOLLOWER" FIND NIP
[IF]
: 2,  ( D -- )
  HERE 2! 2 CELLS ALLOT ;

: VOC-STATE,
   CONTEXT @ ,
   CONTEXT @ @ ,
  VOC-LIST @ VOC-LIST 2,
   CURRENT @  CURRENT 2,
      LAST @     LAST 2,
  VOC-LIST @
  BEGIN  ?DUP
  WHILE  DUP CELL+ DUP @ SWAP 2, @
  REPEAT
;

: MARKER, ( -- ADDR )
  HERE
  VOC-STATE,
  FOLLOWER @ FOLLOWER 2,
  HERE  4 CELLS + DP 2,  0. 2,
;
: MARKER! ( ADDR -- )
   DUP @ CONTEXT ! CELL+
   DUP @ CONTEXT @ ! CELL+
   BEGIN  DUP 2@  DUP
   WHILE ! 2 CELLS +
   REPEAT 2DROP DROP ;
[ELSE]
: MARKER ( "<spaces>name" -- ) \ 94 CORE EXT
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>. <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> name, <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
\ name <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: ( -- )
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
\ <20> <20><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> name. <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> name <EFBFBD> <EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>. <EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 
\ <20><><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 
\ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>. <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, 
\ <20><><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
  HERE
\  [C]HERE , [E]HERE ,
  GET-CURRENT ,
  GET-ORDER DUP , 0 ?DO DUP , @ , LOOP
  CREATE ,
  DOES> @ DUP \ ONLY
\  DUP @ [C]DP ! CELL+
\  DUP @ [E]DP ! CELL+
  DUP @ SET-CURRENT CELL+
  DUP @ >R R@ CELLS 2* + 1 CELLS - R@ 0
  ?DO DUP DUP @ SWAP CELL+ @ OVER ! SWAP 2 CELLS - LOOP
  DROP R> SET-ORDER
  DP !
;

[THEN]

C" BODY>" FIND NIP 0=
[IF] : BODY> 5 - ;
[THEN]

C" >NAME" FIND NIP 0=
[IF] : >NAME  4 - DUP BEGIN 1- 2DUP COUNT + U< 0= UNTIL NIP ;
[THEN]

C" CELL/" FIND NIP 0=
  [IF] : CELL/ ( N - N1 )  2 RSHIFT ;
  [THEN]

C" IMAGE-BEGIN" FIND NIP
[IF]
: ?NAME ( ADDR - FLAG )
        DUP IMAGE-BEGIN U>
        OVER HERE       U< AND
        IF  DUP >NAME COUNT + CELL+ =
        ELSE DROP FALSE
        THEN ;
[THEN]

H-STDOUT CONSTANT FORTH-OUT

: FORTH-IO
   FORTH-OUT H-STDOUT <> 
   IF  H-STDOUT CLOSE-FILE DROP
       FORTH-OUT TO H-STDOUT
   THEN
;
: H. BASE @ HEX SWAP U. BASE ! ;
: 3DROP DROP 2DROP ;
: 4DUP 2OVER 2OVER ;
: 0.0 0 DUP ;
: IS POSTPONE TO ; IMMEDIATE

C" -ROT" FIND NIP 0=
[IF] : -ROT ROT ROT ;
[THEN]


: SCAN ( adr len char -- adr' len' )
\ Scan for char through addr for len, returning addr' and len' of char.
        >R 2DUP R> -ROT
        OVER + SWAP
        ?DO DUP I C@ =
                IF LEAVE
                ELSE >R 1 -1 D+ R>
                THEN
        LOOP DROP ;

: SSKIP ( adr len char -- adr' len' )
\ Skip char through addr for len, returning addr' and len' of char+1.
        >R 2DUP R> -ROT
        OVER + SWAP
        ?DO DUP I C@ <>
                IF LEAVE
                ELSE >R 1 -1 D+ R>
                THEN
        LOOP DROP ;

1 CELLS CONSTANT CELL

C" LSCAN" FIND NIP 0=
[IF]
: LSCAN ( adr len long -- adr' len' )
\ Scan for char through addr for len, returning addr' and len' of char.
        >R 2DUP CELLS R> -ROT   \ adr len long adr len
        OVER + SWAP       \ adr len long adr+len adr
        ?DO DUP I @ =
                IF LEAVE
                ELSE >R 1- >R CELL+ R> R>
                THEN CELL
       +LOOP DROP ;
[THEN]

C" /STRING" FIND NIP 0=
[IF] : /STRING DUP >R - SWAP R> + SWAP ;
[THEN]

: "TO-PATHEND"  ( a1 n1 --- a2 n2 )     \ return a2 and count=n1 of filename
                OVER 1+ C@ [CHAR] : =   \ second char is ':'
                OVER 2 > AND            \ and name is longer than two characters
                IF      2 /STRING       \ then remove first two characters
                THEN                    \ now scan to end of last '\' in filename
                BEGIN   2DUP [CHAR] \ SCAN ?DUP
                WHILE   2SWAP 2DROP 1 /STRING
                REPEAT  DROP ;

: ON TRUE SWAP ! ;
C" -ROT" FIND NIP 0=
[IF] : -ROT ROT ROT ;
[THEN]

C" BOUNDS" FIND NIP 0=
[IF] : BOUNDS OVER + SWAP ;
[THEN]
: >= < INVERT ;
: 4DROP 2DROP 2DROP ;

C" RECURSE" FIND NIP 0=
[IF]
: RECURSE       ( -- )          \ cause current definition to execute itself
                ?COMP  LAST @ NAME> COMPILE, ; IMMEDIATE
[THEN]
C" DUP>R" FIND NIP 0=
[IF] : DUP>R POSTPONE DUP POSTPONE >R ; IMMEDIATE
[THEN]

C" PICK" FIND NIP 0=
[IF]
: PICK ( n -- n' )
  1+ CELLS SP@ + @ ;
[THEN]

C" ROLL" FIND NIP 0=
[IF]

: ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
\  Rotate k values on the stack, bringing the deepest to the top.
\   ?DUP IF 1- SWAP >R RECURSE R> SWAP THEN ;
     DUP>R PICK SP@ DUP CELL+ R> 1+ CELLS MOVE DROP  ;
[THEN]

C" AHEAD" FIND NIP 0=
[IF]
: AHEAD POSTPONE FALSE POSTPONE IF ; IMMEDIATE
[THEN]

C" NOT" FIND NIP 0=
[IF] : NOT 0= ;
[THEN]

C" ?EXIT" FIND NIP 0=
[IF]
 : ?EXIT POSTPONE IF
         POSTPONE EXIT
         POSTPONE THEN ; IMMEDIATE
\ : ?EXIT  IF RDROP THEN ;
[THEN]

: BEEP 7 EMIT ;

16 CONSTANT #VOCS 
-1 CELLS CONSTANT -CELL
C" D2*" FIND NIP 0=
[IF] : D2* 2DUP D+ ;
[THEN]
: ,"  [CHAR] " WORD C@ 1+ ALLOT 0 C, ;
: TAB 9 EMIT ;

: (D.)          ( d -- addr len )       TUCK DABS  <# #S ROT SIGN #> ;
: D.R           ( d w -- )              >R (D.) R> OVER - SPACES TYPE ;
: U.R           ( u w -- )              0 SWAP D.R ;
: $  SOURCE TYPE CR ; IMMEDIATE
: +NULL         ( a1 -- )       \ append a NULL just beyond the counted chars
                COUNT + 0 SWAP C! ;

C" CELLS+" FIND NIP 0=
[IF]
: CELLS+  CELLS + ;
[THEN]

C" +CELLS" FIND NIP 0=
[IF]
: +CELLS  SWAP CELLS+ ;
[THEN]
C" PERFORM" FIND NIP 0=
[IF]
: PERFORM @ EXECUTE ;
[THEN]

C" UPPER" FIND NIP 0=
[IF]
: UPPER ( A L -- )
        OVER + SWAP
        ?DO I C@ DUP [CHAR] Z U>
           IF  0xDF AND
           THEN  I C!
        LOOP ;
[THEN]

C" RESET-STACKS" FIND NIP 0=
[IF]
: RESET-STACKS  S0 @ SP! ;
[THEN]
C" D-" FIND NIP 0=
[IF]
: D- ( D1 D2  -- FLAG )
      DNEGATE D+ ;
[THEN]

C" D=" FIND NIP 0=
[IF]
: D= ( D1 D2  -- FLAG )
       D- D0= ;
[THEN]

C" D<>" FIND NIP 0=
[IF]
: D<> ( D1 D2  -- FLAG )
       D= INVERT ;
[THEN]

C" <=" FIND NIP 0=
[IF]
: <= ( D1 D2  -- FLAG )
      > INVERT ;
[THEN]

C" UMAX" FIND NIP 0=
[IF]
: UMAX ( D1 D2  -- FLAG )
   2DUP U< IF NIP ELSE DROP THEN ;
[THEN]

C" D2/" FIND NIP 0=
[IF]
: D2/        ( d1 -- d2 ) \ divide the double number d1 by two
   DUP 1 AND 0x1F RSHIFT ROT 2/ OR SWAP 2/ ;
[THEN]

C" D0<" FIND NIP 0=
[IF]
: D0<        ( d1 -- f1 )
\ Signed compare d1 double number with zero.  If d1 < 0, RETNurn TRUE.
 0< NIP ;
[THEN]
C" \S" FIND NIP 0=
[IF]
: \S            \ comment to end of file
  BEGIN REFILL 0= UNTIL

\     SOURCE-ID FILE-SIZE DROP
\     SOURCE-ID REPOSITION-FILE DROP
     [COMPILE] \ ; IMMEDIATE
[THEN]

\ C" NEEDS" FIND NIP 0=
0
[IF]
: NEEDS
  BL WORD FIND NIP
  BL WORD SWAP 0=
  IF COUNT INCLUDED
  ELSE  DROP
  THEN
;
[THEN]
C" 0MIN" FIND NIP 0=
[IF] : 0MIN 0 MIN ;
[THEN]
C" 0MAX" FIND NIP 0=
[IF] : 0MAX 0 MIN ;
[THEN]

C" H." FIND NIP 0=
[IF] : H. BASE @ SWAP HEX U. BASE ! ;
[THEN]

C" .HS" FIND NIP 0=
[IF]
: .HS ( N -- N1 )
  BASE @ >R HEX .S R> BASE ! ;
[THEN]


C" MS" FIND NIP 0=
[IF]
C" PAUSE" FIND NIP
  [IF] : MS ( N -- ) PAUSE ;
  [THEN]
[THEN]

C" 0>" FIND NIP 0=
[IF]
: 0> ( N -- ) NEGATE 0< ;
[THEN]
C" CS-DUP" FIND NIP 0=
[IF] : CS-DUP 2DUP ;
[THEN]
C" M_WL" FIND NIP 0=
[IF] : M_WL  CS-DUP POSTPONE WHILE ; IMMEDIATE
[THEN]

C" AHEAD" FIND NIP 0=
[IF] : AHEAD  ?COMP HERE BRANCH, >MARK 1 ; IMMEDIATE
[THEN]

C" CS-DUP" FIND NIP 0=
[IF] : CS-DUP 2DUP ;
[THEN]

C" CS-!" FIND NIP 0=
[IF] : CS-! 2! ;
[THEN]

C" CS-@" FIND NIP 0=
[IF] : CS-@ 2@ ;
[THEN]

C" CS-CELLS" FIND NIP 0=
[IF] : CS-CELLS CELLS 2* ;
[THEN]