strong.f

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

: TOKEN-FIELD ( flag1 def x -- flag2 )
  SWAP @ = AND ;

: ATTRIBUTE-FIELD ( flag1 def x -- flag2 )
  SWAP CELL+ @ AND 0<> AND ;

: DICT' ( -- def )
  PARSE-WORD 0 ['] 2DROP SEARCH-ALL 0= IF -13 THROW THEN ;

: WORDLIST ( -- WID )
  HERE 0 , ;

: (VOCABULARY) ( -- )
  CREATE WORDLIST 0 ,
  DOES> #ORDER @ 0= IF -50 THROW THEN CONTEXT ! ;

(VOCABULARY) FORTH       ' FORTH       >BODY CONSTANT FORTH-WID
(VOCABULARY) LOCAL       ' LOCAL       >BODY CONSTANT LOCAL-WID
(VOCABULARY) ENVIRONMENT ' ENVIRONMENT >BODY CONSTANT ENVIRONMENT-WID

1 #ORDER !
FORTH-WID CURRENT !
FORTH-WID CONTEXT !  

: <LOCALS ( -- )
  0 LOCAL-WID ! DICT-HERE LP ! ;

: LOCALS> ( -- )
  0 LOCAL-WID ! LP @ DP ! ;

: CFSP! ( -- )
  CFSTACK #NESTING CELLS + CFSP ! ;

: >CF ( cf -- )
  ?COMPILE CFSP @ CFSTACK >
  IF -1 CELLS CFSP +! CFSP @ !
  ELSE DROP -52 THROW
  THEN ;

: CF> ( -- cf )
  ?COMPILE CFSP @ [ CFSTACK #NESTING CELLS + ] LITERAL <
  IF CFSP @ @ 1CELL CFSP +!
  ELSE DROP -52 THROW
  THEN ;

: DICT: ( -- colon-sys )
  S" : " PREVIEW-WORD 2EVALUATE 0 (CREATE) ] DTP! CFSP! <LOCALS ;

: DICT:NONAME ( -- def colon-sys )
  DICT-HERE :NONAME 0 (CREATE-NONAME) ] DTP! CFSP! <LOCALS ;

: DT ( -- dt )
  PARSE-WORD DATA-TYPE-ATTRIBUTE ['] ATTRIBUTE-FIELD SEARCH-ALL
  IF ?DATA-TYPE
  ELSE -260 THROW DROP 0.
  THEN ;

: DT-> ( -- )
  DT> DROP DT-PREFIX DT-OR >DT DT >DT ;

: SEARCH-TOKEN ( xt -- def n )
  0. ROT ['] TOKEN-FIELD SEARCH-ALL ;

: ?DEFINITION ( dt -- def )
  NIP CELL+ @ SEARCH-TOKEN DROP ;

: .DT ( dt -- )
  ?DEFINITION 2DUP D0=
  IF 2DROP ." ??? " ELSE NAME TYPE SPACE THEN ;

: .S ( -- )
  DTP@ DUP DT-DEPTH DCELLS-
  ?DO I 2@ 2DUP .DT DT-PREFIX DT-ATTRIBUTE? IF ." -> " THEN
  2CELLS +LOOP ;

: PARENT ( dt1 -- dt2 )
  DUP IF @ THEN ;

: ANCESTOR ( dt1 -- dt2 )
  DUP IF BEGIN DUP @ WHILE @ REPEAT THEN 0. DT-AND ;

: DT-SIZE ( dt -- u )
  ANCESTOR 2DUP D0<> IF 2CELLS+ @ THEN NIP ;

: ?DT-SIZE ( dt -- u )
  DT-SIZE DUP 0= IF -271 THROW THEN ;

: DEPTH-SP ( -- u )
  0 TRUE DTP@ DUP DT-DEPTH DCELLS-
  ?DO IF I 2@ ?DT-SIZE + THEN I 2@ DT-PREFIX DT-ATTRIBUTE? INVERT
  2CELLS +LOOP DROP ;

: DTDROP ( -- dt )
  BEGIN DT> WHILE 2DROP REPEAT ;

: )COLON ( flag sd -- )
  ) LATEST DUP #PARAMS ALL-PARAMS>DT DROP <LOCALS ;

: @>DT ( addr -- )
  BEGIN DUP 2@ 2DUP DT-PREFIX DT-AND >DT DT-PREFIX DT-ATTRIBUTE?
  WHILE 2CELLS+
  REPEAT DROP ;

