strong.f

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

              ELSE 0=
                 IF D>S
                 THEN
              THEN
           THEN
        THEN
     THEN
  REPEAT 2DROP ;

: REFILL ( -- flag )
  SOURCE-ID STRING-ID <> DUP
  IF DROP SOURCE-ID
     IF SOURCE-ID DUP FILE-POSITION THROW SOURCE-SPEC 2!
        FIB 1022 ROT READ-LINE THROW SWAP #FIB !
     ELSE TIB 80 ACCEPT #TIB ! SPACE TRUE
     THEN DUP IF 0 >IN ! THEN
  THEN ;

: ?REFILL ( -- )
  SOURCE-ID 0<> SOURCE-ID STRING-ID <> AND
  IF SOURCE-SPEC 2@ SOURCE-ID REPOSITION-FILE THROW
     >IN @ REFILL INVERT IF -37 THROW THEN >IN !
  THEN ;

: STRONG-EVALUATE ( c-addr u -- )
  SOURCE-SPEC 2@ 2>R SOURCE-ID >R >IN @ >R
  0 >IN ! STRING-ID TO SOURCE-ID SOURCE-SPEC 2!
  INTERPRET
  R> >IN ! R> TO SOURCE-ID 2R> SOURCE-SPEC 2! ?REFILL ;

: STRONG-INCLUDE-FILE ( fileid -- )
  SOURCE-SPEC 2@ 2>R SOURCE-ID >R >IN @ >R
  TO SOURCE-ID 0 >IN !
  BEGIN REFILL
  WHILE INTERPRET
  REPEAT SOURCE-ID CLOSE-FILE THROW
  R> >IN ! R> TO SOURCE-ID 2R> SOURCE-SPEC 2! ?REFILL ;

: STRONG-INCLUDED ( c-addr u -- )
  R/O OPEN-FILE THROW STRONG-INCLUDE-FILE ;

: CAST ( -- )
  DTDROP DT 2DUP >DT 2SWAP 2DUP >DT
  DT-SIZE 10 * -ROT DT-SIZE +
  CASE  0 OF                         ENDOF
       11 OF                         ENDOF
       12 OF S" S>D" STRONG-EVALUATE ENDOF
       21 OF S" D>S" STRONG-EVALUATE ENDOF
       22 OF                         ENDOF
       -271 THROW
  ENDCASE DT> DROP 2DROP ;

: [LITERAL] ( -- )
  ?COMPILE S" LITERAL," STRONG-EVALUATE DTP@
  BEGIN DUP 2@ 2DUP
     POSTPONE 2LITERAL POSTPONE >DT DT-PREFIX DT-ATTRIBUTE?
  WHILE 2CELLS+
  REPEAT DROP ;

: FREEZE ( -- cf )
  ?COMPILE DTP@
  IF DICT-HERE DT-DEPTH DCELLS DICT,
     DTP@ DT-DEPTH DCELLS- DICT-HERE DT-DEPTH DCELLS DUP DICT-ALLOT MOVE
  ELSE 0
  THEN ;

: THAW ( cf -- )
  ?COMPILE DUP
  IF DUP @ >R CELL+ DTP@
     IF DUP R> + (THAW) 0= IF -258 THROW THEN
     ELSE DT-COMP-BOTTOM R@ + DTP-COMP ! DT-COMP-BOTTOM R> MOVE
     THEN
  ELSE DTP-COMP !
  THEN ;

: NESTING ( addr n -- )
  SWAP [ 3 CELLS 2 CHARS ALIGNED + ] LITERAL -
  COUNT 1 = IF +! ELSE 2DROP THEN ;

: PARAM@, ( def sd1 u1 u2 -- def sd2 )
  ?DO OVER-SD I PARAM@ PARAM, LOOP ;

: +PARAM ( def u1 -- def u2 )
  BEGIN 2DUP PARAM@ DT-PREFIX DT-ATTRIBUTE?
  WHILE 1+
  REPEAT 1+ ;

