Привет всем!
Вот так я это вижу.
Мне кажется, что проще менять целиком весь словарь чтения, чем
добавлять/удалять по одному слову.
Последнее, впрочем, тоже возможно, если пользоватеься MARKER или
написать специальные слова удаления слов из словаря и добавления после
определенного (работа со словарем как со списком).
В общем, дело упирается в негибкость словаря как структуры. А это самый
сложный тип данных Форта :-(
Ю. Жиловец
\ ×àñòî òðåáóþùèåñÿ îïðåäåëåíèÿ, asciiz-ñòðîêè
\ Âåðñèÿ 1.10
\ Þ. Æèëîâåö,
http://www.forth.org.ru/~yzREQUIRE =OF ~yz/lib/mycase.f
CREATE "" 0 ,
: == CONSTANT ;
: VAR ( -- ) 0 VALUE ;
: UVAR ( -- ) USER-VALUE ;
: PRESS NIP ;
: NOT INVERT ;
: -! ( n a --) SWAP NEGATE SWAP +! ;
: CELL+! CELL SWAP +! ;
: CELL-! CELL SWAP -! ;
: CELLS+ CELLS + ;
: CELLS@ CELLS+ @ ;
: CELLS! CELLS+ ! ;
: CELL" ( ->") [CHAR] " PARSE DROP @ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE
: LOWORD [ 0x0F C, 0xBF C, 0xC0 C, ] ; \ movsx eax,ax
: HIWORD ( n--n) 16 RSHIFT LOWORD ;
: ON ( a--) TRUE SWAP ! ;
: OFF ( a--) 0! ;
: ? @ . ;
: 1-! -1 SWAP +! ;
: c: POSTPONE [CHAR] ; IMMEDIATE
: ZLEN ( z -- #) DUP
BEGIN DUP C@ WHILE 1+ REPEAT
SWAP - ;
: CZMOVE ( a # z --) 2DUP + >R SWAP CMOVE R> 0 SWAP C! ;
: ZMOVE ( z a --) OVER ZLEN 1+ CMOVE ;
: s. SP@ S0 @ CELL - 2DUP -
DUP 4 = IF DROP 2DROP ." Stack is empty" CR EXIT THEN
4 > IF 2DROP ." Stack is underflowed" CR EXIT THEN
DO I @ . CELL NEGATE +LOOP CR ;
: .ASCIIZ ( z--) ASCIIZ> TYPE ;
: Z>NUMBER ( z--n true / false)
0 0 ROT ASCIIZ> >NUMBER PRESS IF 2DROP FALSE ELSE D>S TRUE THEN ;
VARIABLE toadr VARIABLE fromadr VARIABLE counter
: [yz]char ( --c/-1) counter @ 1 <
IF -1 ELSE counter 1-! fromadr @ C@ fromadr 1+! THEN ;
: unchar counter 1+! fromadr 1-! ;
: c> ( c--) toadr @ C! toadr 1+! ;
: escape ( c--c ) CASE
-1 OF 0 ENDOF
c: n OF 10 ENDOF
c: r OF 13 ENDOF
c: t OF 9 ENDOF
c: q OF c: " ENDOF
c: ' OF c: " ENDOF
DUP c: 0 c: 9 WITHIN IF
c: 0 -
BEGIN ( n) [yz]char DUP c: 0 c: 9 WITHIN WHILE
( n c) c: 0 - SWAP 10 * +
REPEAT -1 <> IF unchar THEN
THEN
END-CASE ;
: ESC-CZMOVE ( a # to --)
toadr ! counter ! fromadr !
BEGIN
[yz]char CASE
-1 OF 0 ENDOF
c: \ OF [yz]char escape ENDOF
END-CASE
DUP c> 0= UNTIL ;
: ALITERAL R> DUP ASCIIZ> + 1+ >R ;
: ?ALITERAL ( a # -- ; -- a)
STATE @ IF
POSTPONE ALITERAL
HERE DUP >R ESC-CZMOVE R> ZLEN 1+ ALLOT
ELSE
PAD 512 + ESC-CZMOVE PAD 512 +
THEN
;
: " ( -->") c: " PARSE ( a #) ?ALITERAL ; IMMEDIATE
: Z" [COMPILE] " ; IMMEDIATE
: ASCIIZ ( z -- ; ->bl)
CREATE HERE ( z here) OVER ZLEN 1+ DUP >R CMOVE R> ALLOT ;
: .H BASE @ HEX SWAP ." 0x" U. BASE ! ;
\ óãëóáëÿåò ñòåê íà n çíà÷åíèé. Òðåáóåòñÿ äëÿ ïðîöåäóð ñ ïàðàìåòðàìè,
\ îïèñûâàåìûìè ÷åðåç WNDPROC
: PARAMS ( n --) CELLS S0 +! ;
\ ------------------------------------
: GETMEM ( # -- a) ALLOCATE THROW ;
: FREEMEM ( a -- ) FREE THROW ;
WINAPI: FormatMessageA KERNEL32.DLL
: dll-error ( -- n) GetLastError ;
: error-text ( err -- a)
\ âûäåëåííûé áóôåð ïîäëåæèò îñâîáîæäåíèþ
>R 512 DUP GETMEM ( 512 a) DUP >R SWAP 0 SWAP R> 0 R> 0 0x1000 ( format_message_from_system)
FormatMessageA DROP
;
: .ansiz ( z -- ) ASCIIZ> ANSI>OEM TYPE ;
: .err ( err# --) DUP .H
error-text DUP .ansiz FREEMEM ;
: .lerr dll-error .err ;
WINAPI: MultiByteToWideChar KERNEL32.DLL
WINAPI: WideCharToMultiByte KERNEL32.DLL
: >unicode ( z a -- )
SWAP DUP >R ZLEN 1+ 2* SWAP -1 R> 0 0 MultiByteToWideChar DROP ;
: >unicodebuf ( z -- a) \ çàïèñûâàåò ñòðîêó â âûäåëåííûé áóôåð è âîçâðàùàåò
\ åãî àäðåñ. Áóôåð ïîäëåæèò îñâîáîæäåíèþ
DUP >R ZLEN 1+ 2* DUP GETMEM ( # a) SWAP OVER
-1 R> 0 0 MultiByteToWideChar DROP ;
: unicode> ( a z --)
SWAP >R >R 0 0 256 R> -1 R> 0 0 WideCharToMultiByte DROP ;
: unicode>buf ( a -- z) \ çàïèñûâàåò ñòðîêó â âûäåëåííûé áóôåð è âîçâðàùàåò
\ åãî àäðåñ. Áóôåð ïîäëåæèò îñâîáîæäåíèþ
>R
0 0 0 0 -1 R@ 0 0 WideCharToMultiByte ( ïîëó÷èëè äëèíó ñòðîêè)
1+ DUP GETMEM ( # a) SWAP OVER 0 0 2SWAP
-1 R> 0 0 WideCharToMultiByte DROP ;
: .unicode ( a -- ) unicode>buf DUP .ansiz FREEMEM ;
: CZGETMEM ( a n -- a) DUP 1+ GETMEM DUP >R CZMOVE R> ;
: ZGETMEM ( z -- a) ASCIIZ> CZGETMEM ;
WINAPI: lstrcmp KERNEL32.DLL
WINAPI: lstrcat KERNEL32.DLL
: ZCOMPARE ( z1 z2 -- n) lstrcmp ;
: ZAPPEND ( z1 z2 -- ) SWAP lstrcat DROP ;
: 0APPEND ( z -- ) ASCIIZ> + 1+ 0 SWAP C! ;
: SAPPEND ( a1 n1 a2 n2 -- ) DUP >R 2OVER + SWAP CMOVE R> + ;
\ Ìàêðîñû ÷òåíèÿ
\ Þ. Æèëîâåö, 20.03.2007
REQUIRE WORDLIST: ~yz/lib/order.f
REQUIRE { lib/ext/locals.f
REQUIRE ALITERAL ~yz/lib/common.f
0 VALUE READ-MACROS
: LINK ( ->bl; -- )
NextWord 2DUP SFIND IF
ROT ROT SHEADER BRANCH,
ELSE
-2003 THROW
THEN
;
\ Îïðåäåëåíèÿ äîëæíû èäòè â îáðàòíîì ïîðÿäêå: îò ñàìîãî ðåäêîãî
\ äî ñàìîãî ÷àñòîãî
\ Ïåðâûì äîëæíî ñòîÿòü last-resort
: last-resort ( ... a # -- ... ? )
S" NOTFOUND" SFIND IF
EXECUTE
ELSE
2DROP -2003 THROW
THEN TRUE
;
: is-string ( ... a # -- ... ? )
2DUP + 1- C@ [CHAR] ' = 2 PICK C@ [CHAR] ' = AND DUP >R IF
2- SWAP 1+ SWAP [COMPILE] SLITERAL
ELSE
2DROP
THEN
R>
;
: is-asciiz ( ... a # -- ... ? )
2DUP + 1- C@ [CHAR] " = 2 PICK C@ [CHAR] " = AND DUP >R IF
2- SWAP 1+ SWAP ?ALITERAL
ELSE
2DROP
THEN
R>
;
: is-hex ( ... a # -- ... ? )
DUP 1 > 2 PICK W@ 0x7830 ( "0x") = AND IF
HEX-SLITERAL
ELSE
2DROP FALSE
THEN
;
: is-number ( ... a # -- ... ? )
0 0 2SWAP
OVER C@ [CHAR] - = IF 1- SWAP 1+ SWAP TRUE ELSE FALSE THEN >R
>NUMBER
DUP 1 > IF 2DROP 2DROP RDROP FALSE EXIT THEN
IF C@ [CHAR] . <> IF 2DROP RDROP FALSE EXIT THEN
R> IF DNEGATE THEN
[COMPILE] 2LITERAL
ELSE DROP D>S
R> IF NEGATE THEN
[COMPILE] LITERAL
THEN TRUE
;
: find-in-wordlists ( ... a # -- ... ? )
SFIND ?DUP IF
STATE @ =
IF COMPILE, ELSE EXECUTE THEN
TRUE
ELSE
2DROP FALSE
THEN
;
WORDLIST: FORTH-READ-MACROS
LINK last-resort
LINK is-string
LINK is-asciiz
LINK is-hex
LINK is-number
LINK find-in-wordlists
WORDLIST;
FORTH-READ-MACROS TO READ-MACROS
: traverse-read-macros { a n \ ptr -- }
READ-MACROS @ TO ptr
BEGIN
ptr ?DUP
WHILE
\ DUP ID.
NAME> a n ROT EXECUTE IF EXIT THEN
ptr CDR TO ptr
REPEAT
;
:NONAME ( -> )
BEGIN
NextWord DUP
WHILE
\ 42 EMIT s.
( a n ) traverse-read-macros
\ 42 EMIT 42 EMIT s.
?STACK
REPEAT 2DROP
; &INTERPRET !
( 0x100 200 + .
"hello" .ASCIIZ
'giid' TYPE
BYE
)
attachment0 (187 bytes) 