: NEXT-WORD-PARAM ( addr1 u1 -- addr2 u2 )
  BEGIN 1- OVER 2CELLS+ ROT 2@ DT-PREFIX DT-ATTRIBUTE?
  WHILE SWAP
  REPEAT SWAP ;

: PREV-DATA-PARAM ( addr1 -- addr2 )
  BEGIN 2CELLS- DUP DATA-BOT @ U>
     IF DUP 2CELLS- 2@ DT-PREFIX DT-ATTRIBUTE? INVERT
     ELSE TRUE
     THEN
  UNTIL ;

: SKIP-PARAMETERS ( addr1 addr2 u -- addr3 flag )
  BEGIN DUP
  WHILE OVER 2@ DT-INPUT DT-ATTRIBUTE?
  WHILE OVER-SD DATA-BOT @ U>
     IF ROT PREV-DATA-PARAM -ROT NEXT-WORD-PARAM
     ELSE 2DROP FALSE EXIT
     THEN
  REPEAT
  THEN 2DROP TRUE ;

: DIRECT-MATCH ( addr1 dt -- addr2 flag )
  >R OVER @
  BEGIN DUP R@ <>
  WHILE @ DUP 0=
  UNTIL NIP
  ELSE DROP PREFIX-ATTRIBUTE AND
     IF DUP CELL+ @ PREFIX-ATTRIBUTE AND
        IF 2CELLS+ TRUE
        ELSE FALSE
        THEN
     ELSE
        BEGIN DUP 2CELLS+ SWAP CELL+ @ PREFIX-ATTRIBUTE AND 0=
        UNTIL TRUE
     THEN
  THEN RDROP ;

: REFERENCE-MATCH ( addr1 dt -- addr2 flag )
  OFFSET 1- REFERENCES SWAP CELLS+ @
  BEGIN OVER 2@ DT-PREFIX DT-AND
     OVER-SD 2@ DT-PREFIX DT-AND D=
  WHILE SWAP 2CELLS+ SWAP DUP CELL+ @ PREFIX-ATTRIBUTE AND
  WHILE 2CELLS+
  REPEAT DROP TRUE
  ELSE DROP FALSE
  THEN ;

: MATCH-ALL ( addr1 u addr2 -- flag )
  REFERENCES 2>R
  BEGIN DUP
  WHILE OVER 2@ DT-INPUT DT-ATTRIBUTE?
  WHILE 2R> DUP DATA-BOT U< IF 2DUP ! CELL+ THEN 2>R
     1- OVER 2CELLS+ -ROT 2R> >R ROT 2@ 2DUP OFFSET
     IF REFERENCE-MATCH
     ELSE DIRECT-MATCH
     THEN SWAP R> 2>R INVERT
  UNTIL 2DROP DRDROP FALSE EXIT
  THEN
  THEN 2DROP DRDROP TRUE ;

: INIT-COMPILER-WORKSPACE-EXEC ( -- )
  DT-EXEC-BOTTOM DATA-BOT !
  DTP-EXEC @     DATA-PTR !
  DT-EXEC-TOP    DATA-TOP ! ;

: INIT-COMPILER-WORKSPACE-COMP ( -- )
  DT-COMP-BOTTOM DATA-BOT !
  DTP-COMP @     DATA-PTR !
  DT-COMP-TOP    DATA-TOP ! ;

: INIT-COMPILER-WORKSPACE ( flag -- )
  IF INIT-COMPILER-WORKSPACE-COMP
  ELSE INIT-COMPILER-WORKSPACE-EXEC
  THEN ;

: INPUT-PARAMETER-MATCH ( addr1 u -- addr2 flag )
  DATA-PTR @ OVER-DS SKIP-PARAMETERS
  IF DUP >R MATCH-ALL R> SWAP
  ELSE 2DROP FALSE
  THEN ;

: MOVE-OUTPUT-PARAMETERS ( addr1 addr2 -- addr3 )
  >R DATA-PTR @ R@ ROT DATA-PTR @ - R> OVER + >R MOVE R> ;

: STORE-OUTPUT-PARAMETER ( addr1 dt -- addr2 flag )
  ROT DUP DATA-TOP @ U<
  IF >R DT-PREFIX DT-AND R@ 2! R> 2CELLS+ TRUE
  ELSE NIP-DS FALSE
  THEN ;

