strong.f

strongForth: a strongly typed dialect of Forth implemented in ANS Forth.

: M*/ ( ud1 u1 u2 -- ud2 )
  >R T* R> T/MOD NIP-SD ;

: U*/MOD ( u1 u2 u3 -- u4 u5 )
  >R UM* R> UM/MOD ;

: TM*/MOD \ ud1 u1 u2 -- u3 ud2 )
  >R T* R> T/MOD ;

: U2/ ( u1 -- u2 )
  1 RSHIFT ;

: DU2/ ( ud1 -- ud2 )
  DUP >R D2/ R> U2/ AND ;

: UMIN ( u1 u2 -- u3 )
  0 SWAP 0 DMIN DROP ;

: DUMIN ( ud1 ud2 -- ud3 )
  2OVER 2OVER DU< INVERT IF 2SWAP THEN 2DROP ;

: UMAX ( u1 u2 -- u3 )
  0 SWAP 0 DMAX DROP ;

: DUMAX ( ud1 ud2 -- ud3 )
  2OVER 2OVER DU< IF 2SWAP THEN 2DROP ;

: DU> ( ud1 ud2 -- flag )
  2SWAP DU< ;

: D> ( d1 d2 -- flag )
  2SWAP D< ;

: D<> ( xd1 xd2 -- flag )
  D= INVERT ;

: D0> ( d -- flag )
  DNEGATE D0< ;

: D0<> ( d -- flag )
  D0= INVERT ;

: 1/STRING ( c-addr1 u1 n -- c-addr2 u2 )
  1 /STRING ;

: 2, ( xd -- )
  , , ;

: DICT-HERE ( -- addr )
  DP @ ;

: DICT, ( x -- )
  DICT-HERE CELL+ DICT-TOP U>
  IF DROP -8 THROW
  ELSE DICT-HERE 1CELL DP +! !
  THEN ;

: 2DICT, ( xd -- )
  DICT-HERE 2CELLS+ DICT-TOP U>
  IF 2DROP -8 THROW
  ELSE DICT-HERE 2CELLS DP +! 2!
  THEN ;

: DICT-ALLOT ( n -- )
  DICT-HERE OVER + DICT-BOTTOM DICT-TOP WITHIN
  IF DP +!
  ELSE DROP -8 THROW
  THEN ;

: DICT-ALIGN ( -- )
  DICT-HERE ALIGNED DP ! ;

: CDICT, ( x -- )
  DICT-HERE CHAR+ DICT-TOP U>
  IF DROP -8 THROW
  ELSE DICT-HERE 1CHAR DP +! C!
  THEN ;

: UPPER ( char1 -- char2 )
  DUP [CHAR] a [ CHAR z 1+ ] LITERAL WITHIN
  IF [ CHAR a CHAR A - ] LITERAL - THEN ;

: UPPER-STRING ( c-addr u -- )
  CHARS OVER + SWAP ?DO I C@ UPPER I C! 1 CHARS +LOOP ;

: DICT-NAME, ( c-addr u -- )
  DUP 31 >
  IF -18 THROW
  ELSE DUP CDICT,
     BEGIN DUP
     WHILE OVER C@ CASE-INSENSITIVE [IF] UPPER [THEN] CDICT, 1/STRING
     REPEAT
  THEN DROP DROP
  DICT-HERE DICT-ALIGN DICT-HERE OVER - BLANK ;

: RDROP ( -- )
  POSTPONE R> POSTPONE DROP ; IMMEDIATE

: DRDROP ( -- )
  POSTPONE 2R> POSTPONE 2DROP ; IMMEDIATE

HEX

0080 CONSTANT PREFIX-ATTRIBUTE

0080. 2CONSTANT DT-PREFIX
0040. 2CONSTANT DT-INPUT
0020. 2CONSTANT DT-OUTPUT
001F. 2CONSTANT DT-OFFSET

DECIMAL

: DT-AND ( dt1 dt2 -- dt3 )
  DROP ROT AND SWAP ;

: DT-OR ( dt1 dt2 -- dt3 )
  DROP ROT OR SWAP ;

: DT-XOR ( dt1 dt2 -- dt3 )
  DROP ROT XOR SWAP ;

: DT-INVERT ( dt1 -- dt2 )
  SWAP INVERT SWAP ;

