corelib.sf

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

\ Copyright (C) 2008 Stephan Becher
\
\ This file is part of StrongForth.f.
\
\ StrongForth.f is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ StrongForth.f is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with StrongForth.f; if not, write to the Free Software
\ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
\
\ Contact: [e-mail]

: NULL ( -- )
  " 0" EVALUATE POSTPONE CAST ; IMMEDIATE

: DROP-S ( -- )
  " (DROP-S)" ?DT>DT DROP ;

: DROP-S' ( -- )
  " (DROP-S')" ?DT>DT DROP ;

: 2DROP-S ( -- )
  " (2DROP-S)" ?DT>DT DROP ;

: AHEAD ( -- ORIG )
  ?COMPILE (AHEAD) FREEZE >CF DTP| ; IMMEDIATE

: IF ( -- ORIG )
  DROP-S (IF) FREEZE >CF ; IMMEDIATE

: THEN ( ORIG -- )
  ?COMPILE CF> THAW (THEN) ; IMMEDIATE

: ELSE ( ORIG -- 1ST )
  ?COMPILE FREEZE DTP| CF> SWAP >CF THAW (ELSE) ; IMMEDIATE

: BEGIN ( -- DEST )
  ?COMPILE (BEGIN) FREEZE >CF ; IMMEDIATE

: AGAIN ( DEST -- )
  ?COMPILE CF> THAW DTP| (AGAIN) ; IMMEDIATE

: UNTIL ( DEST -- )
  DROP-S CF> THAW (UNTIL) ; IMMEDIATE

: WHILE ( DEST -- ORIG 1ST )
  DROP-S (WHILE) CF> FREEZE >CF >CF ; IMMEDIATE

: REPEAT ( ORIG DEST -- )
  ?COMPILE CF> THAW DTP| CF> THAW (REPEAT) ; IMMEDIATE

: CASE ( -- CASE-SYS ) 
  ?COMPILE (CASE) NULL CONTROL-FLOW >CF FREEZE >CF ; IMMEDIATE

: ENDCASE ( CASE-SYS -- )
  CF> DROP DROP-S CF> DUP IF THAW ELSE DROP THEN (ENDCASE) ; IMMEDIATE

: OF ( CASE-SYS -- 1ST OF-SYS )
  DROP-S' CF> DUP >CF THAW (OF) DROP-S ; IMMEDIATE

: ENDOF ( CASE-SYS OF-SYS -- 1ST )
  ?COMPILE CF> CF> DUP
  IF DUP THAW
  ELSE DROP FREEZE
  THEN >CF >CF (ENDOF) DTP| CF> DUP >CF THAW ; IMMEDIATE

: NEST-DO ( -- CONTROL-FLOW )
  FREEZE " I" OVER OVER SEARCH-LOCAL
  IF +1 NESTING ELSE DROP THEN CREATE-LOCAL DUP DICT, ;

: DO ( -- DO-SYS )
  2DROP-S (DO) NEST-DO >CF ; IMMEDIATE

: ?DO ( -- DO-SYS )
  2DROP-S (?DO) NEST-DO >CF ; IMMEDIATE

: ?LOOP ( -- ADDRESS -> DATA-TYPE )
  ?COMPILE " I" SEARCH-LOCAL 0= IF -26 THROW THEN ;

: NEST-LOOP ( CONTROL-FLOW -- )
  THAW FORGET-LOCAL " J" SEARCH-LOCAL
  IF -1 NESTING ELSE DROP THEN ;

: LOOP ( DO-SYS -- )
  ?LOOP @>DT " (STEP-S)" ?DT>DT CF> NEST-LOOP LOOP, ; IMMEDIATE

: +LOOP ( DO-SYS -- )
  ?LOOP @>DT " (+STEP-S)" ?DT>DT CF> NEST-LOOP +LOOP, ; IMMEDIATE

: LEAVE ( -- )
  ?LOOP DT+ CAST ADDRESS -> CONTROL-FLOW @ THAW DTP| (LEAVE) ; IMMEDIATE

: UNLOOP ( -- )
  ?LOOP DROP POSTPONE (UNLOOP) ; IMMEDIATE

: CHAR ( -- CHARACTER )
  PARSE-WORD IF @ ELSE DROP BL THEN ;

: [CHAR] ( -- )
  ?COMPILE CHAR [LITERAL] ; IMMEDIATE