: NEXT-DATA-TYPE ( addr1 u1 -- addr2 u2 )
  1- SWAP 2CELLS+ SWAP ;

: SCAN-OUTPUT-PARAMETERS ( addr1 u addr2 -- addr3 flag )
  -ROT
  BEGIN DUP
  WHILE OVER 2@ DT-OUTPUT DT-ATTRIBUTE?
     IF OVER 2@ OFFSET
        IF >R >R REFERENCES R@ 2@ OFFSET 1- CELLS+ @
           BEGIN TUCK 2@ STORE-OUTPUT-PARAMETER INVERT
              IF NIP DRDROP FALSE EXIT THEN
              OVER 2CELLS+ ROT 2@ DT-PREFIX DT-ATTRIBUTE? INVERT
           UNTIL DROP R> R>
        ELSE >R DUP >R 2@ STORE-OUTPUT-PARAMETER R> R> ROT INVERT
           IF 2DROP FALSE EXIT THEN
        THEN
     THEN NEXT-DATA-TYPE
  REPEAT 2DROP TRUE ;

: (CAST) ( addr u flag -- )
  DUP >R INIT-COMPILER-WORKSPACE 2DUP INPUT-PARAMETER-MATCH
  IF >R DATA-PTR @ SCAN-OUTPUT-PARAMETERS
     IF R> MOVE-OUTPUT-PARAMETERS R> DTP !
     ELSE DRDROP -256 THROW
     THEN
  ELSE DROP DROP RDROP -13 THROW
  THEN ;

: DT>DT ( def flag -- xt )
  DUP DTP @ 0= IF -257 THROW THEN
  OVER DUP 2CELLS+ SWAP #PARAMS
  ROT (CAST) @ ;

: DICT-COMPILE, ( def -- )
  TRUE DT>DT COMPILE, ;

: COMPARE-DATA-TYPES ( addr1 addr2 u1 -- addr3 addr4 u2 flag )
  OVER-SD DATA-PTR @ U<
  IF OVER-SD 2@ DT-PREFIX DT-AND 2>R OVER 2@ DT-PREFIX DT-AND 2R> D=
     IF ROT 2CELLS+ -ROT NEXT-DATA-TYPE TRUE
     ELSE FALSE
     THEN
  ELSE FALSE
  THEN ;

: (?CONGRUENT) ( def addr -- addr flag )
  STATE @ INIT-COMPILER-WORKSPACE TUCK OVER 2CELLS+ DUP >R ROT #PARAMS
  BEGIN DUP
  WHILE OVER 2@ DT-OUTPUT DT-ATTRIBUTE?
     IF OVER 2@ OFFSET
        IF ROT R@ 3 PICK 2@ OFFSET 1- DCELLS+ -1
           BEGIN COMPARE-DATA-TYPES INVERT
              IF 2DROP RDROP NIP-DS FALSE EXIT
              THEN OVER 2CELLS- 2@ DT-PREFIX DT-ATTRIBUTE? INVERT
           UNTIL 2DROP -ROT NEXT-DATA-TYPE
        ELSE COMPARE-DATA-TYPES INVERT
           IF 2DROP RDROP FALSE EXIT
           THEN
        THEN
     ELSE NEXT-DATA-TYPE
     THEN
  REPEAT 2DROP RDROP DATA-PTR @ = ;

: (THAW) ( addr1 addr2 -- flag )
  >R INIT-COMPILER-WORKSPACE-COMP DATA-BOT @ SWAP
  BEGIN R@ OVER U>
  WHILE -1 COMPARE-DATA-TYPES NIP 0=
     IF RDROP 2DROP FALSE EXIT
     THEN
  REPEAT RDROP DROP DATA-PTR @ = ;

: ?CONGRUENT ( def addr -- )
  (?CONGRUENT)
  IF STATE @ DTP !
  ELSE DROP -258 THROW
  THEN ;

: ?PARAMS ( -- )
  DTP@ IF LATEST DTP@ DT-DEPTH DCELLS- ?CONGRUENT THEN ;

: DICT-EXIT ( -- )
  ?COMPILE ?PARAMS POSTPONE EXIT DTP| ;