: DT-ATTRIBUTE? ( dt1 dt2 -- flag )
  DROP NIP AND 0<> ;

: DT-NULL? ( dt1 -- flag )
  NIP 0= ;

: OFFSET ( dt -- u )
  DT-OFFSET DT-AND DROP ;

: OFFSET+ ( dt1 n -- dt2 )
  OVER-DS OFFSET + DUP 0 32 WITHIN
  IF -ROT [ DT-OFFSET DT-INVERT ] 2LITERAL DT-AND ROT 0 DT-OR
  ELSE DROP -259 THROW
  THEN ;

: T> ( tuple1 -- tuple2 x )
  DUP IF 1- SWAP ELSE -275 THROW THEN ;

: 2T> ( tuple1 -- tuple2 xd )
  DUP IF 2 - -ROT ELSE -275 THROW THEN ;

: >T ( tuple1 x -- tuple2 )
  SWAP 1+ ;

: 2>T ( tuple1 xd -- tuple2 )
  ROT 2 + ;

: TDROP ( tuple -- )
  0 ?DO DROP LOOP ;

: DTP ( flag -- a-addr )
  IF DTP-COMP ELSE DTP-EXEC THEN ;

: DT-BOTTOM ( flag -- a-addr )
  IF DT-COMP-BOTTOM ELSE DT-EXEC-BOTTOM THEN ;

: DT-TOP ( flag -- a-addr )
  IF DT-COMP-TOP ELSE DT-EXEC-TOP THEN ;

: DTP@ ( -- a-addr )
  STATE @ DTP @ ;

: DTP! ( -- )
  STATE @ DT-BOTTOM STATE @ DTP ! ;

: DTP| ( -- )
  STATE @ IF 0 DTP-COMP ! THEN ;

: >DT ( dt -- )
  [ DT-INPUT DT-OUTPUT DT-OR DT-INVERT ] 2LITERAL DT-AND
  STATE @ DTP DUP @
  IF STATE @ DT-TOP OVER @ 2CELLS+ U<
     IF DROP 2DROP -256 THROW
     ELSE DUP >R @ 2! 2CELLS R> +!
     THEN
  ELSE DROP 2DROP -256 THROW
  THEN ;

: DT> ( -- dt flag )
  STATE @ DTP DUP @
  IF STATE @ DT-BOTTOM OVER @ 2CELLS- 2DUP SWAP U<
     IF 2DROP DROP -257 THROW 0. FALSE
     ELSE TUCK =
        IF FALSE
        ELSE DUP 2CELLS- 2@ DT-PREFIX DT-ATTRIBUTE?
        THEN >R DUP ROT ! 2@ R>
     THEN
  ELSE DROP -257 THROW 0. FALSE
  THEN ;

: DT-DEPTH ( -- u )
  DTP@ DUP IF STATE @ DT-BOTTOM - THEN 0 2CELLS UM/MOD NIP ;

: PARAM, ( sd1 dt -- sd2 )
  2DICT, 1 OFFSET+ ;

: (PARAM) ( sd1 dt -- sd2 )
  2OVER [ DT-PREFIX DT-INVERT ] 2LITERAL DT-AND
  DT-OR 2SWAP 2DUP DT-NULL?
  IF 2DROP
  ELSE [ DT-PREFIX DT-INPUT DT-OR DT-OUTPUT DT-OR ] 2LITERAL DT-AND PARAM,
  THEN ;

: -- ( sd1 -- sd2 )
  2DUP [ DT-OUTPUT DT-PREFIX DT-OR ] 2LITERAL DT-ATTRIBUTE?
  OVER-DS DT-INPUT DT-ATTRIBUTE? INVERT OR
  IF -262 THROW
  ELSE 0. (PARAM) [ DT-INPUT DT-OUTPUT DT-OR ] 2LITERAL DT-XOR
  THEN ;

: -> ( sd1 -- sd2 )
  2DUP DT-NULL? OVER-DS DT-PREFIX DT-ATTRIBUTE? OR
  IF -262 THROW
  ELSE DT-PREFIX DT-OR
  THEN ;