: ['] ( -- )
  ?COMPILE ' [LITERAL] ; IMMEDIATE

: [DT] ( -- ) 
  ?COMPILE DT [LITERAL] ; IMMEDIATE

: BIT ( UNSIGNED -- LOGICAL )
  1 CAST LOGICAL SWAP LSHIFT ;

: PROCREATES ( DATA-TYPE -- )
  CREATE SPLIT , DROP LATEST >TOKEN , 8 BIT +ATTRIBUTE
  DOES> ( STACK-DIAGRAM ADDRESS -> TOKEN -- 1ST )
  0 SWAP MERGE CAST DATA-TYPE (PARAM) ;

: SIGN ( FLAG -- )
  IF [CHAR] - HOLD THEN ;

: ." ( -- )
  STATE @
  IF POSTPONE " POSTPONE TYPE
  ELSE [CHAR] " PARSE TYPE
  THEN ; IMMEDIATE

: .( ( -- )
  [CHAR] ) PARSE STATE @
  IF POSTPONE SLITERAL POSTPONE TYPE
  ELSE TYPE
  THEN ; IMMEDIATE

: . ( FLAG -- )
  IF ." TRUE " ELSE ." FALSE " THEN ;

: LITERAL ( SINGLE -- )
  ?COMPILE POSTPONE [ DTP@ ] @>DT LITERAL, ; IMMEDIATE

: LITERAL ( DOUBLE -- )
  ?COMPILE POSTPONE [ DTP@ ] @>DT LITERAL, ; IMMEDIATE

: )' ( FLAG STACK-DIAGRAM -- DEFINITION )
  <DIAGRAM DUP OFFSET PARSE-WORD ROT
  [ ' IDENTITY >TOKEN CAST SEARCH-CRITERION ] LITERAL SEARCH-ALL
  0= IF -13 THROW THEN SWAP DIAGRAM> ;

: ALIAS ( DEFINITION -- )
  ?EXECUTE >TOKEN (CREATE) END-DEF ;

: LOCALS| ( COLON-SYS -- 1ST )
  BEGIN PARSE-WORD OVER OVER " |" COMPARE
  WHILE DUP 0= IF -263 THROW THEN (LOCAL)
  REPEAT 1- (LOCAL) ; IMMEDIATE

: [COMPILE] ( -- )
  ?COMPILE PARSE-WORD TRUE
  [ ' MATCH >TOKEN CAST SEARCH-CRITERION ] LITERAL SEARCH-ALL
  IF COMPILE,
  ELSE DROP -13 THROW
  THEN ; IMMEDIATE

: SAVE-INPUT ( -- INPUT-SOURCE )
  NEW-TUPLE SOURCE-ID
  IF SOURCE-ID STRING-ID <>
     IF -> FILE SOURCE-ID >T CAST TUPLE
     THEN -> DOUBLE SOURCE-SPEC @ >T CAST TUPLE
  THEN -> UNSIGNED >IN @ >T CAST INPUT-SOURCE ;

: RESTORE-INPUT ( INPUT-SOURCE -- FLAG )
  CAST TUPLE -> UNSIGNED SIZE
  CASE 1 OF T> >IN ! DROP SOURCE-ID 0<> ENDOF
       3 OF T> >IN ! CAST TUPLE -> DOUBLE T> SOURCE-SPEC @ <>
            SOURCE-ID 0= OR >R DROP R> ENDOF
       4 OF T> >IN ! CAST TUPLE -> DOUBLE T> SOURCE-SPEC !
            CAST TUPLE -> FILE T> SOURCE-ID <>
            >R DROP R> ?REFILL ENDOF
       >R DROP TRUE R>
  ENDCASE ;

: ABORT" ( -- )
  ?COMPILE POSTPONE " POSTPONE (ABORT") ; IMMEDIATE

: )CAST ( FLAG STACK-DIAGRAM -- )
  <DIAGRAM DUP OFFSET DICT-HERE -> DATA-TYPE OVER - SWAP
  STATE @ (CAST) DIAGRAM> ; IMMEDIATE

: )PROCREATES ( FLAG STACK-DIAGRAM -- )
  <DIAGRAM ENCLOSE-DIAGRAM [DT] TOKEN PROCREATES LATEST >R
  " ' (EXECUTE) >TOKEN (CREATE) EXECUTE" EVALUATE
  OVER OVER 
  ?DO I @ DT-OUTPUT ATTRIBUTE? IF LEAVE THEN 1+ I @ DICT, LOOP
  ROT R> ?DATA-TYPE DT-INPUT OR PARAM, ROT ROT
  ?DO I @ DICT, LOOP END-DIAGRAM END-DEF ;

: NEXT ( DEFINITION -- 1ST )
  DUP PARAMS SWAP #PARAMS +
  CAST CADDRESS -> UNSIGNED NAME>DEFINITION ;

