это уже было, но давно 8) И реализация была поверх стандартных слов и кое чего там не было.
Вобщем теперь можно писать
Код:
7 BEGIN DUP WHILE DUP CONSTANT 1 - REPEAT DROP seven six five fourth three two one
и наслаждаться семью именоваными константами 8)
да, кстати по поводу ON-ERROR - пример использования ( это я к in4 8)
Код:
\ 19-04-2007 ~mOleg
\ Copyright [C] 2007 mOleg mininoleg@yahoo.com
\ структуры управления: ветвления и циклы
REQUIRE IFNOT devel\~moleg\lib\util\ifnot.f
REQUIRE ON-ERROR devel\~moleg\lib\util\on-error.f
\ переменная для контроля парности открывающих и закрывающих слов
USER controls ( --> addr )
\ размер временного буфера для сборки слов мимо кодофайла
0x4000 CONSTANT #compbuf ( --> const )
\ адрес временного буфера
USER-VALUE CompBuf ( --> addr )
\ переменная для временного хранения адреса DP из CURRENT
USER save-dp ( --> addr )
\ восстановить системные переменные
: rest ( --> )
save-dp A@ DP !
0 controls !
[COMPILE] [ ;
\ начать компиляцию во временный буфер
: init: ( --> )
0 controls A!
HERE save-dp A!
CompBuf IFNOT #compbuf ALLOCATE THROW TO CompBuf THEN
['] rest ON-ERROR
CompBuf DP A!
] ;
\ закончить компиляцию во временный буфер, выполнить его содержимое
\ восстановить состояние системных переменных
: ;stop ( --> )
RET,
EXIT-ERROR rest
CompBuf EXECUTE ;
\ пока так
\ при входе в определение переменная controls увеличивается на 1
\ при выходе из определения - уменьшается на 1
: : 1 controls ! : ;
: ; controls @ 1 = IFNOT -22 THROW THEN 0 controls ! [COMPILE] ; ; IMMEDIATE
\ ---------------------------------------------------------------------------
\ Начало ветвления. Код за словом IF выполняется в случае, если flag <> 0
: IF ( flag --> )
STATE @ IFNOT init: THEN
2 controls +!
HERE ?BRANCH, >MARK 1 ; IMMEDIATE
\ Альтернативное ветвление. Код за else выполняется в случае, если
\ пропущен код за основным: IF или IFNOT ветвлением.
: ELSE ( --> ) ?COMP HERE BRANCH, >RESOLVE >MARK 2 ; IMMEDIATE
\ Описатель начала цикла. На код за словом BEGIN передается управление
\ в случае повторений цикла
: BEGIN ( --> )
STATE @ IFNOT init: THEN
2 controls +!
<MARK 3 ; IMMEDIATE
\ возврат без условий на точку BEGIN. Отмечает конец кода бесконечного цикла.
: AGAIN ( --> )
?COMP -2 controls +!
3 = IFNOT -2006 THROW THEN BRANCH,
controls @ IFNOT ;stop THEN ; IMMEDIATE
\ Возврат на точку после BEGIN если flag <> 0 (цикл с постусловием)
: UNTIL ( flag --> )
?COMP -2 controls +!
3 = IFNOT -2004 THROW THEN ?BRANCH,
controls @ IFNOT ;stop THEN ; IMMEDIATE
\ условный выход из цикла, если flag = 0
\ используется между BEGIN и REPEAT, отмечающими начало и конец цикла
: WHILE ( flag --> )
?COMP 2 controls +!
HERE ?BRANCH, >MARK 1 2SWAP ; IMMEDIATE
\ условынй выход из цикла, если flag <> 0. Используется аналогично WHILE
: WHILENOT ( flag --> )
?COMP 2 controls +!
HERE N?BRANCH, >MARK 1 ; IMMEDIATE
\ безусловный возврат на BEGIN. Используется вместе с BEGIN и WHILE
: REPEAT ( --> )
?COMP -4 controls +!
3 = IFNOT -2005 THROW THEN BRANCH, >RESOLVE
controls @ IFNOT ;stop THEN ; IMMEDIATE
\ Начало ветвления. Промежуточное имя.
: ifnot ( flag --> )
STATE @ IFNOT init: THEN
2 controls +!
HERE N?BRANCH, >MARK 1 ;
\ Конец ветвления. На точку за THEN переходит управление после выполнения
\ одной из альтернатив, то есть кода после IF IFNOT или ELSE
: THEN ( --> )
?COMP -2 controls +!
>RESOLVE
controls @ IFNOT ;stop THEN ; IMMEDIATE
\ Начало ветвления. Код за словом IFNOT выполняется в случае, если flag = 0
: IFNOT ifnot ; IMMEDIATE
\EOF -- тестовая секция -----------------------------------------------------
S" должно быть true = " TYPE 1 IF ." true " ELSE ." false " THEN CR
S" должно быть false = " TYPE 0 IF ." true " ELSE ." false " THEN CR
: testa IF ." true " ELSE ." false " THEN CR ;
S" должно быть true = " TYPE 1 testa
S" должно быть false = " TYPE 0 testa
S" убывающий ряд от 10 до 0 = " TYPE 10 BEGIN DUP . DUP WHILE 1 - REPEAT DROP CR
S" убывающий ряд от 10 до 1 = " TYPE 10 BEGIN DUP . 1 - DUP 0= UNTIL DROP CR
S" убывающий ряд от 9 до 6 = " TYPE 10 BEGIN 1 - DUP WHILE DUP 5 <> WHILE DUP . REPEAT THEN DROP CR
S" убывающий ряд от 10 до 6 = " TYPE 10 BEGIN DUP . 1 - DUP WHILE DUP 5 = UNTIL ELSE THEN DROP CR