: TH ( sd1 u -- sd2 )
  -ROT 0. (PARAM) TUCK-SD OFFSET OVER U< OVER 0= OR
  IF DROP -261 THROW
  ELSE OVER-DS OFFSET OVER 1- - DICT-HERE SWAP DCELLS- 2@ 2DUP
     [ DT-OFFSET DT-OUTPUT DT-OR ] 2LITERAL DT-ATTRIBUTE?
     IF 2DROP DROP -261 THROW
     ELSE 0. DT-AND ROT OFFSET+ 2OVER
        [ DT-INPUT DT-OUTPUT DT-OR ] 2LITERAL DT-AND DT-OR PARAM,
     THEN
  THEN ;

: STATE! ( flag -- )
  IF ] ELSE POSTPONE [ THEN ;

: <DIAGRAM ( flag sd1 -- sd2 )
  2DUP [ DT-INPUT DT-PREFIX DT-OR ] 2LITERAL DT-ATTRIBUTE?
  INVERT OVER-DS DT-OUTPUT DT-ATTRIBUTE? AND
  IF 0. (PARAM)
  ELSE -262 THROW
  THEN ROT STATE! ;

: DIAGRAM> ( sd -- )
  OFFSET DCELLS NEGATE DICT-ALLOT ;

: ENCLOSE-DIAGRAM ( sd -- sd a-addr1 a-addr2 )
  2DUP OFFSET >R DICT-HERE DUP R> DCELLS- ;

: PARAM@ ( def u -- dt )
  1+ DCELLS+ 2@ ;

: END-DIAGRAM ( sd -- )
  OFFSET LATEST DUP 2@ ROT-SSD OFFSET+ ROT 2! ;

: PARAMS>DT ( def dt -- )
  2DUP OFFSET
  IF OFFSET 1-
     BEGIN 2DUP OVER SWAP PARAM@ RECURSE
        2DUP PARAM@ DT-PREFIX DT-ATTRIBUTE?
     WHILE 1+
     REPEAT 2DROP
  ELSE >DT DROP
  THEN ;

: ALL-PARAMS>DT ( def u -- def )
  0
  ?DO DUP I PARAM@ 2DUP DT-OUTPUT DT-ATTRIBUTE?
    IF 2DROP LEAVE
    THEN OVER-SD -ROT PARAMS>DT
  LOOP ;

: #PARAMS ( def -- u )
  2@ OFFSET ;

: ) ( flag sd -- )
  <DIAGRAM LATEST #PARAMS IF -264 THROW THEN END-DIAGRAM ;

: GET-CURRENT ( -- wid )
  CURRENT @ ;

: SET-CURRENT ( -- wid )
  CURRENT ! ;

: LATEST! ( -- )
  DICT-HERE TO LATEST ;

: NONAME? ( def -- flag )
  2@ NONAME-ATTRIBUTE 0 DT-ATTRIBUTE? ;

: ?NONAME ( def -- )
  NONAME? IF -267 THROW THEN ;

: NAME ( def -- c-addr u )
  DUP ?NONAME CELL-
  BEGIN CHAR- DUP C@ BL <
  UNTIL COUNT ;

: END-DEF ( -- )
  LATEST NONAME? INVERT
  IF LATEST CELL- >R GET-CURRENT DUP @ R@ @ ROT ! R> !
  THEN ;

: ?COMPILE ( -- )
  STATE @ INVERT IF -14 THROW THEN ;

: ?EXECUTE ( -- )
  STATE @ IF -29 THROW THEN ;

: SOURCE ( -- c-addr u )
  SOURCE-ID STRING-ID =
  IF SOURCE-SPEC 2@
  ELSE SOURCE-ID
     IF FIB #FIB @
     ELSE TIB #TIB @
     THEN
  THEN ;

: CU@+ ( c-addr u1 -- c-addr u2 char )
  2DUP CHARS+ C@ SWAP 1+ SWAP ;

: ENCLOSE ( char c-addr u1 u2 -- c-addr u1 u2 u4 )
  >R TUCK
  BEGIN DUP R@ U<
  WHILE CU@+ 4 PICK =
  UNTIL DUP 1- SWAP RDROP
  ELSE R> SWAP
  THEN 4 ROLL DROP 3 ROLL -ROT ;

: PARSE ( char -- c-addr u )
  SOURCE >IN @ SWAP ENCLOSE >IN ! OVER - -ROT + SWAP ;

