последний рабочий вариант
Код:
S" case.f" INCLUDED
USER-CREATE /d0/ 10 10 * CELLS USER-ALLOT USER /d/ /d0/ /d/ !
USER /org USER /beg USER /cur USER /lim USER /a/ USER /u/ VECT sm,
: SPDROP ( n -- ) [ BASE @ HEX C1 C, E0 C, 02 C, 03 C, E8 C, 8B C, 45 C, 00 C, 8D C, 6D C, 04 C, C3 C, BASE ! ] ;
: SPMOVE ( a n -- ) [ BASE @ HEX 8D C, 5D C, 04 C, 8B C, 55 C, 00 C, 8B C, 0B C, 89 C, 0A C, 8D C, 52 C, 04 C,
8D C, 5B C, 04 C, 48 C, 75 C, F3 C, 8B C, 45 C, 04 C, 8D C, 6D C, 08 C, C3 C, BASE ! ] ;
\ Слово __ надо использовать для реентерабельных целей просто переустанавливает
\ указатель /d/ и готовит возврат к предыдущему буферу(кадру) при выходе из слова
\ с манипулятором (такой простейший стек).
: __RET -10 CELLS /d/ +! ; : __ 10 CELLS /d/ +! R> ['] __RET >R >R ;
: sm+ 10 CELLS /d/ +! ; IMMEDIATE
: sm- -10 CELLS /d/ +! ; IMMEDIATE
\ непосредственно установка рабочего буфера(кадра) ( 0 d!, 1 d! ...9 d! ):
: d! ( n -- ) 10 * CELLS /d0/ + /d/ ! ;
: "0 0 d! ; : "1 1 d! ; : "2 2 d! ; : "3 3 d! ; : "4 4 d! ;
: "5 5 d! ; : "6 6 d! ; : "7 7 d! ; : "8 8 d! ; : "9 9 d! ;
\ доступ к адресам ячеек
: '0 /d/ @ 36 + ; : '1 /d/ @ 32 + ; : '2 /d/ @ 28 + ; : '3 /d/ @ 24 + ;
: '4 /d/ @ 20 + ; : '5 /d/ @ 16 + ; : '6 /d/ @ 12 + ; : '7 /d/ @ 8 + ;
: '8 /d/ @ 4 + ; : '9 /d/ @ ;
\ копирование значений со стека данных в последовательные ячейки манипулятора
: 0| ; : 0\ ; : 1| /d/ @ 32 + 1 SPMOVE ; : 2| /d/ @ 28 + 2 SPMOVE ;
: 3| /d/ @ 24 + 3 SPMOVE ; : 4| /d/ @ 20 + 4 SPMOVE ; : 5| /d/ @ 16 + 5 SPMOVE ;
: 6| /d/ @ 12 + 6 SPMOVE ; : 7| /d/ @ 8 + 7 SPMOVE ; : 8| /d/ @ 4 + 8 SPMOVE ;
: 9| /d/ @ 9 SPMOVE ;
\ загрузка значений со стека данных в последовательные ячейки манипулятора
: 1\ /d/ @ 32 + 1 SPMOVE 1 SPDROP ; : 2\ /d/ @ 28 + 2 SPMOVE 2 SPDROP ; : 3\ /d/ @ 24 + 3 SPMOVE 3 SPDROP ;
: 4\ /d/ @ 20 + 4 SPMOVE 4 SPDROP ; : 5\ /d/ @ 16 + 5 SPMOVE 5 SPDROP ; : 6\ /d/ @ 12 + 6 SPMOVE 6 SPDROP ;
: 7\ /d/ @ 8 + 7 SPMOVE 7 SPDROP ; : 8\ /d/ @ 4 + 8 SPMOVE 8 SPDROP ; : 9\ /d/ @ 9 SPMOVE 9 SPDROP ;
\ вспомагательные слова
: dg? ( a -- f ) C@ [CHAR] 0 [CHAR] 9 1+ WITHIN ;
: [c,] ( C -- ) 48 - 9 SWAP - CELLS LIT, ;
: [d,] ['] /d/ COMPILE, ['] @ COMPILE, ['] + COMPILE, ;
: [p,] 2- LIT, ['] PICK COMPILE, ;
: num? ( a u -- f ) OVER DUP dg? SWAP C@ [CHAR] - = OR -ROT OVER SWAP 1 D+ ?DO I dg? AND LOOP ;
\ ======
\ распознать что мы имеем на входе m-block ( манипулятор-блок или макро-блок ) и
\ скомпилировать предписанные его символам действия. m-block цепочка символов более
\ одного и заканчивающееся символом '_'
\ пример : t1 1 1\ 1._ ; печать 1
: NOTFOUND ( A U -- ) \ m-block
2DUP /u/ ! /a/ ! + 1- C@ [CHAR] _ = /u/ @ 1 > AND 0= IF /a/ @ /u/ @ NOTFOUND EXIT THEN
/a/ @ DUP /cur ! /u/ @ + 2- /lim ! BEGIN sm, /cur @ /lim @ <> WHILE /cur 1+! REPEAT ;
\ ======
\ произвольная загрузка ячеек манипулятора 1 2 3 456i - загрузить число 1 в ячейку 4,
\ число 2 в ячейку 5, число 3 в ячейку 6
\ пример : t2 1 2 3 456i 4.5.6._ ; печать 1 2 3
: NOTFOUND ( A U -- ) \ i-block
/u/ ! /a/ ! /a/ @ /u/ @ + 1- DUP C@ [CHAR] i = SWAP /a/ @ ?DO I dg? AND LOOP 0= IF /a/ @ /u/ @ NOTFOUND EXIT THEN
/a/ @ DUP /u/ @ + 2- DO I C@ [c,] [d,] ['] ! COMPILE, -1 +LOOP ;
\ ======
\ произвольная копирование в ячейки манипулятора 1 2 3 456p - скопировать число 1 в ячейку 4,
\ число 2 в ячейку 5, число 3 в ячейку 6, на стеке данные не изменны
\ пример : t3 1 2 3 456p 4.5.6._ ; печать 1 2 3 на стеке 1 2 3
: NOTFOUND ( A U -- ) \ p-block
/u/ ! /a/ ! /a/ @ /u/ @ + 1- DUP C@ [CHAR] p = SWAP /a/ @ ?DO I dg? AND LOOP 0= IF /a/ @ /u/ @ NOTFOUND EXIT THEN
2 /a/ @ DUP /u/ @ + 2- DO DUP [p,] I C@ [c,] [d,] ['] ! COMPILE, 1+ -1 +LOOP DROP ;
\ ======
\ признак: если длина строки нечетная И в середине символ '@' И остальные символы - цифры
\ 1@2 --- извлечь данные из адреса записанного в ячейке 1 и изменить адрес
\ на величину в ячейке 2 ( групповые варианты 123@789 123@555 )
\ пример : t4 4 5 '9 091i ." befo '1=" 1._ 1@0 ." afte '1=" 1._ ; адрес в ячейке 0 увеличен на стеке значение 5
: NOTFOUND ( A U -- ) \ @-block
/u/ ! /a/ ! /u/ @ 2 MOD 1 = /a/ @ /u/ @ 2/ + C@ [CHAR] @ = AND /u/ @ 2/ /a/ @ + /a/ @ ?DO I dg? AND LOOP
/a/ @ /u/ @ + /a/ @ /u/ @ 2/ + 1+ ?DO I dg? AND LOOP 0= IF /a/ @ /u/ @ NOTFOUND EXIT THEN
/u/ @ 2/ 1+ /org ! /u/ @ 2/ /a/ @ + /a/ @
?DO I C@ [c,] [d,] ['] @ COMPILE, ['] @ COMPILE, I /org @ + C@ [c,] [d,] ['] @ COMPILE, I C@ [c,] [d,] ['] +! COMPILE, LOOP ;
\ ======
\ признак: если длина строки нечетная И в середине символ '!' И остальные символы - цифры
\ 5 1!2 --- записать число 5 по адресу записанному в ячейке 1 и изменить адрес
\ на величину в ячейке 2 ( групповые варианты 1 2 3 123!789 1 2 3 123!555 )
\ пример : t5 5 4 '2 ! '9 '1 ! '1 @ ." befo'1=" . 1!2 '1 @ ." after'1=" . '9 @ ;
: NOTFOUND ( A U -- ) \ !-block
/u/ ! /a/ ! /u/ @ 2 MOD 1 = /a/ @ /u/ @ 2/ + C@ [CHAR] ! = AND /u/ @ 2/ /a/ @ + /a/ @
?DO I dg? AND LOOP /a/ @ /u/ @ + /a/ @ /u/ @ 2/ + 1+ ?DO I dg? AND LOOP 0= IF /a/ @ /u/ @ NOTFOUND EXIT THEN
/u/ @ 2/ 1+ /org ! /u/ @ 2/ /a/ @ + /a/ @ ?DO I C@ [c,] [d,] ['] @ COMPILE, ['] ! COMPILE, I /org @ + C@ [c,] [d,] ['] @ COMPILE, I C@ [c,] [d,] ['] +! COMPILE, LOOP ;
\ ' перед 0...9 - адрес ячеек 0...9, перед a...z, A...Z, ~...? - признак двухсимвольных операторов
: 'parse
/cur 1+!
/cur @ dg? IF /cur @ C@ [c,] [d,] EXIT THEN
/cur @ 2 num? IF /cur @ 2 ?SLITERAL1 /cur 1+! EXIT THEN
/cur @ 2 SFIND 0= IF NOTFOUND ELSE COMPILE, /cur 1+! THEN ;
\ " перед 0...9 - номер буфера стека, перед a...z, A...Z, ~...? - признак трехсимвольных операторов
: "parse
/cur 1+!
/cur @ 3 num? IF /cur @ 3 ?SLITERAL1 /cur 2 /cur +! DROP EXIT THEN
/cur @ 3 SFIND 0= IF NOTFOUND ELSE COMPILE, 2 /cur +! THEN ;
: sm.tst? ( a u -- f ) /u/ ! DUP /a/ ! dg? /a/ @ 1+ DUP DUP C@ [CHAR] \ = SWAP C@ [CHAR] | = OR SWAP C@ [CHAR] / = OR AND /u/ @ 2 > AND ;
: sm.load ( a u -- beg end ) /a/ @ C@ 48 - /org !
/a/ @ 1+ C@ [CHAR] / = IF /org @ LIT, ['] d! COMPILE, ELSE
/org @ 0<> IF /a/ @ C@ [c,] [d,] /org @ LIT, ['] SPMOVE COMPILE,
/a/ @ 1+ C@ [CHAR] \ = IF /org @ LIT, ['] SPDROP COMPILE, THEN THEN THEN
/a/ @ 2+ /beg ! /a/ @ /u/ @ + /lim ! ;
: sm.comp /beg @ /cur ! BEGIN sm, /lim @ /cur @ <> WHILE /cur 1+! REPEAT ;
: sm,,,] /cur @ 1+ /beg ! BEGIN /cur @ 1+ C@ [CHAR] ] <> WHILE /cur 1+! REPEAT
/cur 1+! /beg @ /cur @ OVER - sm.tst? IF sm.load sm.comp ELSE /a/ @ /u/ @ SFIND 0= IF NOTFOUND ELSE COMPILE, THEN THEN ;
\ Lambda. код внутри конструкции LAMBDA{ }LAMBDA не выполняется, возвращается xt на этот код.
: LAMBDA{ ( -- ) LAST-NON HERE BRANCH, >MARK 2 HERE DUP TO LAST-NON ; IMMEDIATE
: }LAMBDA ( -- xt ) >R POSTPONE EXIT POSTPONE THEN R> POSTPONE LITERAL TO LAST-NON ; IMMEDIATE
: S' [CHAR] ' PARSE [COMPILE] SLITERAL ; IMMEDIATE
: ?? ( a u -- f ) SWAP OVER /cur @ OVER COMPARE 0= IF 1- /cur +! 0 THEN ;
: op, ( -- )
0 CASE
S" {" ?? OF POSTPONE LAMBDA{ ENDOF
S" }" ?? OF POSTPONE }LAMBDA ENDOF
S" `+" ?? OF ['] D+ COMPILE, ENDOF
S" `-" ?? OF ['] D- COMPILE, ENDOF
S" `@" ?? OF ['] 2@ COMPILE, ENDOF
S" `!" ?? OF ['] 2! COMPILE, ENDOF
S" `n" ?? OF ['] DNEGATE COMPILE, ENDOF
S" `a" ?? OF ['] DABS COMPILE, ENDOF
\ S" `|" ?? OF ['] DOR COMPILE, ENDOF
\ S" `^" ?? OF ['] DXOR COMPILE, ENDOF
\ S" `&" ?? OF ['] DAND COMPILE, ENDOF
\ S" `~" ?? OF ['] DINVERT COMPILE, ENDOF
\ S" `l" ?? OF ['] DLSHIFT COMPILE, ENDOF
\ S" `r" ?? OF ['] DRSHIFT COMPILE, ENDOF
\ S" `>" ?? OF ['] D> COMPILE, ENDOF
\ S" `<" ?? OF ['] D< COMPILE, ENDOF
S" `=" ?? OF ['] D= COMPILE, ENDOF
\ S" `Z" ?? OF ['] D0= COMPILE, ENDOF
\ S" `z" ?? OF ['] D0= INVERT COMPILE, ENDOF
S" `d" ?? OF ['] 2DUP COMPILE, ENDOF
S" `x" ?? OF ['] 2DROP COMPILE, ENDOF
S" `." ?? OF ['] D. COMPILE, ENDOF
S" `S" ?? OF ['] D>S COMPILE, ENDOF
S" `D" ?? OF ['] S>D COMPILE, ENDOF
S" 0" ?? OF 36 LIT, [d,] ['] @ COMPILE, ENDOF
S" 1" ?? OF 32 LIT, [d,] ['] @ COMPILE, ENDOF
S" 2" ?? OF 28 LIT, [d,] ['] @ COMPILE, ENDOF
S" 3" ?? OF 24 LIT, [d,] ['] @ COMPILE, ENDOF
S" 4" ?? OF 20 LIT, [d,] ['] @ COMPILE, ENDOF
S" 5" ?? OF 16 LIT, [d,] ['] @ COMPILE, ENDOF
S" 6" ?? OF 12 LIT, [d,] ['] @ COMPILE, ENDOF
S" 7" ?? OF 8 LIT, [d,] ['] @ COMPILE, ENDOF
S" 8" ?? OF 4 LIT, [d,] ['] @ COMPILE, ENDOF
S" 9" ?? OF 0 LIT, [d,] ['] @ COMPILE, ENDOF
S" +" ?? OF ['] + COMPILE, ENDOF \ арифметика
S" -" ?? OF ['] - COMPILE, ENDOF
S" *" ?? OF ['] * COMPILE, ENDOF
S" /" ?? OF ['] / COMPILE, ENDOF
S" %" ?? OF ['] MOD COMPILE, ENDOF
S" :" ?? OF ['] /MOD COMPILE, ENDOF
S" n" ?? OF ['] NEGATE COMPILE, ENDOF
S" a" ?? OF ['] ABS COMPILE, ENDOF
S" |" ?? OF ['] OR COMPILE, ENDOF \ логика и сдвиги
S" ^" ?? OF ['] XOR COMPILE, ENDOF
S" &" ?? OF ['] AND COMPILE, ENDOF
S" ~" ?? OF ['] INVERT COMPILE, ENDOF
S" r" ?? OF ['] RSHIFT COMPILE, ENDOF
S" l" ?? OF ['] LSHIFT COMPILE, ENDOF
S" !" ?? OF ['] ! COMPILE, ENDOF \ память
S" @" ?? OF ['] @ COMPILE, ENDOF
S" b" ?? OF ['] C@ COMPILE, ENDOF
S" w" ?? OF ['] C! COMPILE, ENDOF
S" V" ?? OF ['] MOVE COMPILE, ENDOF
S" F" ?? OF ['] FILL COMPILE, ENDOF
S" a" ?? OF ['] ABS COMPILE, ENDOF
S" f" ?? OF ['] NextWord COMPILE, ENDOF
S" o" ?? OF ['] THROW COMPILE, ENDOF
S" h" ?? OF ['] HERE COMPILE, ENDOF
S" =" ?? OF ['] = COMPILE, ENDOF \ сравнения
S" >" ?? OF ['] > COMPILE, ENDOF
S" <" ?? OF ['] < COMPILE, ENDOF
S" z" ?? OF ['] 0<> COMPILE, ENDOF
S" Z" ?? OF ['] 0= COMPILE, ENDOF
S" m" ?? OF ['] MIN COMPILE, ENDOF
S" M" ?? OF ['] MAX COMPILE, ENDOF
S" H" ?? OF ['] WITHIN COMPILE, ENDOF
S" d" ?? OF ['] DUP COMPILE, ENDOF \ копирование и удаление в стеке
S" x" ?? OF ['] DROP COMPILE, ENDOF
S" P" ?? OF ['] DEPTH COMPILE, ENDOF
S" Y" ?? OF ['] TRUE COMPILE, ENDOF
S" y" ?? OF ['] FALSE COMPILE, ENDOF
S" i" ?? OF POSTPONE IF ENDOF \ ветвления
S" e" ?? OF POSTPONE ELSE ENDOF
S" t" ?? OF POSTPONE THEN ENDOF
S" D" ?? OF POSTPONE DO ENDOF \ циклы со счетчиком
S" G" ?? OF POSTPONE ?DO ENDOF
S" L" ?? OF POSTPONE LOOP ENDOF
S" N" ?? OF POSTPONE +LOOP ENDOF
S" I" ?? OF POSTPONE I ENDOF
S" J" ?? OF POSTPONE J ENDOF
S" Q" ?? OF POSTPONE LEAVE ENDOF
S" B" ?? OF POSTPONE BEGIN ENDOF \ циклы
S" A" ?? OF POSTPONE ACCEPT ENDOF
S" U" ?? OF POSTPONE UNTIL ENDOF
S" W" ?? OF POSTPONE WHILE ENDOF
S" R" ?? OF POSTPONE REPEAT ENDOF
S" ;" ?? OF POSTPONE EXIT ENDOF
S" C" ?? OF POSTPONE CASE ENDOF \ выбор по целому
S" E" ?? OF POSTPONE ENDCASE ENDOF
S" (" ?? OF POSTPONE OF ENDOF
S" )" ?? OF POSTPONE ENDOF ENDOF
S" ." ?? OF ['] . COMPILE, ENDOF \ печать
S" c" ?? OF ['] EMIT COMPILE, ENDOF
S" S" ?? OF ['] SPACES COMPILE, ENDOF
S" T" ?? OF ['] TYPE COMPILE, ENDOF
S" \" ?? OF ['] CR COMPILE, ENDOF
S" X" ?? OF ['] EXECUTE COMPILE, ENDOF
\ S" p" ?? OF ['] CHOOSE COMPILE, ENDOF
S" q" ?? OF ['] COMPARE COMPILE, ENDOF
S" s" ?? OF ['] SEARCH COMPILE, ENDOF
S" n" ?? OF ['] NEGATE COMPILE, ENDOF
S" $" ?? OF ['] SFIND COMPILE, ENDOF
S" O" ?? OF ['] AGAIN COMPILE, ENDOF
S" v" ?? OF ['] EVALUATE COMPILE, ENDOF
S" K" ?? OF ['] EKEY COMPILE, ENDOF
S" k" ?? OF ['] KEY COMPILE, ENDOF
S" ," ?? OF ['] COMPILE, COMPILE, ENDOF
S" #" ?? OF ['] >NUMBER COMPILE, ENDOF
\ S" g" ?? OF ['] BRANCH, COMPILE, ENDOF
\ S" j" ?? OF ['] ?BRANCH, COMPILE, ENDOF
S" `" ?? OF /cur 1+! /cur @ C@ 48 - LIT, ENDOF
S" [" ?? OF sm,,,] ENDOF
S" '" ?? OF 'parse ENDOF
S' "' ?? OF "parse ENDOF
ENDCASE ;
' op, TO sm,
: NOTFOUND ( A U -- ) sm.tst? IF sm.load sm.comp ELSE /a/ @ /u/ @ NOTFOUND THEN ;
\EOF
Вход
Регистрация
Благодарности
Forth-FAQ
, поэтому с задачей "ручного жонглирования стеком" "придётся" мириться и включать