: ENCLOSE-PARAMS ( def u1 -- def u2 u3 )
  BEGIN 2DUP +PARAM OVER #PARAMS OVER >
  WHILE 2DUP PARAM@ DT-INPUT DT-ATTRIBUTE?
  WHILE NIP-DS
  REPEAT
  THEN NIP ;

: ?HAS-INPUT-PARAMS ( def -- )
  DUP #PARAMS
  IF 0 PARAM@ DT-OUTPUT DT-ATTRIBUTE?
  ELSE DROP TRUE
  THEN
  IF -262 THROW
  THEN ;

: ?CHECK-REFERENCES ( def u1 u2 -- def u1 u2 )
  OVER-SD #PARAMS OVER
  ?DO OVER-SD I PARAM@ OFFSET OVER-SD > IF -261 THROW THEN
  LOOP ;

: (DOES) ( def -- )
  LATEST #PARAMS 0=
  IF DUP ?HAS-INPUT-PARAMS 0 ENCLOSE-PARAMS ?CHECK-REFERENCES
     >R 0. ROT 0 PARAM@, OVER-SD #PARAMS R> PARAM@,
     END-DIAGRAM
  THEN DROP ;

: STRONG-NO-PARAMS-DOES> ( colon-sys -- does-sys )
  ?COMPILE
  LATEST ?NONAME ?PARAMS POSTPONE DOES> LOCALS> DTP! CFSP! END-DEF
  LATEST TO LATEST-DOES 0 (CREATE-NONAME) ;

: STRONG-DOES> ( colon-sys -- does-sys )
  LP @ POSTPONE LITERAL POSTPONE (DOES)
  STRONG-NO-PARAMS-DOES> ;

: 'LATEST ( -- xt )
  S" ' " LATEST NAME 2EVALUATE ;

: DICT; ( colon-sys -- )
  ?COMPILE ?PARAMS POSTPONE ;
  LATEST NONAME? INVERT IF 'LATEST THEN LATEST !
  LOCALS> DTP| END-DEF ;

: DOES; ( does-sys -- )
  ?COMPILE ?PARAMS LOCALS> DTP| END-DEF
  LATEST-DOES TO LATEST POSTPONE ; 'LATEST LATEST ! ;

: PROMPT ( -- )
  STATE @ INVERT IF ."  OK" THEN ;

: STRONG-QUIT ( -- )
  CR QUIT ;

: 1ST ( STACK-DIAGRAM -- 1ST )
  1 TH ;

: 2ND ( STACK-DIAGRAM -- 1ST )
  2 TH ;

: 3RD ( STACK-DIAGRAM -- 1ST )
  3 TH ;

: IMMEDIATE ( -- )
  LATEST DUP 2@ DT-PREFIX DT-INVERT DT-AND ROT 2! ;

: DU. ( ud -- )
  <# #S #> TYPE SPACE ;

: DU.R ( ud n -- )
  -ROT <# #S #> ROT OVER - SPACES TYPE ;

: IMMEDIATE? ( def -- flag )
  CELL+ @ IMMEDIATE-ATTRIBUTE AND 0= ;

: .DIAGRAM ( def -- )
  TRUE SWAP ." ( " DUP #PARAMS 0
  ?DO 2DUP I PARAM@ DT-OUTPUT DT-ATTRIBUTE? AND
     IF ." -- " SWAP INVERT SWAP THEN DUP I PARAM@ 2DUP OFFSET
     CASE 0 OF 2DUP .DT ENDOF
          1 OF ." 1ST " ENDOF
          2 OF ." 2ND " ENDOF
          3 OF ." 3RD " ENDOF
          DUP . ." TH "
     ENDCASE DT-PREFIX DT-ATTRIBUTE? IF ." -> " THEN
  LOOP DROP IF ." -- " THEN ." ) " ;

: .DEFINITION ( def -- )
  DUP NAME TYPE SPACE .DIAGRAM ;

: 'HOST ( -- xt )
  S" ' " PARSE-WORD 2EVALUATE ;

: 'HOST-PARSING ( -- xt )
  :NONAME PARSE-WORD S"  " CATENATE POSTPONE SLITERAL
  POSTPONE PARSE-WORD POSTPONE 2EVALUATE POSTPONE ; ;

