Ниже приведен рабочий вариант немного переделанный вариант библиотечки для неструктурных GOTO
от MPE для spf. Комментарии из текста удалены при необходимости берутся из оригинального c2forth110.zip
REQUIRE LOCALS| ~af\lib\locals.f
REQUIRE AHEAD lib\include\tools.f
0 CONSTANT NULL
: BOUNDS ( addr u -- addr+u addr ) OVER + SWAP ;
: $. COUNT TYPE ;
: on ( a -- ) -1 SWAP ! ;
: off ( a -- ) 0! ;
: C+! ( c a -- ) +! ;
: toupper DUP [CHAR] a [CHAR] z 1+ WITHIN IF [CHAR] A [CHAR] a - + THEN ;
: upper ( a u -- ) OVER + SWAP DO I C@ toupper I C! LOOP ;
: upc \ v -- 'v
DUP [CHAR] a [CHAR] z WITHIN IF BL - THEN
;
: icompare \ c-addr1 u1 c-addr2 u2 -- flag
( *G CASE Insensitive version of the ANS COMPARE )
ROT SWAP \ c-addr1 c-addr2 u1 u2
2DUP - >R MIN \ c-addr1 c-addr2 minlen -- R: lendiff? --
BEGIN
DUP
WHILE
-ROT OVER C@ upc OVER C@ upc - \ length c-addr1 c-addr2 (char1-char2)
?DUP IF \ If chars are different
R> DROP >R \ replace lendiff result with error code
DROP 0 \ and put 0 on TOS (make len==0 at BEGIN)
ELSE \ otherwise
1+ SWAP 1+ SWAP ROT 1- \ increment addresses and decrement length
THEN
REPEAT
DROP 2DROP \ remove addresses and null count from stack
R> DUP IF 0< 1 OR THEN \ make nice flag, 0 becomes 0, -ve becomes -1
\ and +ve becomes 1
;
: zstrlen \ addr -- len
0 >R
BEGIN
DUP C@ 0<> IF R> 1+ >R 1+ 0
ELSE DROP -1
THEN
UNTIL
R>
;
: zcount \ zaddr -- zaddr len
DUP zstrlen
;
: >pos \ n --
( *G Used in diagnostic display. Move the cursor X position to column N )
\ out @ - 1 MAX SPACES
SPACES
;
\ =======================================================================
VARIABLE <periodic-resolve>
<periodic-resolve> on \ off
: periodic-resolve?
( *G Returns TRUE if periodic address resolution is required. )
<periodic-resolve> @
;
\ =======================================================================
( *S CPU Specific Tools. )
\ =======================================================================
4 CONSTANT size-of-machine-call
: get-parent-cfa \ xt -- addr:32
DUP 5 + SWAP
1+ @ +
;
: flush-opt \ --
\ POSTPONE [o/f]
;
: [literal] \ n -- ;
\ ['] LIT, COMPILE, ,
DIS-OPT POSTPONE LITERAL SET-OPT
\ POSTPONE LITERAL
;
: 'literal' \ dp n --
SWAP CELL + !
;
: CONSTANT-XT? \ xt -- flag
get-parent-cfa
['] TRUE get-parent-cfa =
;
: .dword \ n --
BASE @ >R HEX S>D <# # # # # # # # # #> TYPE R> BASE !
;
: c@s \ addr -- cell
( *G Fetch character from ADDR and sign extend to a CELL. )
C@ DUP 255 > IF 0x0FFFFFF00 OR THEN
;
: allot&erase \ n --
HERE SWAP DUP ALLOT ERASE
;
: char>cell \ signed-byte -- signed-int
DUP 0x80000000 AND IF 0x0FFFFFF00 OR THEN
;
256 CREATE CodeStream ALLOT
: ResetStream \ --
0 CodeStream C!
;
: EvalStream \ --
CodeStream COUNT EVALUATE
;
: $>stream \ c-addr u --
CodeStream COUNT + >R DUP CodeStream C+! R> SWAP MOVE
;
: h>stream \ n --
S" $" $>stream
BASE @ >R HEX S>D <# #S #> $>stream R> BASE !
;
\ =======================================================================
( *S The LABEL Chain Handlers )
\ =======================================================================
\ struct LBL
0
CELL FIELD LBL.link
CELL FIELD LBL.*name
CELL FIELD LBL.flags
CELL FIELD LBL.address
CONSTANT LBL \ end-struct
0x00000001 CONSTANT LF_PUBLIC
0x00000002 CONSTANT LF_ADDRESSVALID
0x00000004 CONSTANT LF_DATALABEL
0x00000008 CONSTANT LF_CODELABEL
0x00000010 CONSTANT LF_DELETE
0 VALUE LabelChain
: .label_flags \ n --
DUP LF_PUBLIC AND IF [CHAR] * ELSE BL THEN EMIT
DUP LF_ADDRESSVALID AND IF [CHAR] * ELSE BL THEN EMIT
DUP LF_DATALABEL AND IF [CHAR] * ELSE BL THEN EMIT
DUP LF_CODELABEL AND IF [CHAR] * ELSE BL THEN EMIT
DUP LF_DELETE AND IF [CHAR] * ELSE BL THEN EMIT
DROP
;
: .label \ *LABEL --
CR
DUP LBL.*name @ $. 40 >pos
DUP LBL.address @ .dword
SPACE
LBL.flags @ .label_flags
;
: .l \ --
CR ." Label List"
CR ." Name | Address |PADCK|"
LabelChain
BEGIN
?DUP
WHILE
DUP .label
LBL.link @
REPEAT
CR
;
: DestroyLabelChain \ --
LabelChain
BEGIN
?DUP
WHILE
DUP LBL.*name @ ?DUP IF FREE THROW THEN
DUP LBL.link @
SWAP FREE THROW
REPEAT
NULL TO LabelChain
;
: AddLabel \ c-addr u flags address --
LBL ALLOCATE ABORT" Failed to allocate label storage" >R
LabelChain R@ LBL.link !
R@ LBL.address !
R@ LBL.flags !
DUP 1 CHARS + ALLOCATE ABORT" Failed to allocate label sub storage"
DUP R@ LBL.*name !
2DUP C!
1 CHARS + SWAP MOVE
R> TO LabelChain
;
: FindLabel \ c-addr u -- *LABEL | NULL
2>R
LabelChain
BEGIN
?DUP
WHILE
DUP LBL.*name @ COUNT 2R@ icompare 0= IF
2R> 2DROP EXIT
THEN
LBL.link @
REPEAT
2R> 2DROP
0
;
: FindResolvedLabel \ c-addr u -- c-addr u 0 | address true
2DUP FindLabel
?DUP IF
DUP LBL.flags @ LF_ADDRESSVALID AND IF
NIP NIP
LBL.address @ TRUE EXIT
ELSE
DROP 0 EXIT
THEN
THEN
\ c-addr u --
2DUP upper
2DUP FORTH-WORDLIST SEARCH-WORDLIST
IF
NIP NIP
DUP CONSTANT-XT? IF EXECUTE THEN
TRUE
ELSE
0
THEN
;
: GarbageCollectLBL \ --
{ | new -- }
0 -> new
LabelChain
BEGIN
?DUP
WHILE
DUP LBL.link @ >R
DUP LBL.flags @ LF_DELETE AND IF \ trash?
DUP LBL.*name @
FREE THROW
FREE THROW
ELSE
new OVER LBL.link !
-> new
THEN
R>
REPEAT
new TO LabelChain
;
: ExportLBL \ *lbl --
DUP LBL.address @ SWAP \ address *lbl --
DUP LBL.*name @ COUNT ROT \ address c-addr u *lbl --
LBL.flags @ LF_CODELABEL AND \ address c-addr u code? --
ResetStream
IF
S" : " $>stream
$>stream
S" " $>stream
h>stream
S" execute ;" $>stream
ELSE
ROT h>stream
S" constant " $>stream
$>stream
THEN
EvalStream
;
: PatchLabel \ address iflag *LABEL --
>R
R@ LBL.flags @
DUP LF_ADDRESSVALID AND IF
CR ." PatchLabel allready has a valid address"
CR R@ LBL.*name @ $. CR CR
ABORT
THEN
OR LF_ADDRESSVALID OR R@ LBL.flags !
R> LBL.address !
;
: NewLabel \ address iflag c-addr u --
2SWAP LF_ADDRESSVALID OR SWAP AddLabel
;
: (label) \ address iflag "name" --
BL WORD COUNT \ address iflag c-addr u --
2DUP FindLabel \ address iflag c-addr u *LABEL|NULL
?DUP IF NIP NIP PatchLabel ELSE NewLabel THEN
;
: RemoveLocalLabels \ --
LabelChain
BEGIN
?DUP
WHILE
DUP LBL.flags @ LF_PUBLIC AND 0= IF
DUP LBL.flags DUP @ LF_DELETE OR SWAP !
THEN
LBL.link @
REPEAT
GarbageCollectLBL
;
: ExportPublics \ --
LabelChain
BEGIN
?DUP
WHILE
DUP LBL.flags @ LF_PUBLIC AND IF
DUP ExportLBL
DUP LBL.flags DUP @ LF_DELETE OR SWAP !
THEN
LBL.link @
REPEAT
GarbageCollectLBL
;
\ =======================================================================
( *S The Forward Reference Chain Handlers )
\ =======================================================================
0x00000001 CONSTANT FF_CELL
\ struct FW
0
CELL FIELD FW.link
CELL FIELD FW.*name \ when 0 means delete me!
CELL FIELD FW.here
CELL FIELD FW.offset
CELL FIELD FW.flags
CONSTANT FW \ end-struct
0 VALUE FWChain
: .fw \ *FW --
CR
DUP FW.*name @ ?DUP IF $. ELSE ." null record (delete)" THEN 30 >pos
DUP FW.offset @ .dword
SPACE
DUP FW.here @ .dword
SPACE
FW.flags @ FF_CELL AND IF ." Only a CELL" ELSE ." default: Literal RT" THEN
;
: .f \ --
CR ." Outstanding Forward Reference Literals"
CR ." Name | Offset | CodeAddress"
FWChain
BEGIN
?DUP
WHILE
DUP .fw
FW.link @
REPEAT
CR
;
: DestroyFWChain \ --
FWChain
BEGIN
?DUP
WHILE
DUP FW.*name @ ?DUP IF FREE THROW THEN
DUP FW.link @
SWAP FREE THROW
REPEAT
;
: $AddLitFW \ c-addr u -- *FW
DUP 1 CHARS + ALLOCATE ABORT" Failed namespace allocate for FW"
2DUP C! DUP >R 1 CHARS + SWAP MOVE
FW ALLOCATE ABORT" Failed allot for FW chain"
R> OVER FW.*name !
0 OVER FW.here !
0 OVER FW.offset !
0 OVER FW.flags !
FWChain OVER FW.link !
DUP TO FWChain
;
: Resolve \ *FW -- res?
DUP FW.*name @ COUNT
FindResolvedLabel
IF
\ *FW label-address --
OVER FW.offset @ + \ add any offset to resolved label address
OVER FW.here @ SWAP ROT \ dp n fw --
FW.flags @ FF_CELL AND IF
OVER - SWAP size-of-machine-call - ! \ resolve CELL
ELSE
'literal' \ do the resolve for literal
THEN
TRUE \ flag, DONE IT!
ELSE
\ *FW c-addr u -- ; No resolved label, cannot resolve fw
2DROP
DROP
FALSE
THEN
;
: GarbageCollectFW \ --
{ | new -- }
0 -> new
FWChain
BEGIN
?DUP
WHILE
DUP FW.link @ >R
DUP FW.*name @ IF
new OVER FW.link ! \ attach to new chain (still active)
-> new
ELSE
FREE THROW \ remove
THEN
R>
REPEAT
new TO FWChain
;
: ResolveFW \ --
FWChain
BEGIN
?DUP
WHILE
DUP Resolve IF
DUP FW.*name DUP @ FREE THROW off \ free name memory and mark
\ for delete
THEN
FW.link @
REPEAT
GarbageCollectFW
;
\ =======================================================================
( *S Compilers )
\ =======================================================================
CREATE name-store 256 ALLOT
: >name-store \ c-addr u -- 'c-addr u
DUP name-store C!
name-store 1 CHARS + SWAP MOVE
name-store COUNT
;
: ParseNumericOffset \ "offset" -- val
\ BL WORD NUMBER? 1 <> ABORT" non-numeric offset used"
\ BL WORD DROP 0 \ ?SLITERAL1 !!!!
\ !!! пока процедура заглушена на выдачу всегда 0
0 S>D BL WORD COUNT >NUMBER 2DROP D>S
;
: CommaAddr \ "symbol" "offset" --
BL WORD COUNT >name-store
FindResolvedLabel
IF
ParseNumericOffset +
,
EXIT
THEN
flush-opt
$AddLitFW >R \ *FW --
HERE R@ FW.here !
ParseNumericOffset
R@ FW.offset !
FF_CELL R> FW.flags !
0 ,
; IMMEDIATE
: CompileAddrLit \ "symbol" "offset" --
BL WORD COUNT
>name-store
FindResolvedLabel
IF \ Found Symbol: address--
ParseNumericOffset +
POSTPONE LITERAL
EXIT
THEN \ No Symbol: c-addr u --
flush-opt
$AddLitFW >R \ *FW --
HERE R@ FW.here !
ParseNumericOffset
R> FW.offset !
-1 DIS-OPT POSTPONE LITERAL \ [literal]
HERE DROP \ !дополнительная блокировка оптимизатора.
SET-OPT
; IMMEDIATE
: CompileCall \ "symbol" --
BL WORD COUNT
>name-store
FindResolvedLabel
IF
\ DUP ?compile-pause
COMPILE,
EXIT
THEN
flush-opt
$AddLitFW >R \ *FW --
0 COMPILE, \ [literal]
HERE R@ FW.here !
FF_CELL R> FW.flags !
; IMMEDIATE
\ ----
\ : CompileJump \ --
\ POSTPONE >R
\ ['] EXIT COMPILE, \ doexit,
\ ; IMMEDIATE
: CompileJump ( xt -- ) \ +хчєёыютэvщ яхЁхїюф яю рфЁхёє эр ёЄхъх
DIS-OPT
[ HERE DROP ]
0x8B C, 0xD8 C, \ MOV EBX, EAX
0x8B C, 0x45 C, 0x00 C, \ MOV EAX, 0 [EBP]
0x8D C, 0x6D C, 0x04 C, \ LEA EBP, 4 [EBP]
0xFF C, 0xE3 C, \ JMP EBX
SET-OPT
; IMMEDIATE
: CompileBranch \ "symbol" --
BL WORD COUNT >name-store
FindResolvedLabel
IF
POSTPONE AHEAD DROP
DUP ROT SWAP - 4 - SWAP !
ELSE
flush-opt
$AddLitFW >R
0 POSTPONE AHEAD DROP ! \ [literal]
HERE R@ FW.here !
FF_CELL R> FW.flags !
THEN
; IMMEDIATE
: CompileCondBranch \ "symbol" --
POSTPONE IF
POSTPONE CompileBranch
POSTPONE THEN
; IMMEDIATE
\ =======================================================================
( *S Label Definitions )
\ =======================================================================
: FLABEL \ "name" --
flush-opt
HERE \ NoNameGap
LF_CODELABEL
(label)
; IMMEDIATE
: LABEL \ "name" --
flush-opt
HERE
LF_DATALABEL
(label)
; IMMEDIATE
: PUBLIC \ "name" --
\ periodic-resolve? IF ResolveFW THEN
BL WORD
DROP \ COUNT LF_PUBLIC -1 AddLabel
;
\ IMMEDIATE
: EXTERN \ "name" --
BL WORD DROP
;
: ENDPROC \ "name" --
periodic-resolve? IF ResolveFW THEN
BL WORD COUNT LF_PUBLIC -1 AddLabel
; IMMEDIATE
\ EOF \ Тестовая секция
: U>= U< 0= ;
PUBLIC _fib
: _fib
FLABEL _fib
{ $arg0 \ $loc[ 8 ] -- }
^ $arg0 @
2 U>=
CompileCondBranch @2
1 CompileAddrLit @1 0
CompileJump
LABEL @2
^ $arg0 @
2 -
CompileAddrLit _fib 0
EXECUTE \ Was ICALL
$loc[ 4 + !
^ $arg0 @
1 -
CompileAddrLit _fib 0
EXECUTE \ Was ICALL
$loc[ 0 + !
$loc[ 4 + @
$loc[ 0 + @
+
LABEL @1
;
ENDPROC
32 _fib .
P.S. Доработанный вариант можно поместить в devel spf.
Доработки на дальнейшее усмотрение разработчиков spf.
Вход
Регистрация
Благодарности
Forth-FAQ
Сейчас делаю очередную попытку, получается (в идейной проработке, а не в прогах 