: IDENTITY ( flag1 def x -- flag2 )
  OVER #PARAMS OVER =
  IF SWAP 2CELLS+ SWAP DICT-HERE DUP ROT DCELLS-
     ?DO DUP 2@ I 2@ D<> IF UNLOOP 2DROP FALSE EXIT THEN 2CELLS+
     2CELLS +LOOP DROP
  ELSE 2DROP DROP FALSE
  THEN ;

: DEFERRED ( flag1 def1 def2 -- flag2 )
  >R DUP >R DEFERRED-ATTRIBUTE ATTRIBUTE-FIELD DUP
  IF R> R> OVER #PARAMS OVER #PARAMS =
     IF DUP #PARAMS 0
        ?DO 2DUP I PARAM@ ROT I PARAM@ D= INVERT
           IF UNLOOP 2DROP DROP FALSE EXIT THEN
        2CELLS +LOOP 2DROP
     ELSE 2DROP DROP FALSE
     THEN
  ELSE DRDROP
  THEN ;

: EXECUTE-CONGRUENCE ( def x addr -- flag )
  >R OVER 2CELLS+ ROT #PARAMS DATA-PTR @ SCAN-OUTPUT-PARAMETERS
  IF >R DUP 2CELLS+ SWAP #PARAMS 2DUP DATA-BOT @ MATCH-ALL DROP
     R@ SCAN-OUTPUT-PARAMETERS
     IF R> R@ OVER >R MOVE-OUTPUT-PARAMETERS DATA-BOT @ - R@ + OVER =
        IF R> DATA-BOT @ ROT >R
           BEGIN OVER R@ U<
           WHILE 2DUP 2@ DT-PREFIX DT-AND
              ROT 2@ DT-PREFIX DT-AND D=
           WHILE 2CELLS+ SWAP 2CELLS+ SWAP
           REPEAT 2DROP FALSE
           ELSE 2DROP TRUE
           THEN RDROP
        ELSE DROP RDROP FALSE
        THEN
     ELSE DROP RDROP FALSE
     THEN
  ELSE 2DROP FALSE
  THEN RDROP ;

: MATCH ( flag1 def x -- flag2 )
  ROT DUP >R 2/ OVER IF DROP TRUE THEN STATE @ AND INIT-COMPILER-WORKSPACE
  OVER DUP 2CELLS+ SWAP #PARAMS INPUT-PARAMETER-MATCH
  OVER-SD 1 -1 WITHIN OVER AND
  IF DROP EXECUTE-CONGRUENCE
  ELSE NIP NIP-DS
  THEN R> AND ;