: SLITERAL \ c-addr u -- )
  ?COMPILE POSTPONE SLITERAL
  [ (DT) CADDRESS DT-PREFIX DT-OR ] 2LITERAL >DT
  [ (DT) CHARACTER ] 2LITERAL >DT
  [ (DT) UNSIGNED ] 2LITERAL >DT ;

: " ( -- )
  [CHAR] " PARSE STATE @
  IF SLITERAL
  ELSE #STR ! STR #STR @ MOVE S" STR #STR @" STRONG-EVALUATE
  THEN ;

: STRONG-POSTPONE ( -- )
  ?COMPILE PARSE-WORD 2DUP TRUE ['] MATCH SEARCH-ALL 1 =
  IF DICT-COMPILE, 2DROP
  ELSE DROP SLITERAL S" EVALUATE" STRONG-EVALUATE
  THEN ;

: (CONSTANT) ( sd1 -- sd2 )
  DTP@
  BEGIN TUCK-DS 2@ DT-OUTPUT DT-OR PARAM,
     ROT DUP 2@ DT-PREFIX DT-ATTRIBUTE?
  WHILE 2CELLS+
  REPEAT DROP ;

: (VARIABLE) ( sd1 -- sd2 )
  [ (DT) ADDRESS DT-OUTPUT DT-PREFIX DT-OR DT-OR ] 2LITERAL
  PARAM, (CONSTANT) ;

: DICT-CONSTANT ( x -- )
  ?EXECUTE S" CONSTANT " DEFINE-WORD (CREATE)
  0. (CONSTANT) END-DIAGRAM END-DEF ;

: DICT-VARIABLE ( x -- )
  ?EXECUTE S" VARIABLE " DEFINE-WORD SWAP
  PREVIEW-WORD EVALUATE ! (CREATE)
  0. (VARIABLE) END-DIAGRAM END-DEF ;

: DICT-VALUE ( x -- )
  ?EXECUTE S" VALUE " DEFINE-WORD (CREATE)
  0. (CONSTANT) END-DIAGRAM END-DEF
  VALUE-ATTRIBUTE +ATTRIBUTE ;

: 2VALUE ( xd -- )
  CREATE 2, DOES> 2@ ;

: DICT-2CONSTANT ( xd -- )
  ?EXECUTE S" 2CONSTANT " DEFINE-WORD (CREATE)
  0. (CONSTANT) END-DIAGRAM END-DEF ;

: DICT-2VARIABLE ( xd -- )
  ?EXECUTE S" 2VARIABLE " DEFINE-WORD -ROT
  PREVIEW-WORD EVALUATE 2! (CREATE)
  0. (VARIABLE) END-DIAGRAM END-DEF  ;

: DICT-2VALUE ( xd -- )
  ?EXECUTE S" 2VALUE " DEFINE-WORD (CREATE)
  0. (CONSTANT) END-DIAGRAM END-DEF
  2VALUE-ATTRIBUTE +ATTRIBUTE ;

: ?VALUE ( c-addr u -- def )
  [ VALUE-ATTRIBUTE 2VALUE-ATTRIBUTE OR ] LITERAL
  ['] ATTRIBUTE-FIELD SEARCH-ALL INVERT
  IF -32 THROW THEN ;

: (STRONG-TO) ( -- )
  S" TO " PARSE-WORD 2EVALUATE
  S" !" FALSE ['] MATCH SEARCH-ALL 0=
  IF DROP -13 THROW
  ELSE STATE @ DT>DT DROP
  THEN ;

: STRONG-TO ( -- )
  PREVIEW-WORD SEARCH-LOCAL
  IF ?COMPILE
     [ (DT) ADDRESS DT-PREFIX DT-OR ] 2LITERAL >DT
     DUP @>DT 2@ DT-SIZE 2 =
     IF S" TO 2~" PREVIEW-WORD 2EVALUATE
     THEN (STRONG-TO)
  ELSE DROP PREVIEW-WORD ?VALUE
     [ (DT) ADDRESS DT-PREFIX DT-OR ] 2LITERAL >DT
     DUP 1. PARAMS>DT
     DUP 2@ 2VALUE-ATTRIBUTE 0 DT-ATTRIBUTE?
     IF PARSE-WORD 2DROP DICT>BODY STATE @
        IF POSTPONE LITERAL THEN S" !" STRONG-EVALUATE
     ELSE DROP (STRONG-TO)
     THEN
  THEN ;

: RECURSE ( -- )
  ?COMPILE LATEST STATE @ DT>DT DROP POSTPONE RECURSE ;

: DT+ ( addr1 -- addr2 )
  BEGIN DUP 2CELLS+ SWAP 2@ DT-PREFIX DT-ATTRIBUTE? INVERT
  UNTIL ;

: CREATE-LOCAL ( c-addr u -- )
  ?COMPILE DICT-HERE -ROT DICT-NAME,
  LOCAL-WID DUP @ DICT, !
  1 DICT, DTP@ DUP DT+ SWAP 2DUP -D DICT,
  DO I 2@ DT-OUTPUT DT-OR 2DICT,
  2CELLS +LOOP ;

: FORGET-LOCAL ( -- )
  ?COMPILE LOCAL-WID @ DP !
  DICT-HERE NAME>LINK @ LOCAL-WID ! ;

: (LOCAL) ( c-addr u -- )
  ?COMPILE DUP
  IF DTDROP DT-SIZE 2 =
     IF S" 2~" 2OVER CATENATE (LOCAL)
     THEN 2DUP (LOCAL) CREATE-LOCAL
  ELSE (LOCAL)
  THEN ;

: STRONG->R ( -- n )
  ?COMPILE S" (>R)" STRONG-EVALUATE
  DTP@ 2@ DT-SIZE S" R@" CREATE-LOCAL ;

: STRONG-R> ( n -- )
  ?COMPILE S" R@" SEARCH-LOCAL
  IF @>DT FORGET-LOCAL
     CASE 1 OF POSTPONE  R> ENDOF
          2 OF POSTPONE 2R> ENDOF
          -271 THROW
     ENDCASE
  ELSE DROP -271 THROW
  THEN ;

: LOOP, ( do-sys xt -- )
  CASE
     ['] NOOP   OF POSTPONE LOOP ENDOF
     ['] 1CELL  OF POSTPONE 1CELL  POSTPONE +LOOP ENDOF
     ['] 2CELLS OF POSTPONE 2CELLS POSTPONE +LOOP ENDOF
     ['] 1CHAR  OF POSTPONE 1CHAR  POSTPONE +LOOP ENDOF
  ENDCASE ;

: +LOOP, ( do-sys xt -- )
  CASE
     ['] NOOP   OF POSTPONE +LOOP ENDOF
     ['] CELLS  OF POSTPONE CELLS  POSTPONE +LOOP ENDOF
     ['] DCELLS OF POSTPONE DCELLS POSTPONE +LOOP ENDOF
     ['] CHARS  OF POSTPONE CHARS  POSTPONE +LOOP ENDOF
  ENDCASE ;

: DICT-MARKER ( -- )
  DICT-HERE
  FORTH-WID @ DICT,
  LOCAL-WID @ DICT,
  ENVIRONMENT-WID @ DICT,
  #ORDER @ DICT,
  CONTEXT #ORDER @ CELLS+ CONTEXT
  ?DO I @ DICT, 1CELL +LOOP
  GET-CURRENT DICT,
  VOC-LINK @ DUP DICT,
  BEGIN DICT>BODY DUP @ DICT, CELL+ @ DUP 0=
  UNTIL DROP
  LATEST DICT,
  LATEST-DOES DICT,
  S" MARKER " DEFINE-WORD
  DICT-CREATE 2, DOES> DUP CELL+ @ DUP
        DUP @ FORTH-WID !
  CELL+ DUP @ LOCAL-WID !
  CELL+ DUP @ ENVIRONMENT-WID !
  CELL+ DUP @ #ORDER !
  CONTEXT #ORDER @ CELLS+ CONTEXT
  ?DO CELL+ DUP @ I ! 1CELL +LOOP
  CELL+ DUP @ SET-CURRENT
  CELL+ DUP @ DUP VOC-LINK !
  BEGIN DICT>BODY DUP ROT CELL+ DUP @ ROT ! SWAP CELL+ @ DUP 0=
  UNTIL DROP
  CELL+ DUP @ TO LATEST
  CELL+     @ TO LATEST-DOES
  DP ! @ EXECUTE ;

: STRONG-ENVIRONMENT? ( c-addr u -- addr flag )
  0 ['] 2DROP ENVIRONMENT-WID SEARCH-WID
  0<> DUP IF SWAP DICT>BODY SWAP THEN ;

2VARIABLE ERROR-STR

: (ABORT") ( SINGLE CCONST -> CHARACTER UNSIGNED -- )
  ROT IF ERROR-STR 2! -2 THROW ELSE 2DROP THEN ;

: .ERROR ( SIGNED -- )
  DECIMAL ?DUP
  IF CR SOURCE DROP >IN @ -TRAILING TYPE ."  ? "
     DUP -299 -0 WITHIN
     IF ERROR-MESSAGES SWAP CELLS- @ ?DUP IF COUNT TYPE THEN
     ELSE ." ERROR " .
     THEN CR .S
  THEN ;

: DEPTH! ( u -- )
  >R
  BEGIN DEPTH R@ > WHILE DROP REPEAT
  BEGIN DEPTH R@ < WHILE 0    REPEAT
  RDROP ;

: DEFER ( -- )
  ?EXECUTE DICT-CREATE ['] NOOP ,
  DEFERRED-ATTRIBUTE +ATTRIBUTE
  DOES> @ EXECUTE ;

: IS ( def -- )
  DUP PARSE-WORD ROT ['] DEFERRED SEARCH-ALL 0=
  IF 2DROP -269 THROW
  ELSE SWAP @ SWAP DICT>BODY !
  THEN ;

: (CATCH) ( xt n1 -- n2 )
  SOURCE-ID >R >IN @ >R SOURCE-SPEC 2@ 2>R DEPTH + >R CATCH DUP
  IF R> SWAP >R DEPTH! R> 2R> SOURCE-SPEC 2! R> >IN ! R> TO SOURCE-ID ?REFILL
  ELSE RDROP DRDROP DRDROP
  THEN ;

: STRONG-CATCH ( -- )
  S" EXECUTE" FALSE ['] MATCH SEARCH-ALL
  IF DEPTH-SP SWAP STATE @ DT>DT DROP DEPTH-SP - 1+ NEGATE STATE @
     IF POSTPONE LITERAL POSTPONE (CATCH)
     ELSE (CATCH)
     THEN [ (DT) SIGNED ] 2LITERAL >DT
  ELSE DROP -13 THROW
  THEN ;

: COLD ( -- )
  POSTPONE [ <LOCALS 0 TO SOURCE-ID DTP! 0 DEPTH! ;

: STRONG ( -- )
  ?EXECUTE COLD PROMPT CR
  BEGIN REFILL
  WHILE ['] INTERPRET CATCH
     CASE  0 OF PROMPT ENDOF
          -1 OF COLD ENDOF
          -2 OF COLD ERROR-STR 2@ TYPE ENDOF
        .ERROR COLD 0
     ENDCASE CR
  REPEAT ;

: ( ( -- flag sd )
  STATE @ POSTPONE [ DT-INPUT ;

' DUP EXPORT DUP ( SINGLE -- 1ST 1ST )
' 2DUP EXPORT DUP ( DOUBLE -- 1ST 1ST )
' DROP EXPORT DROP ( SINGLE -- )
' 2DROP EXPORT DROP ( DOUBLE -- )
' SWAP EXPORT SWAP ( SINGLE SINGLE -- 2ND 1ST )
' ROT EXPORT SWAP ( SINGLE DOUBLE -- 2ND 1ST )