keXa/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity
09488af869
kolibrios/programs/develop/SPForth/devel/~mak/lib/locals4.f
Kirill Lipatov (Leency) 09488af869 KolSPForth12 uploaded to SVN 
git-svn-id: svn://kolibrios.org@4867 a494cfbc-eb01-0410-851d-a64ba20cac60
2014-04-21 19:22:58 +00:00

402 lines
8.4 KiB
Forth
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

( 28.Mar.2000 Andrey Cherezov Copyright [C] RU FIG
ˆá¯®«ì§®¢ ­ë ¨¤¥¨ á«¥¤ãîé¨å  ¢â®à®¢:
Ruvim Pinka; Dmitry Yakimov; Oleg Shalyopa; Yuriy Zhilovets;
Konstantin Tarasov; Michail Maximov.
!! <EFBFBD> ¡®â ¥â ⮫쪮 ¢ SPF4.
)
( <EFBFBD>à®á⮥ à áè¨à¥­¨¥ ‘<EFBFBD>-”®àâ  «®ª «ì­ë¬¨ ¯¥à¥¬¥­­ë¬¨.
<EFBFBD>¥ «¨§®¢ ­® ¡¥§ ¨á¯®«ì§®¢ ­¨ï LOCALS áâ ­¤ àâ  94.
Ž¡ê¥­¨¥ ¢à¥¬¥­­ëå ¯¥à¥¬¥­­ëå, ¢¨¤¨¬ëå ⮫쪮 ¢­ãâà¨
⥪ã饣® á«®¢  ¨ ®£à ­¨ç¥­­ëå ¢à¥¬¥­¥¬ ¢ë§®¢  ¤ ­­®£®
á«®¢  ¢ë¯®«­ï¥âáï á ¯®¬®éìî á«®¢  "{". ‚­ãâਠ®¯à¥¤¥«¥­¨ï
á«®¢  ¨á¯®«ì§ã¥âáï ª®­áâàãªæ¨ï, ¯®¤®¡­ ï á⥪®¢®© ­®â æ¨¨ ”®àâ 
{ ᯨ᮪_¨­¨æ¨ «¨§¨à®¢ ­­ëå_«®ª «®¢ \ á¯.­¥¨­¨æ.«®ª «®¢ -- ç⮠㣮¤­® }
<EFBFBD> ¯à¨¬¥à:
{ a b c d \ e f -- i j }
ˆ«¨ { a b c d \ e f[ EVALUATE_¢ëà ¦¥­¨¥ ] -- i j }
<EFBFBD>â® §­ ç¨â çâ® ¤«ï ¯¥à¥¬¥­­®© f[ ¡ã¤¥â ¢ë¤¥«¥­ ­  á⥪¥ ¢®§¢à â®¢ ãç á⮪
¯ ¬ï⨠¤«¨­®© n ¡ ©â. ˆá¯®«ì§®¢ ­¨¥ ¯¥à¥¬¥­­®© f[ ¤ áâ  ¤à¥á ­ ç «  í⮣®
ãç á⪠. \‚ á⨫¥ MPE\
ˆ«¨ { a b c d \ e [ 12 ] f -- i j }
<EFBFBD>â® §­ ç¨â çâ® ¤«ï ¯¥à¥¬¥­­®© f ¡ã¤¥â ¢ë¤¥«¥­ ­  á⥪¥ ¢®§¢à â®¢ ãç á⮪
¯ ¬ï⨠¤«¨­®© 12 ¡ ©â. ˆá¯®«ì§®¢ ­¨¥ ¯¥à¥¬¥­­®© f ¤ áâ  ¤à¥á ­ ç «  í⮣®
ãç á⪠.
— áâì "\ á¯.­¥¨­¨æ.«®ª «®¢" ¬®¦¥â ®âáãâá⢮¢ âì, ­ ¯à¨¬¥à:
{ item1 item2 -- }
<EFBFBD>â® § áâ ¢«ï¥â ‘<EFBFBD>-”®àâ  ¢â®¬ â¨ç¥áª¨ ¢ë¤¥«ïâì ¬¥áâ® ¢
á⥪¥ ¢®§¢à â®¢ ¤«ï íâ¨å ¯¥à¥¬¥­­ëå ¢ ¬®¬¥­â ¢ë§®¢  á«®¢ 
¨  ¢â®¬ â¨ç¥áª¨ ®á¢®¡®¦¤ âì ¬¥áâ® ¯à¨ ¢ë室¥ ¨§ ­¥£®.
Ž¡à é¥­¨¥ ª â ª¨¬ «®ª «ì­ë¬ ¯¥à¥¬¥­­ë¬ - ª ª ª VALUE-¯¥à¥¬¥­­ë¬
¯® ¨¬¥­¨. …᫨ ­ã¦¥­  ¤à¥á ¯¥à¥¬¥­­®©, â® ¨á¯®«ì§ã¥âáï "^ ¨¬ï"
¨«¨ "AT ¨¬ï".
‚¬¥áâ® \ ¬®¦­® ¨á¯®«ì§®¢ âì |
‚¬¥áâ® -> ¬®¦­® ¨á¯®«ì§®¢ âì TO
<EFBFBD>ਬ¥àë:
: TEST { a b c d \ e f -- } a . b . c . b c + -> e e . f . ^ a @ . ;
Ok
1 2 3 4 TEST
1 2 3 5 0 1 Ok
: TEST { a b -- } a . b . CR 5 0 DO I . a . b . CR LOOP ;
Ok
12 34 TEST
12 34
0 12 34
1 12 34
2 12 34
3 12 34
4 12 34
Ok
: TEST { a b } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { a b -- } a . b . ;
Ok
1 2 TEST
1 2 Ok
: TEST { a b \ c -- d } a . b . c . ;
Ok
1 2 TEST
1 2 0 Ok
: TEST { \ a b } a . b . 1 -> a 2 -> b a . b . ;
Ok
TEST
0 0 1 2 Ok
ˆ¬¥­  «®ª «ì­ëå ¯¥à¥¬¥­­ëå áãé¥áâ¢ãîâ ¢ ¤¨­ ¬¨ç¥áª®¬
¢à¥¬¥­­®¬ á«®¢ à¥ ⮫쪮 ¢ ¬®¬¥­â ª®¬¯¨«ï樨 á«®¢ ,  
¯®á«¥ í⮣® ¢ëç¨é îâáï ¨ ¡®«¥¥ ­¥¤®áâ㯭ë.
ˆá¯®«ì§®¢ âì ª®­áâàãªæ¨î "{ ... }" ¢­ãâਠ®¤­®£® ®¯à¥¤¥«¥­¨ï ¬®¦­®
⮫쪮 ®¤¨­ à §.
Š®¬¯¨«ïæ¨ï í⮩ ¡¨¡«¨®â¥ª¨ ¤®¡ ¢«ï¥â ¢ ⥪ã騩 á«®¢ àì ª®¬¯¨«ï樨
’®«ìª® ¤¢  á«®¢ :
á«®¢ àì "vocLocalsSupport" ¨ "{"
‚ᥠ®áâ «ì­ë¥ ¤¥â «¨ "á¯àïâ ­ë" ¢ á«®¢ à¥, ¨á¯®«ì§®¢ âì ¨å
­¥ ४®¬¥­¤ã¥âáï.
)
REQUIRE [IF] ~MAK\CompIF.f
C" 'DROP_V" FIND NIP 0=
[IF] ' DROP VALUE 'DROP_V
: 'DROP 'DROP_V ;
[THEN]
C" 'DUP_V" FIND NIP 0=
[IF] ' DUP VALUE 'DUP_V
: 'DUP 'DUP_V ;
[THEN]
C" 'DROP" FIND NIP 0=
[IF] ' DROP VALUE 'DROP
[THEN]
C" 'DUP" FIND NIP 0=
[IF] ' DUP VALUE 'DUP
[THEN]
\ C" '(LocalsExit)_V" FIND NIP 0=
\ [IF] ' (LocalsExit)_V VALUE '(LocalsExit)_V
\ [THEN]
MODULE: vocLocalsSupport_M
VARIABLE uLocalsCnt
VARIABLE uLocalsUCnt
VARIABLE uPrevCurrent
VARIABLE uAddDepth
: LocalOffs ( n -- offs )
2+ CELLS uAddDepth @ +
;
BASE @ HEX
' RP@ 7 + @ 0xC3042444 =
[IF]
: R_ALLOT,
DUP SHORT?
OPT_INIT SetOP
IF 8D C, 64 C, 24 C, C, \ mov esp, offset [esp]
ELSE 8D C, A4 C, 24 C, , \ mov esp, offset [esp]
THEN
OPT_CLOSE
;
C" MACRO," FIND NIP 0=
[IF] : MACRO, INLINE, ;
[THEN]
: CompileLocalRec ( u -- )
LocalOffs DUP
'DUP MACRO,
SHORT?
OPT_INIT SetOP
IF 8D C, 44 C, 24 C, C, \ lea eax, offset [esp]
ELSE 8D C, 84 C, 24 C, , \ lea eax, offset [esp]
THEN OPT
OPT_CLOSE
;
: CompileLocal@ ( n -- )
'DUP MACRO,
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 8B C, 44 C, 24 C, C, \ mov eax, offset [esp]
ELSE 8B C, 84 C, 24 C, , \ mov eax, offset [esp]
THEN OPT
OPT_CLOSE
;
: CompileLocal! ( n -- )
LocalOffs DUP SHORT?
OPT_INIT SetOP
IF 89 C, 44 C, 24 C, C, \ mov offset [esp], eax
ELSE 89 C, 84 C, 24 C, , \ mov offset [esp], eax
THEN OPT
OPT_CLOSE
'DROP MACRO,
;
\ : CompileLocal@ ( n -- )
\ LocalOffs LIT, POSTPONE RP+@
\ ;
[ELSE]
: R_ALLOT,
] POSTPONE LITERAL S" RP@ + RP! " EVALUATE
POSTPONE [ ;
: CompileLocalRec ( u -- )
LocalOffs
POSTPONE LITERAL
\ S" RP@ + " EVALUATE
;
: CompileLocal@ ( n -- )
CompileLocalRec
S" @ " EVALUATE
;
: CompileLocal! ( n -- )
CompileLocalRec
S" ! " EVALUATE
;
[THEN]
VARIABLE TEMP-DP
: CompileLocalsInit
TEMP-DP @ DP !
uPrevCurrent @ SET-CURRENT
uLocalsUCnt @ ?DUP
IF NEGATE CELLS R_ALLOT,
THEN
uLocalsCnt @ uLocalsUCnt @ - ?DUP
IF DUP CELLS NEGATE uAddDepth +! 0 DO S" >R " EVALUATE LOOP THEN
uLocalsCnt @ ?DUP
IF CELLS POSTPONE LITERAL S" >R ['] (LocalsExit) >R" EVALUATE
-2 CELLS uAddDepth +!
THEN
;
\ : CompileLocal@ ( n -- )
\ LocalOffs LIT, POSTPONE RP+@
\ ;
BASE !
WORDLIST CONSTANT widLocals@
CREATE TEMP-BUF 1000 ALLOT
: LocalsStartup
GET-CURRENT uPrevCurrent !
ALSO vocLocalsSupport_M
ALSO widLocals@ CONTEXT ! DEFINITIONS
HERE TEMP-DP !
TEMP-BUF DP !
widLocals@ 0!
uLocalsCnt 0!
uLocalsUCnt 0!
uAddDepth 0!
;
: LocalsCleanup
PREVIOUS PREVIOUS
;
: ProcessLocRec ( "name" -- u )
[CHAR] ] PARSE
STATE 0!
EVALUATE CELL 1- + CELL / \ ¤¥« ¥¬ ªà â­ë¬ 4
-1 STATE !
\ DUP uLocalsCnt +!
uLocalsCnt @
;
: CreateLocArray
[CHAR] [ PSKIP
ProcessLocRec
CREATE ,
DUP uLocalsCnt +!
;
: LocalsRecDoes@ ( -- u )
DOES> @ CompileLocalRec
;
: LocalsRecDoes@2 ( -- u )
ProcessLocRec ,
DUP uLocalsCnt +!
DOES> @ CompileLocalRec
;
: LocalsDoes@
uLocalsCnt @ ,
uLocalsCnt 1+!
DOES> @ CompileLocal@
;
: ;; POSTPONE ; ; IMMEDIATE
: ^
' >BODY @
CompileLocalRec
; IMMEDIATE
: -> ' >BODY @ CompileLocal! ; IMMEDIATE
WARNING DUP @ SWAP 0!
: AT
[COMPILE] ^
; IMMEDIATE
: TO ( "name" -- )
>IN @ NextWord widLocals@ SEARCH-WORDLIST 1 =
IF >BODY @ CompileLocal! DROP
ELSE >IN ! [COMPILE] TO
THEN
; IMMEDIATE
WARNING !
: ¢ POSTPONE -> ; IMMEDIATE
WARNING @ WARNING 0!
\ ===
\ ¯¥à¥®¯à¥¤¥«¥­¨¥ ᮮ⢥âáâ¢ãîé¨å á«®¢ ¤«ï ¢®§¬®¦­®á⨠¨á¯®«ì§®¢ âì
\ ¢à¥¬¥­­ë¥ ¯¥à¥¬¥­­ë¥ ¢­ãâਠ横«  DO LOOP ¨ ­¥§ ¢¨á¨¬® ®â ¨§¬¥­¥­¨ï
\ ᮤ¥à¦¨¬®£® á⥪  ¢®§¢à â®¢ á«®¢ ¬¨ >R R>
C" DO_SIZE" FIND NIP 0=
[IF] 3 CELLS CONSTANT DO_SIZE
[THEN]
: DO POSTPONE DO DO_SIZE uAddDepth +! ; IMMEDIATE
: ?DO POSTPONE ?DO DO_SIZE uAddDepth +! ; IMMEDIATE
: LOOP POSTPONE LOOP DO_SIZE NEGATE uAddDepth +! ; IMMEDIATE
: +LOOP POSTPONE +LOOP DO_SIZE NEGATE uAddDepth +! ; IMMEDIATE
: >R POSTPONE >R [ 1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: R> POSTPONE R> [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: RDROP POSTPONE RDROP [ -1 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2>R POSTPONE 2>R [ 2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
: 2R> POSTPONE 2R> [ -2 CELLS ] LITERAL uAddDepth +! ; IMMEDIATE
\ ===
\ uLocalsCnt @ ?DUP
\ IF CELLS RLIT, ['] (LocalsExit) RLIT, THEN
: ; LocalsCleanup
S" ;" EVAL-WORD
; IMMEDIATE
WARNING !
\ =====================================================================
EXPORT
: {
LocalsStartup
BEGIN
BL PSKIP PeekChar DUP [CHAR] \ <>
OVER [CHAR] - <> AND
OVER [CHAR] } <> AND
OVER [CHAR] | <> AND
SWAP [CHAR] ) XOR AND
WHILE
CREATE LocalsDoes@ IMMEDIATE
REPEAT
PeekChar >IN 1+! DUP [CHAR] } <>
IF
DUP [CHAR] \ =
SWAP [CHAR] | = OR
IF
BEGIN
BL PSKIP PeekChar DUP
DUP [CHAR] - <>
SWAP [CHAR] } <> AND
SWAP [CHAR] ) XOR AND
WHILE
PeekChar [CHAR] [ =
IF CreateLocArray LocalsRecDoes@
ELSE
CREATE LATEST DUP C@ + C@
[CHAR] [ =
IF
LocalsRecDoes@2
ELSE
LocalsDoes@ 1
THEN
THEN DUP U.
uLocalsUCnt +!
IMMEDIATE
REPEAT
THEN
[CHAR] } PARSE 2DROP
ELSE DROP THEN
CompileLocalsInit
;; IMMEDIATE
;MODULE
View Git Blame Copy Permalink