: ?DT>DT ( c-addr u -- xt )
  ?COMPILE TRUE ['] MATCH SEARCH-ALL
  IF TRUE DT>DT ELSE -13 THROW THEN ;

: (DT) ( -- dt )
  0 ' >BODY ;

: (PROCREATES) ( dt -- )
  CREATE , DROP DOES> ( sd addr -- sd ) 0 SWAP (PARAM) ;

0.                     (PROCREATES) SINGLE ' SINGLE , 1 , \ size
(DT) SINGLE            (PROCREATES) INTEGER ' INTEGER ,
(DT) INTEGER           (PROCREATES) UNSIGNED ' UNSIGNED ,
(DT) INTEGER           (PROCREATES) SIGNED ' SIGNED ,
(DT) INTEGER           (PROCREATES) CHARACTER ' CHARACTER ,
(DT) SINGLE            (PROCREATES) ADDRESS ' ADDRESS ,
(DT) ADDRESS           (PROCREATES) CADDRESS ' CADDRESS ,
(DT) SINGLE            (PROCREATES) LOGICAL ' LOGICAL ,
(DT) LOGICAL           (PROCREATES) FLAG ' FLAG ,
(DT) SINGLE            (PROCREATES) DEFINITION ' DEFINITION ,
(DT) SINGLE            (PROCREATES) TOKEN ' TOKEN ,
(DT) TOKEN             (PROCREATES) SEARCH-CRITERION ' SEARCH-CRITERION ,
(DT) SINGLE            (PROCREATES) FILE ' FILE ,
(DT) SINGLE            (PROCREATES) FAM ' FAM ,
(DT) SINGLE            (PROCREATES) WID ' WID ,
(DT) SINGLE            (PROCREATES) R-SIZE ' R-SIZE ,
(DT) SINGLE            (PROCREATES) CONTROL-FLOW ' CONTROL-FLOW ,
0.                     (PROCREATES) DOUBLE ' DOUBLE , 2 , \ size
(DT) DOUBLE            (PROCREATES) INTEGER-DOUBLE ' INTEGER-DOUBLE ,
(DT) INTEGER-DOUBLE    (PROCREATES) UNSIGNED-DOUBLE ' UNSIGNED-DOUBLE ,
(DT) UNSIGNED-DOUBLE   (PROCREATES) NUMBER-DOUBLE ' NUMBER-DOUBLE ,
(DT) INTEGER-DOUBLE    (PROCREATES) SIGNED-DOUBLE ' SIGNED-DOUBLE ,
(DT) DOUBLE            (PROCREATES) DATA-TYPE ' DATA-TYPE ,
(DT) DATA-TYPE         (PROCREATES) STACK-DIAGRAM ' STACK-DIAGRAM ,
0.                     (PROCREATES) TUPLE ' TUPLE , 0 , \ invalid size
(DT) TUPLE             (PROCREATES) INPUT-SOURCE ' INPUT-SOURCE ,
0.                     (PROCREATES) SYS ' SYS , 0 , \ invalid size
(DT) SYS               (PROCREATES) ORIG/DEST ' ORIG/DEST ,
(DT) ORIG/DEST         (PROCREATES) ORIG ' ORIG ,
(DT) ORIG/DEST         (PROCREATES) DEST ' DEST ,
(DT) SYS               (PROCREATES) COLON-SYS ' COLON-SYS ,
(DT) COLON-SYS         (PROCREATES) DOES-SYS ' DOES-SYS ,
(DT) SYS               (PROCREATES) DO-SYS ' DO-SYS ,
(DT) SYS               (PROCREATES) CASE-SYS ' CASE-SYS ,
(DT) SYS               (PROCREATES) OF-SYS ' OF-SYS ,

: >SIGN ( char -- n )
  CASE [CHAR] + OF  1 ENDOF
       [CHAR] - OF -1 ENDOF
       0 SWAP
  ENDCASE ;

: NUMBER ( c-addr u -- d dt )
  0. 2SWAP DUP
  IF OVER C@ >SIGN
  ELSE 0
  THEN DUP >R
     IF 1/STRING
     THEN DUP
  IF DUP >R >NUMBER DUP R> =
  ELSE TRUE
  THEN
  IF 2DROP RDROP 0. EXIT
  THEN DUP
  IF S" ." COMPARE
     IF RDROP 0. EXIT
     THEN R@
     IF [ (DT) SIGNED-DOUBLE ] 2LITERAL
     ELSE [ (DT) UNSIGNED-DOUBLE ] 2LITERAL
     THEN
  ELSE 2DROP R@
     IF [ (DT) SIGNED ] 2LITERAL
     ELSE [ (DT) UNSIGNED ] 2LITERAL
     THEN
  THEN R> 0<
  IF 2SWAP DNEGATE 2SWAP
  THEN ;

: SEARCH-LOCAL ( c-addr u -- addr n )
  0 ['] 2DROP LOCAL-WID SEARCH-WID
  IF 2CELLS+ 1 ELSE 0 THEN ;

: LOCAL, ( c-addr u addr -- )
  ?COMPILE DUP 2@ DT-SIZE
  CASE 1 OF @>DT EVALUATE ENDOF
       2 OF @>DT 2DUP S" R@" COMPARE
            IF 2DUP EVALUATE S" 2~" 2SWAP 2EVALUATE 
            ELSE 2DROP S" 2R@" EVALUATE
            THEN ENDOF
       >R DROP 2DROP R> -271 THROW
  ENDCASE ;

: INTERPRET ( -- )
  BEGIN PARSE-WORD DUP
  WHILE 2DUP SEARCH-LOCAL
     IF LOCAL,
     ELSE DROP 2DUP FALSE ['] MATCH SEARCH-ALL DUP
        IF 2SWAP 2DROP 0< STATE @ AND
           IF DICT-COMPILE,
           ELSE FALSE DT>DT EXECUTE
           THEN
        ELSE 2DROP NUMBER 2DUP D0=
           IF 2DROP DROP -13 THROW
           ELSE 2DUP >DT DT-SIZE 1- STATE @
              IF IF POSTPONE 2LITERAL
                 ELSE D>S POSTPONE LITERAL
                 THEN