: ?SUBTOKEN ( DATA-TYPE -- )
  PARENT [DT] TOKEN <> IF -265 THROW THEN ;

: ?IS-EXECUTE ( DEFINITION -- )
  NAME " EXECUTE" COMPARE IF -265 THROW THEN ;

: ?SAME-DATA-TYPE ( DATA-TYPE -- )
  DT> ROT ROT <> OR IF -265 THROW THEN ;

: ?TOKEN ( DATA-TYPE -- TOKEN )
  DUP ?SUBTOKEN DUP ?DEFINITION
  NEXT DUP ?IS-EXECUTE
  STATE @ >R ] DICT-HERE >R FREEZE >R
  DTP! DUP #PARAMS ALL-PARAMS>DT
  SWAP ?SAME-DATA-TYPE
  PARSE-WORD ROT
  [ ' MATCH >TOKEN CAST SEARCH-CRITERION ] LITERAL SEARCH-ALL
  DTP| R> THAW R> DICT-HERE - DICT-ALLOT R> STATE!
  IF >TOKEN
  ELSE DROP -258 THROW NULL TOKEN
  THEN ;

: * ( SIGNED-DOUBLE SIGNED -- 1ST )
  DUP 0<
  IF ABS CAST UNSIGNED * NEGATE
  ELSE CAST UNSIGNED *
  THEN ;

: */ ( SIGNED-DOUBLE SIGNED SIGNED -- 1ST )
  CAST UNSIGNED ROT DUP 0<
  IF ABS CAST UNSIGNED-DOUBLE ROT DUP 0<
     IF ABS CAST UNSIGNED ROT */
     ELSE CAST UNSIGNED ROT */ NEGATE
     THEN
  ELSE CAST UNSIGNED-DOUBLE ROT DUP 0<
     IF ABS CAST UNSIGNED ROT */ NEGATE
     ELSE CAST UNSIGNED ROT */
     THEN
  THEN CAST SIGNED-DOUBLE ;

' ENVIRONMENT VOC-LINK !
' LOCAL ' ENVIRONMENT >BODY 1 CELLS + -> DEFINITION !
' FORTH ' LOCAL >BODY 1 CELLS + -> DEFINITION !

: GET-ORDER ( -- TUPLE -> WID )
  NEW-TUPLE -> WID #ORDER @
  IF CONTEXT DUP #ORDER @ + 1- DO I @ >T -1 +LOOP
  THEN ;

: SET-ORDER ( -- )
  FORTH-WORDLIST CONTEXT ! 1 #ORDER ! ;

: SET-ORDER ( TUPLE -> WID -- )
  SIZE #VOCS >
  IF -49 THROW
  ELSE SIZE DUP #ORDER ! CONTEXT SWAP + CONTEXT ?DO T> I ! LOOP
  THEN DROP ;

: DEFINITIONS ( -- )
  CONTEXT @ SET-CURRENT ;

: VOCABULARY ( -- )
  CREATE WORDLIST DROP VOC-LINK @ , LATEST VOC-LINK ! 12 BIT +ATTRIBUTE
  DOES> ( WID -- )
  #ORDER @ 0= IF -50 THROW THEN CONTEXT ! ;

: ?DEFINITION ( WID -- DEFINITION )
  VOC-LINK @
  BEGIN OVER OVER >BODY CAST WID <>
  WHILE >BODY 1 CELLS + -> DEFINITION @ DUP 0=
     IF NIP EXIT THEN
  REPEAT NIP ;

: . ( WID -- )
  ?DEFINITION DUP 0=
  IF DROP ." ??? " ELSE NAME TYPE SPACE THEN ;

: ORDER ( -- )
  CR ." CURRENT: " GET-CURRENT .
  CR ." CONTEXT: " GET-ORDER BEGIN SIZE WHILE T> . REPEAT DROP ;

: ALSO ( -- )
  GET-ORDER T> DUP >R >T R> >T SET-ORDER ;

: ONLY ( -- )
  SET-ORDER ;

: PREVIOUS ( -- )
  GET-ORDER T> DROP SET-ORDER ;

: LAST ( WID -- DEFINITION )
  CAST ADDRESS -> ADDRESS @ DUP
  IF CAST CADDRESS -> UNSIGNED NAME>DEFINITION
  ELSE CAST DEFINITION
  THEN ;

: FIRST ( WID -- DEFINITION )
  LAST DUP 0= INVERT
  IF BEGIN DUP PREV DUP
     WHILE NIP
     REPEAT DROP
  THEN ;

\ EOF