: ENCLOSE-WORD ( c-addr u1 u2 -- c-addr u3 u4 u5 )
  >R TUCK
  BEGIN DUP R@ U< INVERT IF ROT DROP R> OVER EXIT THEN CU@+ BL U>
  UNTIL ROT DROP DUP 1- -ROT
  BEGIN DUP R@ U<
  WHILE CU@+ BL > INVERT
  UNTIL DUP 1- SWAP RDROP
  ELSE R> SWAP
  THEN 3 ROLL -ROT ;

: PARSE-WORD ( -- c-addr u )
  SOURCE >IN @ SWAP ENCLOSE-WORD >IN ! OVER - -ROT + SWAP
  DUP 31 > IF -19 THROW THEN ;

: COMMENT ( -- )
  [CHAR] \ PARSE 2DROP ;

: CATENATE ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
  2SWAP >R DICT-HERE R@ CMOVE
  DUP ROT DICT-HERE R@ CHARS+ ROT CMOVE
  DICT-HERE SWAP R> + ;

: 2EVALUATE ( c-addr1 u1 c-addr2 u2 -- )
  CATENATE EVALUATE ;

: PREVIEW-WORD ( -- c-addr u )
  >IN @ PARSE-WORD ROT >IN ! ;

: DEFINE-WORD ( c-addr u -- xt )
  ?EXECUTE PREVIEW-WORD 2EVALUATE S" ' " PREVIEW-WORD 2EVALUATE ;

: ((CREATE)) ( xt c-addr u -- )
  DICT-HERE >R DICT-NAME, ( name field )
  R> DICT, ( link field )
  LATEST! DICT, ( token field )
  IMMEDIATE-ATTRIBUTE DICT, ( attribute field ) ;

: (CREATE) ( xt -- )
  PARSE-WORD ((CREATE)) ;

: (CREATE-NONAME) ( xt -- )
  LATEST! DICT, ( token field )
  [ IMMEDIATE-ATTRIBUTE NONAME-ATTRIBUTE OR ] LITERAL
  DICT, ( attribute field ) ;

: +ATTRIBUTE ( x -- )
  LATEST CELL+ +! ;

: EXPORT ( xt -- )
  BL WORD COUNT ((CREATE)) END-DEF ;

: EXPORT-DT ( xt -- )
  EXPORT DATA-TYPE-ATTRIBUTE +ATTRIBUTE ;

: IMPORT ( xt -- )
  (CREATE) END-DEF ;

: DICT-CREATE ( -- )
  S" CREATE " DEFINE-WORD IMPORT ;

: DICT>BODY ( def -- addr )
  @ >BODY ;

: NAME>LINK ( c-addr -- a-addr )
  COUNT + ALIGNED ;

: NAME>DEFINITION ( c-addr -- def )
  NAME>LINK CELL+ ;

: PREV ( def1 -- def2 )
  DUP ?NONAME CELL- @ DUP IF NAME>DEFINITION THEN ;

: SEARCH-WID ( c-addr u x xt wid -- def n )
  -ROT 2>R @
  CASE-INSENSITIVE [IF] >R >R HERE R@ CMOVE HERE R> 2DUP UPPER-STRING R> [THEN]
  BEGIN DUP
  WHILE DUP NAME>LINK SWAP OVER-SD
     IF 2OVER ROT COUNT COMPARE 0=
     ELSE DROP TRUE
     THEN
     IF CELL+ DUP 2@ IMMEDIATE-ATTRIBUTE 0 DT-ATTRIBUTE?
        2* 1+ OVER 2R@ EXECUTE DUP
        IF 2SWAP 2DROP 2R> 2DROP EXIT
        ELSE DROP CELL-
        THEN
     THEN @
  REPEAT -ROT 2DROP 2R> 2DROP 0 ;

: SEARCH-ALL ( c-addr u x xt -- def n )
  #ORDER @ 0
  ?DO 2OVER 2OVER CONTEXT I CELLS + @ SEARCH-WID DUP
     IF 2>R 2DROP 2DROP 2R> UNLOOP EXIT
     THEN 2DROP
  LOOP 2DROP 2DROP 0 0 ;

: ?DATA-TYPE ( def -- dt )
  DUP 2@ DATA-TYPE-ATTRIBUTE 0 DT-ATTRIBUTE?
  IF DICT>BODY 0 SWAP
  ELSE DROP 0.
  THEN ;