Д. Ответы к упражнениям
Блок 0 [0:0] ( Глава 1. Упражнения 1. 01 из 02 ) ( 1. ) ( а. 10 б. 0 в. 6 г. 1 д. 4 ) ( 2. ) ( а. 1 2 * b. 1 2 * 2 / в. 2 3 / 1 + г. 1 2 + 3 / д. 3 2 1 + / е. 3 4 + 2 1 + / ) ( 3. ) : POWER4 ( n -- ) DUP CUBE * ; ( 4, ) : NEWPOWER4 ( n -- ) SQUARE SQUARE ; ( 5. ) : PYTHAGORUS ( n1 n2 -- ) SQUARE SWAP SQUARE * :
Блок 1 [1:0] ( Глава 1. Упражнения 1. 02 из 02 ) ( 6. ) ( AREA ( радиус -- ) SQUARE 314 * ; ( 7. ) : VOLUME ( длина радиус -- ) AREA * ; : XVOLUME ( радиус длина -- ) SWAP AREA * ; ( Второе описание менее эффективно из-эа лишнего SWAP . )
Блок 2 [2:0] ( Глава 1. Упражнения 2. 01 из 02 ) ( 1. ) ( Главное преимущество диска заключается в уменьшении вероятности потери программы и в простоте ее изменения.) ( 2. ) : .X ." -" ; ( .X может быть изменено для отображения любого символа. ) ( 3. ) : LIMITBAR ( n --) DUP 40 > IF DROP 40 THEN BAR ; ( Для использования с 80-символьным экраном: ) ( : LIMITBAR ( n -- ) DUP 80 > IF DROP 80 THEN BAR ; ) ( Аналогичным образом можно приспособиться к экрану любой ширины ) ( 4. ) : LIMITBAR1 ( n --) 100 / DUP 64 > IF DROP 64 THEN BAR ; (5. ) : LIMITBAR2 ( в.- ) 10000 / 64 * DUP 64 > IF DROP 64 THEN BAR ;
Блок 3 [3 :0] ( Глава 1. Упражнения 2. 02 из 02 ) ( 6. ) : GRAPH ( n1 т2 n3 ... -- или n1 n2 n3 ) CR DEPTH DUP 16 < IF DO LIMITBAR LOOP THEN ; ( Заметии, что исходное число может остаться в стеке.) ( 7.) : BAR ( n --) DUP 0 DO .X LOOP . СR ; ( DUP позволяет использовать вернее число как LIMlTBAR, так и . ) : LIMITBAR3 ( n -- ) DUP 50 > IF DROP 50 THEN BAR ;
Блок 4 [4 :0] ( Глава 2, Упражнения 1. 01 из 04 ] . ( 1. ) ( а. 5 5 + 5 + . Ответ: 15 б. 5 5 * 5 * 5 * . 625 в. 5 5 + 5 * . , 50 г. 5 5 + 5 / . 2 д. 5 5 + 2 / . 5 е. 10 5 5 + / . 1 ж. 5 4 + 5 5 + / . 0 з. 5 5 * 5 4 * 4 4 * + . 61 и. 5 4 + 5 4 + * . 81 к. 5 4 + 5 4 + * . 81
Блок 5 [5 :0] Глава 2. Упражнения 1. 02 из 04 ) ( 2.) а. 5 5 5 + + . Ответ: 15 б. 5 5 5 5 * * * . 625 в. 5 5 5 + * . 50 г. Это нельзя изменить. д. и это нет. е. Это тоже нельзя.
ж. И это не может быть изменено з. 5 5 * 5 4 * 4 4 * + + . 61 и. Т эти два также нельзя к. изменить. )
Блок 6 [6 :0] ( Глава 2. Упражнения 1. 03 из 04 ) ( 3. ) ( Сначала сложим 3 и 5, умножим на 2, разделим на 4 и добавим 16. Постфиксная запись: 3 5 + 2 * 4 / 16 + ( дает 20). ( Заметим, что если есть выбор, то, чтобы не было ошибки округления, умножение должно всегда предшествовать делению. Например: 7 100 * 6 / выдает 116 в то время как 7 6 / 100 * выдает 100 )
( 4. ) ( 9 3 + 5 * 6 / 2 + 32 + . Ответ: 44 5 6 * 3 * 3 * 2 * 32 * . 6336 5 4 + 22 * 5 10 * 2 + + 2 * . 500 )
Блок 7 [7 :0] ( Глава 2. Упражнения 1. 04 из 04 ) ( 5. ) ( a. 5 DUP DUP + + . Ответ: 15 б. 5 DUP DUP DUP * * * . 625 в. 5 DUP DUP + * . 50 г. 5 DUP + 5 / . 2 д. 5 DUP + 2 / . 5 е. 10 5 DUP + / . 1 ж. 5 4 + 5 DUP + / . 0 з. 5 DUP * 5 4 * + 4 * DUP * + . 61 и. 5 4 + DUP * . 81 к. 5 4 + DUP * . 81 )
Блок 8 [8 :0] ( Глава 2. Упражнения 2. 01 из 04 ) ( 1. ) a. SWAP б. DUP в. OVER г. OVER SWAP д. DUP ВОТ е. ROT ж. SWAP з. SWAP ROT и. ROT SWAP к. ROT ROT л. OVER SWAP м. 3 PICK ROT ROT [FORTH-79] 2 PICK ROT ROT [FORTH-83] н. OVER SWAP DUP o. 3 PICK ROT ROT OVER SWAP DUP [79] 2 PICK ROT ROT OVER SWAP DUP [83])
Блок 9 [9 :0] ( Глава 2. Упражнения 2. 02 из 04 ) ( 2.) а. * б. DUP + + в. SWAP DUP + + г. - д. DUP DUP * * SWAP DUP * * f. OVER + * e. + DUP * факториэуем [a + b] [а + b] ж. ROT ROT + SWAP / з. OVER + ROT ROT + SWAP / и. SWAP OVER + ROT ROT + SWAP / к. DUP + ROT ROT + SWAP / л. ROT ROT + SWAP DUP + / м. OVER SWAP - ROT ROT SWAP - * н. + + * факторизируем a [b + с + d ] o. * 1 + * * факторизуем a b [1 + c d]
Блок 10 [10 :0] ( Глава 2. Упражнения 2. 03 из 04 ) ( З. ) : OVER ( n1 n2 -- n1 n2 n1 ) SWAP DUP ROT ROT ; ( 4. ) : 2DUP ( n1 n2 -- n1 n2 n1 n2) OVER OVER ; ( 5. ) : NEWDUP83 ( n -- n n ) 0 PICK ; ( FORTH-83 ) : NEWDUP79 ( n -- n n ) 1 PICK ; ( FORTH-79 ) : NEWOVER83 ( n1 n2 -- n1 n2 n1 ) 1 PICK : ( F-83 ) : NEWOVER79 ( n1 n2 -- n1 n2 n1 ) 2 PICK ; ( F-79 ) ( 6. ) : NEWROT83 ( n1 n2 n3 -- n2 n3 n1 ) 2 ROLL ; ( F-83 ) : NEWROT79 ( nl n2 n3 -- n2 n3 n1 ) 3 ROLL ; ( F-79 )
Блок 11 [11 :0] ( Глава 2. Упрахнеиия 2. 03 из 04 ) ( 7. ) : 2SWAP83 ( 1 2 3 4 - 3 4 2 1 ) 3 ROLL 3 ROLL ; [ 83 ] : 2SWAP79 ( 1 2 3 4 - 3 4 2 1 ) 4 ROLL 4 KOLL ; [ 79 ] ( 8. ) : ROTSTACK83 DEPTH 1 - ROLL ; ( FORTH-83 ) : ROTSTACK79 DEPTH ROLL ; ( FORTH-79 ) ( 9. ) : SPHERE ( радиус -- 100*v ) DUP DUP * * 314 ( 10. ) * 4 * 3 / ; : .ВОTТОМ*83 DEPTH 1 - PICK DEPTH 1 - PICK * . ; [83] : .BOTTOM*79 DEPTH PICK DEPTH PICK * . ; [79] ( 11. ) : NEWMOD ( n1 -- n2 ) OVER OVBB / * - ;
Блок 12 [12 :0] ( Глава 3. Упражнения 1. 01 из 02 ) ( 1. ) ( Двоичная часть результата имеет вид: 1 дает 1 3 дает 11 7 дает 111 15 дает 1111 31 дает 11111 63 дает 111111 127 дает 1111111 255 дает 11111111 Число, которое на единицу меньше чем два в степени n, состоит из последовательности n бит, равных единице. ) ( 2. ) Шестнадцатеричная часть результата имеет вид: 2 дает 2 4 дает 4 8 дает 8 16 дает 10 32 дает 20 64 дает 40 128 дает 80 256 дает 100 ) Шестнадцатеричное число отображает содержимое 1 байта. )
Блох 13 [13 :0] ( Глава 3. Упражнения 1. 02 из 02 ) ( 3. ) ( Ответ неизбежно будет сведен к 2., так как 11111111 равно ff в шестнадпатеричном представлении, а 1111111111111111 равно FFFF ) ( 4. ) ( Вам следует ввести FFFF 1 + . , и, если вы это сделали, то получите результат =0. Легче запоминать и задавать числа а шестнадцатеричном представлении, результат, требующий для представления более двух байт, дает ошибку переполнения и засылает в стек два 0 байта.) ( 5. ) ( Прежде чем использовать описание ) DECIMAL : HЕХ 16 BASE ! ; : OCTAL 8 BASE ! ; : BINARY 2 BASE ! ; ( 6. ) ( Taкие слова как AA, BAC и т.д. помешают использовать соответствующие шестнадцатеркчные числа, если в их начале не стоит 0. GG не шестнадцатеричное число )
Блок 14 [14 :0] ( Глава 3. Упражнения 1. 01 из 02 ) ( 1. ) а. 11110111 AND б. 100 OR в. 0 AND г. 11111111 OR д. 10100000 AND e. 1111 AND ж. 10101111 XOR з. 11111111 XOR и. 11111111 XOR ) ( 2. ) : ZERO-IT ( n -- 0 ) 0 AND ; ( 3. ) : NEW= ( n1 n2 -- f ) XOR DUP / 1 XOR ; (4. ) : <> ( n1 n2 -- f ) XOR DUP / ; ( Выше приведено быстродействующее описание. ) ( Другой вариант: : <> ( n1 n2 -- f ) = 0 = ; )
Блок 15 [15 :0] ( Глава 3. Упражнения 2. 02 из 02 ) ( 5. ) : NOT1 ( n1 -- n2 ) 65535 XOR ; : NOT2 ( n1 -- n2 ) 65535 - ; ( 6.) : SET? ( n1 маска -- f) DUP ROT AND = ; ( 7. ) : NOTSET? ( n1 маска -- f) DUP ROT AND = 0 = ; ( или )
Блок 16 [16 :0] ( Глава 3. Упражнения 3. 01 из 02 ) ( 1. ) : .DEC.BIN ( n -- ) DECIMAL DUP . DUP U. ( 2.) .BIN U.BIN DROP ; ( Таблица должна иметь следующий вид ) ( 1 1 1 1 2 2 10 10 3 3 11 11 32766 32766 111111111111110 111111111111110 32767 32767 111111111111111 111111111111111 -32768 32768 -1000000000000000 1000000000000000 -32767 32769 -1111111111111111 1000000000000001 -3 65533 -11 1111111111111101 -2 65534 -10 1111111111111110 -1 65535 -1 1111111111111111
Бпок 17 [17 :0] ( Глава З. Упражнения 3. 02 из 02 ) ( 3.) ( 65536 + n ) ( 4.) : NEWNEGATE ( n -- -n ) 65535 XOR 1 + ; : NEWNEGATE -1 XOR 1 + ; является эхвквалентным ) ( 65535 XOR выдает то. что называется дополнением по модулю 1; добавление 1 превращает его в дополнение по модулю 2, которое меняет знак. ) ( 5. ) : NEW- ( n1 n2 -- n3 ) NEGATE + ; ( Так в действительности выполняется вычитание в ЭВМ; то есть добавляется дополненме по модулю два. )
Блок 18 [18 :0] ( Глава 3. Упражнения 4. 01 из 02 ) ( 1. ) : .LSB ( n --) 255 AND . ; ( 255 в двоичном виде равно 11111111 ) ( 2.) : MSB ( n -- ) 256 / . ; ( Это не работает для отрицательных чисел, так как отрицательное делимое даст отрицательное частное. ) ( 3.) : .LSB1 ( n -- ) 256 / 256 * - ; ( 4.) : .LSB2 ( n -- ) PAD 1 PAD C@ . ; : .MSB2 ( n -- ) PAD 1 PAD 1+ С@ . ; ( Описания в упражнениях 1 и 2 будут быстрее. ) ( 5.) : 256/ ( n1 -- n2 ) PAD 1+ С@ ; ( В отличие от 256 / это игнорирует знак числа.)
Блок 19 [19 :0] ( Глава 3. Упражнения 4. 02 из 02 ) ( 6.) : 256+ PAD ! PAD 1 + С@ 1 + PAD 1 + C! PAD @ ;
Блок 20 [20 :0] ( Глава 4. Упражнения 1. 01 из 02 ) ( 1. ) ( "Нормал." С округлением по нижн. границе) ( ост част ост част) а. 0 5 0 5 б. 0 0 0 0 в. 2 3 2 3 г. -2 -3 1 -4 д. 2 -3 -1 -4 е. -2 3 -2 3 ж. 0 -5 0 -5 з. 0 -5 0 -5 и. 0 5 0 5 к.
Деление на 0 является ошибкой ) Блок 21 [21 :0] ( Глава 4. Упражнение 1. 02 из 02 ) (2.) : LINE ( N -- строка ) 50 / ; (3.) : POS ( -- pos ) 50 MOD ; ( 4.) : POSLINE ( N длина -- роs строка ) /MOD ; ( 5.) : NEW/ ( n1 n2 -- n3) /MOD SWAP IF DUP 0 < IF 1+ THEN THEN ; : NEWMOD ( n1 n2 -- n3 ) 2DUP N/ * - ; ( 6.) ( 2000 100 30 */ . дает 6666 2000 30 /MOD 100 * SWAP 100 * 30 / + . . также дает 6666 2000 100 30 */MOD . . дает 6666 20 2000 30 /MOD 100 * SWAP 100 * 30 /MOD RОТ + . . дает 6666 20 Преимущество */ очевидно, тах как оно не дает переполнения)
Блок 22 [22 :0] ( Глава 4. Упражнения 2. 02 из 02 ) : .LARGEST-3 ( n1 n2 n3 -- ) MAX MAX . ; ( 2.) : 79.SMALLEST-3 ( n1 n2 n3 -- n1 n2 n3 ) 3 PICK 3 PICK 3 PICK MIN MIN ; ( FORTH-79 ) : 83.SMALLEST-3 ( n1 n2 n3 -- nl n2 n3 ) 2 PICK 2 PICK 2 PICK MIN MIN ; ( FORTH-83 ) ( 3. ) : TREE>5? ( n1 n2 n3 -- f ) 5 > MAX MAX 5 > ; ( 4. ) : ALL>5? ( n1 n2 n3 -- f ) 5 > MIN MIN 5 > ; ( 5.) : >LOWER2? ( n1 n2 n3 -- f ) ROT ROT MAX > ; ( 6.) : TEMPDIFF ( n1 n2 n3 ) - ABS ;
Блок 23 [23 :0] ( Глава 4. Упражнения 2. 02 из 02 ) ( 7. ) : LARCER-MAG ( n1 n2 -- n3 ) ABS SWAP ABS MAX ; ( 8. ) : NEAREST-0 ( n1 n2 -- n3 ) ABS SWP ABS MIN ; ( 9 ) : -ABS ( n -- -n или -n -- -n ) ABS NEGATE ; ( 10. ) : OTHER-QUAD ( x y -- -x -y и т.д.) NEGATE SWAP NEGATE SWAP ; ( 11. ) ; NEWNEGATE -1 * ;
Блок 24 [24:0] (Глава 4. Упражнения 3. 01 из 02 ( 1. ) : PYRVOL ( область h -- v) * 2 /MOD + ; ( 2. ) : F->C ( f -> c ) 32 - 5 9 */MOD SWAP 10 9 */ 5 + 10 / + ; ( SWAP 10 9 */ 5 t 10 / по существу округляет в большую сторону, добавляя к числу 0.5 . ) : 10F->10C (10f -- 10с ) 320 - 9 5 */MOD SWAP 100 90 */ 50 + 100 / + ; ( Вводите значение температуры, умноженое на 10, в результате получается та же, но округленная величина. Это способ работает с десятыми долями целого числа. )
Блок 25 [25 :0] ( Глава 4. Упражнения 3. 02 из 02 ) ( 3.) ( а. факторизируем [а + в]/c ) : (a.+.b)./.c ( a b c -- n) ROT ROT + SWAP / ; ( б. факторизируем [a + b/c]/c ) : (a.+.b./.c.)./.c ( а b с -- n) SWAP ОVER / ROT + SWAP / ; ( в.
факторизируем [a + b]^2 ) : (A.+.B)^2 ( а b -- n ) + DUP * ; ( г. факторизируем 3[а + b]^2 : 3.(A.+.B)^2 ( a b -- n ) (A.+.B)^2 3 * ; ( д. факторизируем [a + b]^4 ) : (a.+.b)^4 ( a b -- n) (A.+.B)^2 DUP * ; ( Оказывается даже сложные выражения могут стать простыми за счет факторизации)
Блок 26 [26 :0] ( Глава 4. Упражнения 4. 01 из 03 ) ( 1. ) ( а. 25E15 б. 25E-5 в. 25E5 г. 25E-6 д. 1Е-5 е. 1 ж. 25E2 з. 500.005 и. 499.998 к. 499.995 ) ( 2. ) : EXP* ( m1 e1 m2 e2 -- m3 e3 ) ROT + ROT ROT * SWAP ; ( 3. ) ( Здесь не принято никаких мер против переполнения : : EXP/ ( m е m е -- m е) ROT SWAP - 2 - ROT 100 * / SWAP ; ( Мантисса - 2 и показатель * 100 способствуют ( 4. ) ( предотвращению переполнения ) : TOM ( km m - m ) SWAP 1000 * + ; ( 5. ) : TOCMMM ( mm -- m mm ) 10 /MOD SWAP ;
Блок 27 [27 :0] ( Глава 4. Упражнения 4. 02 из 03 ) ( 6. ) : TOKM ( m -- km m ) 1000 /MOD SWAP ; ( 7. ) : TOFT ( mi ft - ft ) ROT 5280 * + ; ( 8. ) : TOMILES ( ft - mi ft ) 5280 /MOD SWAP ; ( 9. ) : FTTOM ( ft -- m) 305 1000 */ ; ( 10. ) : ТОMЕТRIС ( mi ft -- km cm ) TOFT FTTOM TOKM ; ( 11. ) : C->F ( c -- f ) 9 5 */ 320 + ;
Блок 28 [28 :0] ( Глава 4. Упражнения 4. 03 из 03 ) ( 12. ) : CIRCUM ( -- длина окружности в мм ) 10000 355 113 */ 3 8 */ ; ( Проблема заключается в подавлении переполнения) ( 13. ) : IN->FT ( in -- ft ) 12 /MOD SWAP 6 / + ; ( 6 / + эквивалентно добавлению 2/12 остатка. )
Блок 29 [29 :0] ( Глава 4. Упражнения 5. 01 из 13 ) ( 1.) 4.294.967.296 равно 2 в 32-ой степени. ) ( 2. ) ( 2DROP [ d -- ] 2DUP [ d -- d d ] 2SWAP [ d1 d2 -- d2 d1 ] 2OVER [ d1 d2 -- d1 d2 d1 ] 2ROT [ d1 d2 d3 -- d2 d3 d1 ] Не существует стандартных слов-эквивалентов PICK, ROLL или DEPTH для чисел двойной длины ) ( 3.) : NEW2DROP ( d -- ) DROP DROP ; ( 4. ) ( Это не то же самое. Число двойной длины содержит старшее и младшее числа, каждое из которых должно быть задублировано. )
Блок 30 [30 :0] ( Глава 4. Упражнения 5. 02 из 03 ) ( 5. ) : NEW2DUP ( d -- d d ) OVER OVER ; ( 6. ) 2SWAP83 ( d1 d2 -- d2 d1 ) 3 ROLL 3 ROLL ; ( F-83) 2SWAP79 ( d1 d2 -- d2 d1 ) 4 ROLL 4 ROLL ; ( F-79) ( 7. ) 2ROT83 ( d1 d2 d3 -- d2 d3 d1 ) 5 ROLL 5 ROLL ; ( F-83) 2ROT7( ( d1 d2 d3 -- d2 d3 d1 ) 6 ROLL 6 ROLL ; ( F-79) ( 8. ) 2OVER83 ( d1 d2 -- d1 d2 d1 ) 3 PICK 3 PICK ; ( F-83) 2OVER79 ( d1 d2 -- d1 d2 d1 ) 4 PICK 4 PICK ; ( F-79) ( 9. ) 2ROLL83 2 * DUP ROLL SWAP 1- ROLL ; ( FORTH-83) 2ROLL79 2 * DUP 1+ ROLL SWAP ROLL ; ( FORTH-79)
Блок 31 [31 :0] ( Глава 4. Упражнения 5. 03 из 03 ) ( 10. ) : 2PICK83 2 * DUP PICK SWAP 1- PICK ; ( FORTH-83 ) : 2PICK79 2 * DUP 1+ PICK SWAP PICK ; ( FORTH-79 ) ( 11. ) : S->D ( n -- d ) HI# ; ( 12. ) ( HI# будет содержать 0. ) ( 13. ) : 10^N 1 SWAP 0 DO 10 * LOOP : : BEF. #PT 1- 10^N 0 D/ ; : AFT. 2DUP ВЕF. #PT 1- 10^N 0 D* D- ; ( Таким образом можно разделить целую и дробную части числа двойной длины. )
Блок 32 [32 :0] ( Глава 4. Упражнения 6. 01 из 02 ) ( 1. ) ( 1 UM* выполнит это. Используются числа без знака. ) ( 2. ) : M* ( n n -- d ) 0 ROT 0 D* ; : М+ ( d n -- d ) 0 D+ ; : М- ( d n -- d ) 0 D- ; : М/ ( d n -- d ) 0 D/ DROP ; : M/MOD ( d n -- n n ) 0 D/MOD DROP SWAP DROP ; ( 3. ) ( Как M* так и М/МОD воспринимают числа со знаком, в то время как U* и U/MOD работают с числами без знака.)
Блок 33 [33 :0] ( Глава 4. Улражнения 6. 02 из 02 ) ( 4. ) : ->DOLLARS1 ( d -- n) 100 M/ ; ( MMSFORTH ) : ->DOLLARS2 ( d -- n) 100 0 D/ DROP ; ( Стандарт ) : ->CENTS1 ( d -- n) 2DUP ->DOLLARS1 100 * М- DROP ; ( MMSFORTH ) : -> CENTS2 ( d -- n) 2DUP ->DOLLARS2 100 * 0 D- DROP ; ( Стандарт ) ( 5. ) : FRAC1 2SWAP ROT 0 D/ ROT 0 D* ; ( Стандарт ) : FRAC2 M*/ ; ( MMSFORTH )
Блок 34 [34: 0] ( Глава 4. Упражнения 7. 01 из 01 ) ( 1.) ( а. % 5.5 % 1200 F+ F. б. % 23 % 5 F/ LOG F. в. DEGREES % 55 SIN 2DUP F* % 45 COS 2DUP F* F+ F. г. % 1- SQR F. д. % 3.25 2DUP F* PI F* F. ) ( 2. ) : RECT ( n1 n2 -- ) I-F FDF 5 ROLL I-F FDF DF* DF. ; ( 3.) : NEWFABS ( f1 -- f2 ) 2DUP F* SQR ; ( 4.) : HYPOT ( f1 f2 -- f3 ) 2DUP F* 2SWAP 2DUP F* F+ SQR ; ( 5. ) : TABLE1 0 46 DO I 3 .R ( приращение равно 1 градусу) I I-F SIN 10 F.R I I-F TAN 10 F.R CR ; : TABLE2 0 451 DO I I-F % 10 F/ 2DUP 6 F.R 2DUP SIN 10 F.R TAN 10 F.R CR LOOP ; ( приращение равно одной десятой )
Блок 35 [35 :0] ( Глава 4. Упражнения 6. 01 из 03 ) ( 1. ) а. 5 8 + % 5.5 % 6.5 F+ б. % 35 10 >87 F+ SIN в. % -55 FNEGATE ) ( 2. ) ( г. 5 . % 35 2DUP COS 2SWAP SIN F+ F. ) : 87FABS ( f1 -- f2 ) FDUP F* SQR ; : 87CINT ( f1 -- f2 ) 87> ; : 87I-F ( n -- f ) >87 ; : 87RAD PI % 180 F/ ; : 87L10 % 10 LOG ; ( 3. ) : FACT 1001 2 % 1 DO I >87 F* LOOP F. ; ( Выдает реэултт .4023872600770938Е2568; 100 итераций требует 10.1 секунд.
Выполнение цикла требует 7.1 секунд. Т.о. 100.000 преобразований в форму с плавающей точкой и умножений требуют 3.1 секунды. )
Блок З6 [36 :0] ( Глава 4. Упражнения 8. 02 из 03 ) ( 4. ) ( С клавиатуры % 113 % 355 F/ PI F- F. дает 2.66764E-7 или ошибку около 0.00000003 ) ( 5. ) : ANGLE ( x y -- угол ) DEGREES PHASE ; ( 6. ) : НУРОТ ( x y -- угол ) DEGREES MAG ; ( 7. ) : CONC-CHANGE ( pH H-ch -- % ) FSWAP FNEGATE 10^ F/ % 100 F* ; : DELTAPH ( рH H-ch -- pH1) ( Вычис. новое H, затем - новое pH) FSWAP FNEGATE 10^ F+ LOG10 FNEGATE ; ( Практически это нельзя сделать в рамках целочисленной арифметики, не написав программу размером в несколько блоков с таблицами логарифмов и степеней 10.)
Блок 37 [37 :0] ( Глава 4. Упражнения 8. 03 из 03 ) ( 8. ) : ARM-MOVE ( x1 y1 x2 y2 -- - приращение угла приращение радиуса ) DEGREES FOVER FOVER MAG DF87> PHASE DF87>
FOVER FOVER PHASE FROT FROT MAG DF>87 DF>87 FROT F- FROT FROT FSWAP F- FSWAP ; ( Поскольку не существует FPICK или 2FSWAP числа запоминаются в "обычном" стеке с помощью DF87> и восстанавливаются DF>87. )
Блок 38 [38 :0] ( Глава 5. Упражнения 1. 01 из 02 ) ( 1. ) : BS 8 EMIT ; ( 2. ) : РАПЕ 12 EMIT ; ( 3. ) : CRS 0 DO CR LOOP ; ( 4. ) : DASHES 0 DO 45 EMIT LOOP ; ( Это эквивалентно : DASHES 0 DO ." -" LOOP ; )
Блок 39 [39:0] ( Глава 5. Упражнения 1. 02 из 02 ) ( 5.) : MMENU ." MAIN МЕNU" ; : THIS ." This is the " ; : 1ST ." first " ; : 2ND ." second " ; : 3RD ." 3rd " ; : 4th ." FORTH " ; : СHЕ ." choice" : : MENU 9 SRACES 5 DASHES SPACE MMENU SPACE 5 DASHES 2 CRS 40 DASHES CR 4 SPACES ." A" 6 DASHES SPACE THIS 1ST СНЕ CR 4 SRACES ." В" 5 DASHES SPACE THIS 2ND СНЕ CR 4 SRACES ." С" 8 DASHES SPACE THIS 3RD СНЕ CR 4 SRACES ." D" 6 DASHES SPACE THIS 4TH СНЕ CR 40 DASHES CR 5 DASHES SPACE ." WHAT IS YOUR CHOICE, PLEASE?" SPACE 5 DASHES CR ; ( 6. ) : $. COUNT TYPE :
Блок 40 [40 :0] ( Глава 5.
Упражнения 2. 01 из 03 ) ( 1.) : PLOT1 CR DEPTH 0 DO MIN XS CR LOOP ; ( Заметьте, насколько элегантнее MIN, чем IF ... THEN. как это сделано в главе 1. ) ( 2.) : РLOТ2 РRINT CR DEPTH 0 DO 79 MIN XS CR LOOP CRT ; ( 3. ) : YS 0 DO 89 EMIT LOOP ; : PLOT3 CR DEPTH 2/ 0 DO YS CR XS CR LOOP ; ( 4. ) : PLOT4 CR DEPTH 0 DO I . 3 SPACES XS CR LOOP ; ( 5. ) : PLOT5 CR DEPTH 0 DO I . 3 SPACES 1- SPACES ." X" CR LOOP ; ( 1- необходима перед SPACES для того, чтобы поместить "X" в конец строки. )
Блок 41 [41 :0]. (Глава 5. Упражнения 2. 02 из 03 ) ( 6.) : PLOT6 CR DEPTH 0 DO I . SPACE 1- 75 1000 */ SPACES ." Х" CR LOOP ; ( Заметьте, что масштабирование выполнено с использованнем 75. ) ( 7.) : PLOT7 CR DEPTH 2/ 0 DO SWAP XS YS CR LOOP ; ( 8. ) : PLOT8 CR DEPTH 2/ 0 DO SWAP 1- SPACES ." X" 1- SPACES ." Y" CR LOOP ; ( 9. ) : PLOT9 СR DEPTH 2/ О DO SWAP 1- SPACES ." X" DUP 1- SPACES ." Y" . CR LOOP ; ( 10. ) : PLOT10 CR DEPTH 2/ 0 DO SWAP 1- SPACES ." X" DUP 60 1000 */ 1- SPACES ." Y" . CR LOOP ;
Блок 42 [42 :0] ( Глава 5. Упражнения 2. 03 из 03 ) ( 11.) : PLOT11 CR DEPTH 2/ 0 SWAP 0 DO OVER SWAP - 3 PICK SWAP 0 DO CB ." ." LOOP SPACES ." X" SWAP OVER . . LOOP DROP ; ( Это описание можно упростить, использовав переменную или второй стек, стек возвратов, который будет описан в следующих главах, вы можете убедиться тeпeрь, насколько проще временное запоминание чисел в PAD как в: ) : PLOT12 CR DEPTH 2/ 0 PAD ! 0 DO OVER OVER PAD @ - 0 DO CR ." ." LOOP SPACES ." X" DUP PAD I . . LOOP ; ( Хотя и не намного короче, PLOT12 имеет более простые манипуляции со стеком, так как предшествующая величина Х [или 0 в начале] записана в PAD. )
Блок 43 [43 :0] ( Глава 5. Упражнения 3. 01 из 03 ) ( 1. ) : UD$. ( ud -- ) TYPE ; ( 2. ) : UD$. ( u -- ) 0 TYPE ; ( 3. ) : S#. ( n -- ) DUP 0< NEGATE SWAP OVER DABS TYPE ; ( Здесь и в следующем упражнении NEGATE, как обсуждалось ранее, в FORTH-83 присутствовать не должен.) ( 4. ) : S$.R ( n1 n2 -- ) SWAP DUP 0< NEGATE SWAP OVER DABS ROT OVER - SPACES TYPE ; ( Длина поля n2, хранится в стеке пока это необходимо, а затем используется ROT OVER - SPACES, как в описании U.R в тексте. )
Блок 44 [44 :0] ( Глава 5. Упражнении 3. 02 из 03 ) ( 5.) : .L ( n1 n2 -- ) SWAP DUP D< NEGATE ROT OVER - ROT ROT TYPE SPACES ; ( Запомните, никакого NEGATE в FORTH-83 нет. ) ( 6. ) : .DATE ( d --) TYPE ; ( 7. ) : .MDY ( d -- ) TYPE ; ( 121, 100, и 109 являются ASCII "у", "d" и "m". )
Блок 45 [45 :0] ( Глава 5. Упражнения 3. 03 из 03 ) ( 1. ) : .PHONE ( n1 n2 n3 ---) 0 TYPE ; ( Заметьте, что можно преобразовывать несколько чисел одновременно, но DROP DROP необходимо для удаления из стека частного двойной длины, исключая n1. которое удаляется #> .) ( 9.) : Fl. ( d -- )
IF #РТ 1- 0 DO # LOOP THEN 46 HOLD #S #> TYPE ; ( Это иллюстрирует, какая программа может находиться ( между . При вводе .1234 будет отображен начальный 0.)
Блок 46 [46 :0] ( Глава 6. Упражнения 1. 01 из 04 ) ( 1.) VARIABLE FEET VARIABLE INCHES : F->I ( -- ) FЕЕТ @ 12 * INCHES ! ; ( 2.) 2VARIABLE DFEET 2VARIABLE DINCHES : DF->I DFEET 2@ 12 0 D* DINCHES 2! ; ( 0 формирует 12 число двойной длины. ) ( 3.) : NEW2! ( d адр -- ) SWAP OVER 2SWAP 2+ ! ! ; ( 2! может использоваться для запоминания двух чисел одинарной длины. n1 n2 адр 2! запоминает n1 по адресу "адр", а n2 по адресу "адр+2" .) ( 4. ) : NEW+! ( n адр - ) DUP @ RОТ + SWAP ! ; ( 5. ) : NEW@ ( адр -- n ) DUP 1+ С@ 256 * SWAP C@ + ;
Блок 47 [47 :0] ( Глава 6. Упражнения 1. 02 из 04 ) ( 6. ) : NEW! ( n адр --) OVER OVER SWAP 256 / SWAP 1+ С! С! ; ( 7.) : VARSWAP ( адр1 адр2 --) DUP @ PAD ! SWAP DUP @ ROT ! PAD @ SWAP ! : ( 8. ) CREATE 1WEEK 0 , 0 , 0 , 0 , 0 , 0 , 0 , CREATE 2WEEK 0 , 0 , 0 , 0 , 0 , 0 , 0 , ( Оба слова засылают при использовании в стек ) ( свои адреса.) : !SUN ! ; : !MON 2+ ! ; : !TUE 4 + ! ; : !WED 6 + ! ; : !THU 8 + ! ; : !FRI 10 + ! ; : !SAT 12 + ! ; ( Все слова имеют диаграмму преобразования стека ( n адр -- )
Блок 48 [48 :0] ( Глава 6. Упражнения 1. 03 из 04 ) ( 10. ) : @SUN @ ; : MON 2+ @ ; : @TUE 4 + @ ; : @WED 6 + @ ; : @THU 8 + @ ; : @FRI 10 + @ ; : @SAT 12 + @ ; ( Каждое слово живет схему преобразования стека (адр -- n) ( 11. ) : RSWAP ( n1 n2 адр -- ) SWAP 2 * OVER + ROT 2 * ROT + VARSWAP ; ( Каждое число должно умножаться на 2 и добавляться к адресу так, чтобы их содержимое можно было бы обменять с помощью VARSWAP ) ( 12. ) CREATE CNT 0 С, 0 С, 0 С, 0 С, 0 С, 0 С, 0 С,
Блок 49 [49 :0] ( Глава 6. Упражнения 1. 04 из 04 ) (13.) : +SUN 0 + +! 1 0 CNT + +! ; : +MON 2 + +! 1 1 CNT + +! ; : +TUE 4 + +! 1 2 CNT + +! ; : +WED 6 + +! 1 3 CNT + +! ; : +THU 8 + +! 1 4 CNT + +! ; : +FRI 10 + +! 1 5 CNT + +! ; : +SAT 12 + +! 1 6 CNT + +! ; ( Каждое слово имеет cxeuy преобразования стека адр -- n ) ( 14. ) : DAY-AVE ( день - средн. ) DUP DUP 2 * 1WEEK + @ SWAP 2 * 2WЕЕК + @ + SWAP CNT + C@ / ;
Блок 50 [50 :0] ( Глава 6. Упражнения 2. 01 из 01 ) ( 11.) : NEWFILL ( адр n с -- ) ROT SWAP OVER С! DUP ( 2. ) 1+ ROT 1- CMOVE ; : NEWERASE ( адр n -- ) 0 FILL ; ( 3. ) : INITIALIZE ( адр n -- ) 2 * ERASE ; ( 4. ) : ARR-COPY1 ( адр1 адр2 n -- ) 2 * CMOVE ; : ARR-COPY2 ( адр1 адр2 n -- ) MOVE ; ( 5. ) : ARR-EXCH ( адр1 адр2 n --) PAD ! ( Запишем счетчик в PAD) OVER PAD 2 + PAD @ MOVE ( Переносим адр1 в PAD ) DUP ROT PAD @ MOVE ( Переносим адр2 в адр1 ) PAD 2 + SWAP PAD @ MOVE ( Переносим PAD+2 в адр2 ) ;
Блок 51 [51 :0] ( Глава 6. Упражнения 3. 01 из 02 ) ( 1.) CVARIABLE CREATE 1 ALLOT ; 4VARIABLE CREATE 4 ALLOT : ( 2. ) ARRAY CREATE 2 * ALLOT ; ( 3. ) : CARRAY CREATE ALLOT ; : 2ARRAY CREATE 4 * ALLOT ; : 4ARRAY CREATE 8 * ALLOT ; ( 4. ) VARIABLE 1LENGTH VARIABLE 2LENCTH 12 CONSTANT 1->2 : CONVERT1-2 1LENGTH @ 1->2 * 2LENGTH ! ; : CONVBRT2-1 2LENGTH @ 1->2 / 1LEHGTH ! ; ( Сменить коэффициент можно путем замени 12 [см. выше] и рекомпиляции или путем n ' 1->2 ! [79]. или n ' {или [']} >BODY ! [83])
Блок 52 [52 :0] ( Глава 6. Упражнения 3. 02 из 02 ) ( 5.) : X->Y ( x -- у ) A @ * В @ + ; ( Замена операций путем изменения содержимого переменных А и В соответствует n А ! или n В ! .) ( 6.) ( В Форт-79 здесь нет различия. Оба засылают в стек адрес, где запомнено значение. ' >BODY является эквивалентом для Форт-83. ) ( 7.) : SET-FEET ( -- ) 12 ['] TO-INCHES >BODY ! ; : SET-YARDS ( -- ) 36 ['] TO-INCHES >BODY ! ; ( в описании-двоеточии должно использоваться ['] вместо '.)
Блок 53 [53 :0] ( Глава 6. Упражнения 4. 01 из 01 ) ( 1.) : SIR ." Dear Sir:" ; : MADAM ." Dear Madam:" ; : SORM ." Dear Sir or Madam:" ; VARIABLE HELLO : SALUTATION HELLO @ EXECUTE ; ( Смена приветствия путем FIND HELLO ! в Форт-79 или ' HELLO ! в Форт-83. ) ( 2. ) CREATE CHOICES FIND PRINT , FIND CRT , FIND PCRT , ( В Форт-83 используйте ' вместо FIND. ) : CHOOSE ." PRINTER (1), SCREEN(2), OR BOTH(3) " KEY 49 - 0 МАХ 2 MIN 2 * CHOICES + 6 EXECUTE ; ( Нажатие клавиши преобразуется в число от 0 до 2 путем вычитания значения ASCII 1 [49]. 0 МАХ 2 MIN гарантирует, что неверное нажатие клавиши не выведет из строя систему. )
Блок 54 [54 :0] ( Глава 6. Упражнения 4. 02 из 06 ) ( 3. ) VARIABLE COUNT1 VARIABLE COUNT2 VARIABLE COUNT3 0 COUNT1 ! 0 COUNT2 ! 0 COUNT3 ! VARIABLE WT1 VARIABLE WT2 VARIABLE WT3 0 WТ1 ! 0 WT2 ! 0 WT3 ! ( 4а. ) : CLASS ( wt -- n ) 100 / 0 MAX 2 MIN ; ( 4b. ) CREATE COUNTADDRS COUNT1 , COUNT2 , COUNT3 , CREATE WTADDRS WT1 , WT2 , WT3 , ( 4c. ) : BW ( wt --) DUP CLASS 2 * DUP 1 SWAP COUNTADDRS + @ +! WTADDRS + @ +! ;
Блок 55 [55 :0] ( Глава 6. Упражнения 4. 03 из 06 ) ( 4d. ) : SUMMARY ( n -- ) CR ." In class " DUP . ." there are " 2 * DUP COUNTADDRS + @ @ . ." bolts with a total weight of " DUP WTADDRS + @ @ . CR ." and а mean weight of " DUP WTADDRS + @ @ SWAP COUNTADDRS + @ @ / . ." ." CR ; ( 5. ) CREATE COUNT 0 , 0 , 0 , CREATE WEIGHTS 0 , 0 , 0 , : NBW ( wt -- ) DUP CLASS 2 * DUP 1 SWAP COUNT + +! WEIGHTS + +! ; ( Упражн. 4х5 иллюстрируют 2 способа сделать одну и ту же вещь. 4 также показывает насколько легко использовать переменные совместно с таблицами. Обратите внимание на сходство описания WT и NWT. NWT лучше, так как оно требует меньше памяти и времени, хотя 4 имеет небольшое преимущество контроля значений с помощью, например, WT1 @ . .)
Блок 56 [56 :0] ( Глава 6. Упражнения 4. 04 из 06 ) ( 5. ) : SMPHRASE ." under 200 grams, is " ; : MDPHRASE ." 100 to 200 grams, is " ; : LGPHRASE ." more then 200 gramss, is " ; CREATE PHRASES FIND SMPHRASE , FIND MDPHRASE , FIND LGPHRASE , ( В Форт-8З следует использовать ' вместо FIND . ) ( 6. ) 0 CONSTANT SMALL 2 CONSTANT MEDIUM 4 CONSTANT LARGE : SAY ( n -- n ) DUP PHRASES + @ EXECUTE ; : CNT ( n -- ) ." Total count, " SAY COUNT + @ . ; : WEICHT ( n -- ) ." Total weight, " SAY WE1GHTS + @ . ; : AVERAGE ( n -- ) ." AVERAGE weight, " SAY DUP WEIGHTS + @ SWAP COUNTS + @ / . ; ( SAY удаляет ненужные части следующих слов; эта техника, наэываемая разбором, широко используется в Форте.)
Блок 57 [57 :0] ( Глава 6.
Упражнения 4. 05 из 06) ( 7a. ) CREATE DVORAK 32 С, 123 С, 95 С, 37 С, 35 С, 33 С, 41 С, 45 С, 36 С, 94 С, 64 С, 43 С, 87 С, 56 С, 86 C, 90 С, 54 С, 91 С, 55 С, 53 С, 51 С, 49 С, 57 С, 48 С, 50 С, 52 С, 83 С, 115 С, 119 С, 61 С, 118 С, 122 С, 38 С, 65 С, 88 С, 74 С, 69 С, 62 С, 85 С, 73 С, 68 С, 67 С, 72 С, 84 С, 78 С, 77 С, 66 С, 82 С, 76 С, 34 С, 80 С, 79 С, 89 С, 71 С, 75 С, 60 С, 81 С, 70 С, 58 С, 47 С, 92 С, 93 С, 40 С, 42 С, 96 С, 97 С, 120 С, 106 С, 101 С, 46 С, 117 С, 105 С, 100 С, 99 С, 104 С, 116 С, 110 С, 109 С, 98 С, 114 С, 108 С, 63 С, 112 С, 111 С, 121 С, 103 С, 107 С, 44 С, 113 С, 102 С, 59 С, 63 С, 124 С, 125 С, 126 С, ( Это таблица преобразования клавиатуры QWERTY в Dvorak. Она начинается с пробела [ASCII 32], который имеет идентичиое значение для обоих типов клавиатуры. )
Блок 58 [58 :0] ( Глава 6. Упражнения 4. 06 из 06 ) ( 7и. ) : DKEY KEY DUP 31 > OVER 127 < AND IF 32 - DVORAK + С@ THEN ; ( DKEY используется также, где обычно ) ( 8. ) ( применяется KEY ) CREATE KEYBD FIND DKEY , FIND KEY , VARIABLE ?KBD ( В Форт-83 используйте ' вместо FIND. CONSTANT было бы быстрее, но скорость здесь не важна.) : CHOICE CR ." Type 1 for Dvorak" CR ." Type 2 for QWERTY" KEY DUP 49 - 0 MAX 1 MIN 2* KEYBD + @ ?KBD ! ; : NEWKEY ?KBD @ EXECUTE ; : TEST BEGIN NEWKEY EMIT 0 UNTIL ; ( Используется для теста клавиатуры. )
Блок 59 [59 :0] ( Глава 6. Упражнения 5. 01 из 03 ) ( 1.) 9 ARRAY NUMBERS : CLASS ( вес -- ) 10 / 0 МАХ 9 MIN ; : COUNTS ( n -- ) CLASS 1 SWAP NUMBERS +! ; ( 2.) 9 ARRAY WTSUM : !W ( вес счет -- ) DUP CLASS WTSUM +! ; ( 3. ) : .TOT-#S CR 10 0 DO I NUBMERS @ 6 .R LOOP ; : .TOT-WT CR 10 0 DO I WTSUM @ 6 .R LOOP ; : .AVE-WT CR 10 0 DO I WTSUM @ ( 4. ) I NUMBERS @ / 6 .R LOOP ; : !WT ( w -) DUP COUNTS !W .TOT-WT .TOT-#S .AVE-WT ; : INIT 10 0 DO DO 0 I WTSUM ! 0 I NUMBERS ! LOOP ; ( Используйте INIT для начального обнуления массива)
Блок 60 [60 :0] ( Глава 6. Упражнения 5. 02 из 03 ) 1 8 ARRAY NUMWTS : CLASS ( вес --) 10 / 0 МАХ 9 MIN ; ( Аналог.
CLASS ранее) : COUNTS ( вес ) CLASS 1 0 ROT NUMWTS +! ; : !W ( wt -- ) DUP CLASS 1 SWAP NUMWTS +! ; : .TOT-#S CR 10 0 DO 0 I NUMWTS @ 6 .R LOOP ; : .TOT-WT CR 10 0 DO I 1 NUMWTS @ 6 .R LOOP ; : .AVE-WT CR 10 0 DO 1 I NUMWTS @ 0 1 NUMWTS @ / 6 .R LOOP ; : !WT ( w -- ) DUP COUNTS !W .TOT-WT .TOT-#S .AVE-@T ; ( Это идентично предшествующему примеру. ) : INIT 10 0 DO 0 0 I NUMWTS ! 0 1 NUMWTS ! LOOP ; ( Заметьте, насколько это похоже на предшествующее упражн. Использование матрицы экономит немного место за счет потери некоторого времени. Реальное преимущество матрицы сказыва- ется при размерности больше двух или, когда для математических расчетов необходима матричная алгебра. )
Блок 61 [61 :0] ( Глава 6. Упражнения 5. 03 из 03 ) ( 6.) CREATE NEWSTACK 32 ALLOT VARIABLE STACKPOS NEWSTACK STACKPOS ! : XPUSH ( n -- ) STACKPOS @ ! 2 STACKPOS +! ; : XPOP ( -- n ) -2 STACKPOS +! STACKPOS @ @ ; : PUSH ( n -- ) STACKPOS @ NEWSTACK 28 + MIN STACKPOS ! XPUSH ; : POP ( -- n ) STACKPOS @ NEWSTACK 2 + MAX STACKPOS ! XPOP ; ( Когда стек станет пуст, POP выдаст число, которое было занесено туда последним. Аналогично, когда стек заполнен, PUSH перезапишет верхнее число, в то время как XPUSH и XPOP разрушит систему из-за переполнения стека. ) ( 7. ) : NEWDROP POP DROP ; ( Форт в действительности контроли-) : NEWDUP POP PUSH PUSH ; ( рует стек аналогичным образом ) : NEWSWAP POP POP SWAP PUSH PUSH ;
Блок 62 [62 :0] ( Глава 7. Упражнения 1. 01 из 03 ) ( 1. ) : NEW> ( n1 n2 -- f ) SWAP < ; : NEW0< ( n -- f ) 0 < ; : NEW0> ( n -- f ) NEGATE NEW0< ; : NEW= ( n1 n2 -- f ) - 1+ NEW0> ; : NEW= ( n1 n2 -- f ) OVER OVER NEW= AND ; : NEW<> ( n1 n2 -- f ) - DUP NEW0< SWAP NEW0> OR ; : NEW0= ( n -- f ) 0 NEW= ;
Блок 63 [63 :0] ( Глава 7. Упражнения 7. 02 из 03 ) ( 2. ) ( а. = ROT ROT = AND б. ROT ROT = OR в. <> ROT ROT = AND г. <> ROT ROT = OR д. 0 ROT ROT <> AND е. = ROT ROT = XOR ж. < ROT ROT > AND з. OVER = SWAP ROT = AND и. OVER < SWAP ROT < AND ) ( 3. ) : ?REM=0 MOD 0= ; ( 4. ) : ?REM MOD 0= NOT ; ( 5. ) : ?OPPOSITE + 0= ; : NEW= - 0= ;
Блок 64 [64 :0] ( Глава 7. Упражнения 1. 03 из 03 ) ( 6.) : D= D- 0= SWAP 0= AND ; ( 7.) : COMP DUP 0< NEGATE SWAP 0> + ; \ Блок 65 [65 :0] ( Глава 7. Упражнения 2. 01 из 02 ) ( 1.) : NEWABS ( -n -- n ) или n -- n ) ?DUP 0< IF NEGATE THEN ; ( 2.) : /0? ( n --) ?DUP IF / ELSE DROP ( 3. ) ." Divide by 0 error" THEN ; : TYPE IF TYPE ELSE DROP DROP THEN ; (v4.) : 1TASK ." A " ; : 2TASK ." T " ; : 3TASK ." X" ; : ?WHICH-TASK ( -- ) KEY DUP 65 = IF 1TASK ELSE DUP 84 = IF 2TASK ELSE DUP 88 = IF 3TASK THEN THEN THEN DROP ;
Блок 66 [66 :0] ( Глава 7. Упражнения 2. 02 из 02 ] ( 5.) : UPPER-KEY ( -- с) KEY DUP 96 > OVER 123 < AND IF 223 AND THEN ; ( 6.) : NO-CONT-KEY ( -- с ) UPPER-KEY DUP 32 < IF 64 + THEN ; ( 7.) : ALPHA-KEY ( -- с ) NO-CONT-KEY DUP 47 > OVER 58 < AND IF DROP THEN ; ( 8. ) : D->S ( d -- n или d -- d ) ?DUP IF THEN : ( : D->S DUP 0= IF DROP THEN ; ( также работает, но медленнее.)
Блок 67 [67 :0] ( Глава 7. Упражнение 3. 01 и 03 ) ( 1. ) : ?END ." Do you want to quit? (Y/N) " КEY 89 = IF CR ." Do you want to save the stack? (Y/N) " KEY 118 = IF ." OK" CR QUIT ELSE ." OK" CR ABORT THEN THEN ; ( 2. Нет. ) ( 3. ) ( Первое остановит программу, вторые два обеспечат только выход из слова ?223 .) ( 4. Нет. ) ( 5. ) : 0? ( n1 -- n2) ?DUP 0= IF ." Number is zero " ( 6. ) ABORT THEN ; : =IF-ABORT = IF ABORT THEN ;
Блок 68 [68 :0] ( Глава 7. Упражнения 3. 02 из 03 ] ( 7. ) : +RANGE-ABORT ( n1 n2 -- n1 n2 ) OVER ОVER 0 ROT 0 D+ 0= 0= IF ." Add overflow error ? " ABORT THEN ; ( 8.) : +*RANGE-ABORT +RANCE-ABORT ОVER ОVER 0 ROT 0 D+ 0= 0= IF ." Multiply overflow error ? " ABORT THEN ; ( 9.) : STACK-TOO-BIG ( -- ) DEPTH 15 > IF ." Stack too big ?" ABORT THEN ;
Блок 69 [69 :0] ( Глава 7. Упражнения 3. 03 из 03 ) ( 10a. ) : DOTHAT ." That " ; : DOOTHER ." Other " ; : 1TASK ( n -- ) 0= IF DOTHAT THEN ; ( 10b. ) : 2TASK ( n -- ) IF DOTHAT THEN ; ( 10c. ) : 3TASK ( n -- ) 0= IF DOTHAT ELSE DOOTHER THEN ; ( 10d. ) : 4TASK ( n -- ) IF DOTHAT DOOTHER THEN ;
Блок 70 [70 :0] ( Глава 7. Упражнения 4. 01 из 02 ) ( 1.) CREATE МАТH , FIND + , FIND - , FIND * , FIND / , ( В Форт-83 используйте ' вместо FIND ) : ARITH ( n1 n2 n3 -- ) 1- 2* MATH + @ EXECUTE ; : ARITH' ( n1 n2 n3 -- n4 ) DUP 0 > ОVER 5 < AND IF 1- 2* MATH + @ EXECUTE ELSE DROP DROP DROP 0 ТHEN ; ( 2.) : ARITH-' ( n1 n2 n3 -- n4 ) NCASE 1 3 4 " + - * / OTHERWISE DROP DROP 0 CASEND ; ( 3. ) : NEWARITH ( n1 n2 -- n3 ) KEY ACASE +-*/" + - * / OTHERWISE DROP DROP 0 CASEND ;
Блок 71 [71 :0] ( Глава 7. Упражнения 4. 02 из 02 ) ( 4. ) : NEWARITH' KEY DUP 43 = IF DROP + ELSE DUP 45 = IF DROP - ELSE DUP 42 = IF DROP * ELSE 47 = IF / ELSE DROP DROP 0 THEN THEN THEN THEN ; ( 5.) : NEWARITH'' ( --) KEY ACASE +-*/" + - * / OTHERWISE ." Incorrect input " ABORT CASEND ; ( 6. ) ( Если вы хотите изменить задание путем замены содержимого вектора. Векторное исполанениее кроме того быстрее. )
Блок 72 [72 :0] ( Глава 8. Упражнения 1. 01 из 06 ) ( 1. ) : ASCIITAB ( - ) CR 1+ SWAP DO I 4 .R 3 SPACES I EMIT CR LOOP ; ( 2. ) : ASCIICHAR ( -- ) CR 33 9 0 DO 10 0 DO DUP I J 10 * + + 4 .R LOOP CR 10 0 DO DUP I J 10 * + + 3 SPACES EMIT LOOP CR LOOP DROP : ( 3. ) : ZERDIAG ( адр -- ) 5 0 DO DUP I 5 * I + 2 * + 0 SWAP ! LOOP DROP ;
Блок 73 [73 :0] ( Глава 8. Упражнения 1. 01 из 06 ) ( 4.) : SUMCOL ( адр -- n1 n2 n3 n4 n5 ) 5 0 DO 0 SWAP 5 0 DO DUP I J + 2 * + @ ROT + SWAP LOOP LOOP DROP ; ( 5.) : X^5 ( n - n^5 ) DUP 4 0 DO OVER * LOOP ;
Блок 74 [74 :0] ( Глава 8. Упражнения 1. 03 из 06 ) ( 6.) : D** ( n1 n2 -- ) ?DUP 0= IF DROP 1. - ELSE DUP 1 = IF DROP 0 ELSE 0 ROT 0 2SWAP 2OVER 2SWAP DROP 1- 0 DO 2OVER D* LOOP 2SWAP 2DROP THEN THEN ( 7. ) : DUMP ( адр -- ) CR BASE @ SWAP HEX 10 0 DO 16 0 DO DUP I J 16 * + + C@ 3 .R LOOP CR LOOP DROP BASE ! ;
Блок 75 [75 :0] ( Глава 8. Упражнения 1 04 из 06 ) ( 8. ) : DUMP2 CR BASE @ SWAP HEX 10 0 DO DOP I 16 * + 5 .R 16 0 DO DUP I J 16 * + + С@ 3 .R LOOP CR LOOP DROP BASE ! ; ( 9. ) : DUMP3 ( адр -- ) CR BASE @ SWAP HЕХ 5 0 DO DUP I 16 * + 5 U.R 16 0 DO DUP I J 16 * + + С@ 3 .R LOOP CR 5 SPACES 16 0 DO DUP 2 SPACES I J 16 * + + С@ DUP 32 < OVER 127 > OR IF DROP 46 EMIT ELSE EMIT THEN LOOP CR LOOP DROP BASE ! ;
Блок [76 :0] ( Глава 8. Упражнения 1. 05 из 06 ) ( 10. ) VARIABLE SPCS : COUNT-SPCS ( адр --) 1024 0 DO DUP I + С@ 32 = IF 1 SPCS +! THEN LOOP DROP ; ( 11. ) CREATE ALPHA 52 ALLOT : ALPHACOUNT ( адр cw -- ) ALPHA 52 0 FILL ( очистка массива ) 0 DO DUP I + С@ 223 AND DUP 64 > OVER 91 < AND IF 65 - 2 * ALPHA + 1 SWAP +! ELSE DROP THEN LOOP DROP ;
Блок 77 [77 :0] ( Глава 8. Упражнения 1. 06 из 06 ) ( 12. ) : LETTERBAR ( n с --) SWAP 0 DO DUP EMIT LOOP DROP ; : ALPHALLOT ( -- ) ALPHA CR 26 0 DO DUP I 2 * + @ ?DUP 0= 0= IF I 65 @ LETTERBAR CR THEN ; LOOP DROP QUIT ; ( 13. ) : .S ( -- ) DEPTH ?DUP 0= IF ." Stack empty" ELSE 0 DO DEPTH ROLL DUP . LOOP THEN ;
Блок 78 [78 :0] ( Глава 8. Упражнения 2. 01 из 03 ) ( 1. ) : .ARR ( адр n --) 2 * CR 0 DO DUP I + @ . ( 2. ) 2 +LOOP DROP ; : .SQARR ( адр n -- ) 2 * CR DUP @ DO DUP 0 DO OVER I J + + @ . 2 +LOOP CR 2 +LOOP 2DROP ; ( 3. ) : D.ARR ( адр n --) 4 * CR 0 DO DUP I + 2@ D. 4 +LOOP DROP ; : D.SQARR ( адр n -- ) 4 * CR DUP 0 DO DUP 0 DO OVER J + + 2@ D. 4 +LOOP CR 4 +LOOP 2DROP ; ( Может покаэаться более естественным использовать LOOP и 2 * или 4 * для вычисления адреса извлекаемого элемента, но быстрее использовать +LOOP и делать умножение только раз в начале описания. )
Блок 79 [79 :0] ( Глава 1. Упражнения 2. 02 из 03 ) ( 4. ) : F-C ( -- ) СК 201 0 DO I 6 .R I 32 - 5 9 */ 6 .R CR 10 +LOOP ; ( Заметьте, что хотя шаг цикла равен 10, предел цикла должен только на 1 превосходить верхнюю ступеньку. ) ( 5. ) : F-C1 ( -- ) CR 0 200 DO I 6 .R I 32 - 5 9 */ 6 .R CR 10 +LOOP ; ( 6. ) : FINDCHAR ( адр1 с -- адр2 ) 1024 0 DO OVER OVER SWAP 1 + C@ IF DROP I + LEAVE THEN LOOP ;
Блок 80 [80 :0] ( Глава 8. Упражнения 2. 03 из 03 ) ( 7. ) : $= ( адр1 адр2 -- f ) OVER OVER C@ SWAP C@ = 0= IF 0 DROP DROP EXIT THEN 1+ SWAP 1+ DUP 1- С@ 0 DO OVER OVER I + C@ SWAP I + C@ = 0= IF DROP DROP 0 LEAVE THEN LOOP DUP IF DROP DROP 1 ( или -1 для Форт-03) THEN ; ( 8. ) : SEARCH ( адр @адр -- f ) 1+ DUP 1- C@ 0 DO OVER OVER 1 + C@ SWAP I + C@ = 0= IF DROP DROP 0 LEAVE THEN LOОР DUP IF DROP DROP 1 ( или -1 ) THEN ; : $FIND ( адр $адр - адр ) 1024 0 DO SWAP 1+ SWAP OVER OVER SEARCH IF LEAVE THEN LOOP DROP ;
Блок [81 :0] ( Глава 1. Упражнение 3. 01 из 02 ) ( 1. ) : .4PICK ( n1 n2 n3 n4 -- n2 nЗ n4) >R >R >R . R> R> R> ; ( Do-loop нельзя применять, так как там испольэуется стек возвратов ) ( 2.) : DUP1 ( n -- n n ) >R R@ R> ; ( 3. ) : J1 R> R> R> R@ SWAP >R SWAP >R SWAP >R ; ( 4. ) : К R> R> R> R> R> R@ SWAP >R SWAP >R SWAP >R SWAP >R SWAP >R ; ( 5. ) : J' R> R> R> R> R@ SWAP >R SWAP >R SWAP >R SWAP >R ;
Блок 82 [82 :0] ( Глава 8. Упражнения 3. 02 из 02 ) ( 6. ) : NEWLEAVE R> R> DROP R@ >R >R ; ( 7.) ( Выполним R> R> DROP, чтобы записать новое число, а затеи исполним >R >R . ) ( 8.) ( I 10 = IF R> DROP 15 >R THEN ) ( 9. ) : +INDEX ( n -- ) R> SWAP R> + >R >R ; ( 10. ) ( Возникает бесконечный цикл, так как индекс всегда увеличивается до того, как он будет уменшен оператором LOOP. Такям образом индекс никогда не достигнет предела.)
Блок 83 [83 :0] ( Глава 8. Упражнение 4. 01 из 02 ) ( 1.) VARIABLE N 1000 N ! : POPSIZE CR 501 0 DO N @ 200 / N +! I 1+ 50 MOD 0= IF I 1+ ." Day " U. N @ ." Size " U. CR THEN LOOP 1000 N ! ; ' ( Население не может увеличиватся менее чем на 200 ) ( 2. ) 1000 N ! : POPDOUBLE CR N @ 2 * 10000 0 DO N @ 200 / N +! DUP N @ R BEGIN DEPTH ROLL DUP . R> 1- >R R@ 0= UNTIL R> DROP ; ( 2. ) : ST-SUM ( -- ) DEPTH 0= IF 0 EXIT THEN 0 BEGIN + DEPTH 1 = UNTIL ; : ST-SUM1 ( -- ) DEPTH 0= IF 0 EXIT THEN DEPTH 1 = IF EXIT THEN DEPTH 1- 0 DO + LOOP ; ( 3. ) VARIABLE TOTAL 500 TOTAL ! : ?YEAR1 ( -- ) CR BEGIN DUP 4 .R TOTAL @ 10 / DUP 6 .R TOTAL +! 1+ TOTAL @ DUP 6 .R CR 1000 >
UNTIL 500 TOTAL ! ;
Блок 86 [86 :0] ( Глава 8. Упраиенмя 5. 02 из 03) ( 4.) VARIABLE #MICE 1000 #MICE ! : MICE ( -- ) #MICE @ 2 * 0 BEGIN #MICE @ 200 / #MICE +! 1+ OVER #MICE @ 0= IF DROP DROP EXIT ELSE KEY DUP 13 <> TNEN WHILE DUP 8 = ( если backspace ... ) IF NEISPAN @ 0 = ( если NEWSPAN равен 0, игнорируем) IF DROP ELSE -1 NEWSPAN +! EMIT THEN ELSE DUP EMIT OVER NEWSPAN @ + C! 1 NEWSPAN +! THEN REPEAT DROP DROP DROP ; ( Из цикла do-loop не просто осуществить условный переход туда, куда надо и выйти, так как мы это здесь сделали.)
Блок 89 [89 :0] ( Глава 9. Упражнения 1. 02 из 04 ) ( 3.) : .ЕУЧЕ ( адр -- ) 0 BEGIN OVER OVER + С" 0= 0= WHILE 1+ REPEAT 1+ TYPE ; ( В Форт-83 вы можете просто выдать адр SPAN @ TYPE ) ( 4.) CREATE $SPACE 258 ALLOT ( оставляет 2 байта для нулей ...) : GET$ ( -- адр ) $SPACE 1+ 255 OVER OVER BLANK ." ?" OVER OVER EXPECT -TRAILING $SPACE C! 1- ; ( В Форт-83 это описание будет иметь вид: ) : 83GET$ ( - $адр ) $SPACE 1+ 258 ." ?" EXPECT $SPACE DUP SPAN @ SWAP C! ;
Блок 90 [90 :0] ( Глава 9. Упражнения 1. 03 из 04 ) ( 5. ) : ADD$ ( - $адр) $SPACK C@ 255 < IF $SPACE DUP C@ + 255 $SPACE C@ - 1+ OVER OVER BLANK ." ?" OVER OVER EXPECT -TRAILING $SPACE C@ + $SPACE С! DROP $SPACE ELSE ." Not enough room to add string " $SPACE EXIT THEN ; ( 6.) : ADD$1 ( -- $адр ) $SPACE C@ 255 < IF $SPACE DUP C@ + 255 $SPACE C@ - 1+ OVER OVER BLANK ." ?" OVER OVER EXPECT -TRAILING $SPACK C@ + DUP 254 > IF DROP DROP $SPACE EXIT THEN $SPACE C! DROP $SPACE ELSE ." Not enough room to add string! " $SPACE EXIT THEN ;
Блок 91 [91 :0] ( Глава 9. Упражнения 1. 04 из 04 ) ( 7.) : !DOLLAR$ ( d --) SWAP OVER DABS DUP $SPACE C! $SPACE 1+ SWAP CMOVE ; ( 8. ) : LEFT$ ( адр1 n -- адр2 ) OVER C@ MIN DUP ROT 1+ PAD 1+ ROT CMOVE PAD C! PAD ;
Блок 92 [92 :0] ( Глава 9. Упражнения 2. 01 из 02 ) ( 1. ) ( следует ли нам заботиться о начальном обнулении длины ? ) : VARIABLE ( n -- ) CREATE ALLOT ; ( 2. ) : $! ( $адр1 $адр2 -- ) OVER C@ 1+ CMOVE ; ( 3. ) : $GET ( $адр -- ) 34 WORD SWAP OVER C@ 1+ CMOVE ; ( 4. ) : $" ( --$адр ) 34 WORD PAD OVER C@ 1+ CMOVE PAD ; ( 5. ) ( $" входная строка" $SPACE $! , например, решает стоящую задачу.) ( 6. ) CREATE CHOCES $1 , $2 , $3 , $4 , $5 , $6 , $7 . $8 , $9 , $10 , ) : .$CHOISE ( n -- ) 1- 2 * CHOICES + @ COUNT TYPE ;
Блок 93 [93 :0] ( Глава 9. Упражнения 2. 02 из 02 ) ( 7. ) 2 20 $VARIABLE 1STRING 20 $VARIABLE 2STRINC 3 20 $VARIABLE 3STRING 20 $VARIABLE 4STRING CREATE NSTRING 1STRING , 2STRING , 3STRING , 4STRING , : PARSE$ TIB 80 BLANK 0 >IN ! ." ?" QUERY 4 0 DO 35 WORD I 2 * NSTRING + @ $! LOOP TIB 80 BLANK ; ( 8. ) : PARSE$1 TIB 80 BLANK 0 >IN ! ." ?" QUERY 4 0 DO 35 WORD >IN @ .
I 2 * NSTRING + @ #! LOOP TIB 80 BLANK ; ( > IN увеличивается оператором WORD по мере разбора ) ( входного потока . ) : (( 41 WORD DROP ; IMMEDIATE (( Это действительно работает? Если да, то все это будет проигнорирована и не будет дано сообщения об ошибке ) : TEST (( Nor will this. ) ;
Блок 94 [94 :0] ( Глава 9. Упражнения 3. 01 иэ 03 ) ( 1. ) : NEWLEFT$ ( $адр1 n -- $адр2 ) 1 SWAP MID$ ; : NEWRIGHT$ ( $адр1 n - $адр2) ( 2.) OVER C@ OVER - 1+ SWAP MID$ ; : $CHAR ( с -- $адр ) 1 PAD С! PAD 1+ С! PAD ; ( 3.) : 1STCHAR ( $адр -- с) 1+ C@ ; ( 4.) : $SWAP ( $адр1 $адр2 --) DUP DUP С@ 1+ PAD SWAP CMOVE OVER SWAP OVER С@ 1+ CMOVE PAD SWAP OVER C@ 1+ CMOVE ; : $SWAP1 ( $aдр1 $адр2 --) DUP PAD $! OVER SWAP $! PAD SWAP $! ; ( Преимущество MMSFORTH-пакета операторов для работы со строками очевядио. ) ( 5. ) ( LEFT$ RIGHT$ CHR$ ASC $XCHG )
Блок 95 [95 :0] ( Глава 9. Упражнения 3 02 из 03 ) ( 6. ) : BUILD$ ( $адр -- ) >R BEGIN INKEY$ DUP DUP $. $" #" $COMPARE WHILE R@ SWAP $+ R@ $! REPEAT R> DROP ; ( 7.) : BUILD$1 ( $адр -- ) IN$ SWAP $! ; ( 8. ) ( Но здесь не используется # ) ( Опишите 30 CONSTANT SIZE и используйте SIZE всюду, где используется 10 в STOREPHONE , GETPBONE к т.д. Преимущество заключается в легокости изменения размера словаря) ( 9. ) : SHOWPHONES ( -- ) CR 10 ( или SIZE ) 0 DO 1 0 PHONES $. 2 SPACES I 1 PHONES $. I AVAILABLE + C@ 0= IF LEAVE ELSE CR THEN LOOP ;
Блок 96 [96 :0] ( Глава 9. Упражнения 3. 03 из 03 ) ( 10. ) : ERASEALL ( --) ." Are you sure you want to do this? (Y/N)?" KEY 89 IF 0 0 PHONES 600 0 FILL AVAILABLE 10 0 FILL ELSE ." Not done." THEN ;
Блок 97 [97 :0] ( Глава 9. Упражнения 4. 01 из 03 ) ( 1. ) : $IN PAD 1+ 255 OVER OVER BLANK ." ?" OVER OVER EXPECT -TRAILING PAD C! 1- ; ( используется ниже ) : D#IN1 ( -- d ) 0 0 $IN CONVERT DROP ; : D#IN2 ( -- d ) BEGIN $IN DUP 0 0 ROT CONVERT 4 ( 3 в Форт-83 ) ROLL 1+ = WHILE ." REDO " DROP DROP REPEAT ; : D#IN3 BEGIN $IN DUP 1+ C@ 45 = DUP >R IF 2+ THEN DUP 0 0 ROT CONVERT ROT ROT R>
IF DNEGATE THEN 4 ( 3 в Форт-83 ) ROLL 1+ 4 ( 3 в Форт-83 ) ROLL = WHILE ." REDO " DROP DROP REPEAT ;
Блок 98 [98 :0] ( Глава 9, Упражнения 4. 02 из 03 ) (2. ) : #IN. ( -- n ) BEGIN $IN DUP 1+ C@ 45 = DUP >R IF 1+ THEN DUP 0 0 ROT CONVERT ROT ROT R>
IF DNEGATE THEN 4 ( 3 для Форт-83 ) ROLL 1+ 4 ( 3 ) ROLL DUP C@ 46 = 0= >R = WHILE R> DBOP ."REDO " DROP DBOP REPEAT R> IF DROP THEN ;
Блок 99 [99 :0] ( Глава 9. Упражнения 4. 03 из 03 ) ( 3.) : $IN3 ( -- n ) $IN NUMBER DROP ; ( 4. ) : INFIX ( -- n ) 32 WORD NUMBER DROP ; ( Это слово упрощает последующие описания. ) : PLUS ( n1 -- n2 ) INFIX + ; ( 5.) : TIMES ( n1 -- n2 ) INFIX * ; : DIVIDEDBY ( n1 -- n2 ) INFIX / ; : MINUS ( n1 -- n2 ) INFIX - ; : EQUALS ( n --) . ;
Блок 100 [100 :0] ( Глава 10, Упражнения 1. 01 из 01 ) ( 1.) ( Приведенное здесь описание продолжает работу после загрузки следущего блока. Предшествующее описание этого не делает и остаток блока будет проигнорирован. ( 2.) : N--> 0 >IN ! BLK @ ." Block " . ." loaded" CR 1 BLK +! ; ( 3. ) : LISTS ( n1 n2 -- ) OVER + SWAP DO CR CR ." Block " I DUP . LIST CR CR CR CR LOOP ; ( 4.) : ^ ( -- ) CR ." Block " BLK @ . >IN @ 64 /MOD ." Line " . ." Character " 2 - . CR ; IMMEDIATE ( 5. ) ( FORGET TASK 20 LOAD )
Блок 101 [101 :0] ( Глава 10. Упражнения 2. 01 из 02 ) ( 1. ) : SLOAD ( n -- ) DUP 2 MOD IF ." Can't load odd blocks" ABORT THEN LOAD ; ( или ) ( : SLOAD1 ) ( n -- ) ( DUP 2 MOD ABORT" Can't load odd blocks" LOAD ; ) ( 2. ) : SLIST ( n -- ) DUP 2 MOD + LIST ; ( 3. ) : SVIEW ( n -- ) DUP 2 MOD 0= - ( + в Форт-83 ) LIST ; ( 4. ) : SLISTS ( n1 n2 -- ) 2 * SWAP DUP 2 MOD + SWAP OVER + SWAP DO CR CR ." Block " I DUP . LIST CR CR CR CR 2 +LOOP ;
Блок 102 [102 :0] ( Глава 10. Упражнения 2. 02 из 02 ) ( 5. ) : SVIEWS ( n1 n2 ) 2 * SWAP DUP 2 MOD 0= - ( + в Форт-83 ) SWAP OVER + SWAP DO CR CR ." Block " I DUP . LIST CR CR CR CR 2 +LOOP : ( 6.) : S--> 0 >IN ! BLK +! ; IMMEDIATE
Блок 103 [ 103 :0] ( Глава 10. Упражнения 3. 01 из 02 ) ( 1. ) 100 CONSTANT PACFORTH ( 2. ) : GET FIND 2* @ LOAD ; ( В Форт-79 ) : GET1 ' >BODY @ LOAD ; ( В Форт-83 ) ( 3. ) : LOADIT ( адр -- ) DUP @ 0 DO DUP I 2 * + 2 * @ LOAD LOOP DROP ; ( 4. ) : SHOWBLOCKS ( адр -- ) DUP @ 0 DO DUP I 2 * + 2 + @ . LOOP DROP ;
Блок 104 [104 :0] ( Глава 10. Упражнения 3. 02 из 02 ) ( 5.) : ?BLOCKS ( адр -- ) CR DUP @ 0 DO DUP I 2 * + @ SHOWBLOCKS CR LOOP DROP ; ( 6. ) : LOADEM ( адр n -- ) 2 * 2 + @ LOADIT ;
Блок 105 [105 :0] ( Глава 10. Упражнения 4. 01 из 03 ) ( 1. ) : .LINE ( n1 n2 -- ) SWAP BLOCK SWAP 64 * + 64 -TRAILING TYRE ; ( 2.) : NEWINDEX ( n1 n2 -- ) OVER + SWAP DO CR I . I 0 .LINE LOOP ; ( 3.) : NEWLIST ( n -- ) 16 0 DO CR DUP I DUP 2 .R SPACE .LINE LOOP DROP ; ( 4. ) : BLLINE ( n1 n2 -- ) SWAP BLOCK SWAP 64 * + 64 32 FILL UPDATE ; ( 5.) : NEWTL ( n1 n2 -- ) 1+ SWAP DO CR SCR @ I DUP 2 .R SPACE .LINE LOOP ; : NEWLIST1 ( n -- ) SCR ! 0 15 TL ;
Блок 106 [106 :0] ( Глава 10. Упражнения 4. 02 из 03 ) ( 6. ) : CLEAR-BLOCK ( n -- ) BLOCK 1024 32 FILL UPDATE ; ( 7. ) : PP ( n1 n2 -- ) SWAP BLOCK SWAP 64 * + DUP 64 32 FILL 0 WORD 1+ DUP 1- C@ -TRAILING ROT SWAP CMOVE UPDATE ; ( 8. ) : NEWCOPY ( n1 n2 --) SWAP BLOCK SWAP BLOCK 1024 ( 9. ) CMOVE UPDATE ; : ( n1 n2 n3 -- ) 0 DO OVER OVER SWAP I' I - + 1- SWAP I' I - + 1- NEWCOPY LOOP DROP DROP ; ( но I' также не стандартное слово ) ( 11. ) : COPIES ( n1 n2 nЗ -- ) ROT ROT OVER OVER < IF ROT COPIES> ELSE ROT
IF ." Block overflow! " ABORT ELSE STORBLK @ BLOCK SWAP ARRLEN @ * + ARRLEN @ CMOVE UPDATE THEN ; ( 2.) CREATE ARRAY 1 , 2 , 3 , 4 , 5 , CREATE 2ARRAY 6 , 7 , 8 , 9 , 0 : PUTARRAYS ( адр1 адр2 n -- ) DUP 1+ 20 * 1024 >
IF ." Block overflow! " ABORT ELSE 20 * >R SWAP STORBLK @ BLOCK R@ + 10 CMOVE STORBLK @ BLOCK R> + 10 + 10 CMOVER UPDATE THEN ;
Блок 109 [ 109 :0] ( Глава 10. Упражнения 5. 02 из 05 ) ( 3.) 700 CONSTANT PATBLOCK ( Измените это, если нужно : PD ( n1 n2 n3 n4 -- ) DUP 1+ 2 * 1024 >
IF ." Block overrun " ABORT THEN 2 * > R PATBLOCK 2+ BLOCK R@ + ! UPDATE PATBLOCK 1+ BLOCK R@ + ! UPDATE PATBLOCK BLOCK R> + ! UPDATE ; : SD ( - n ) DUP 1+ 2 * 1024 >
IF ." Block overrun" ABORT THEN 2 * >R CR R@ 2 / ." Patient number " CR R@ PATBLOCK BLOCK + @ ." Weight " CR R@ PATBLOCK 1+ BLOCK + @ ." Systolic pressure " CR R@ PATBLOCK 2 + BLOCK + @ ." Diastolic pressure " . CR;
Блок 110 [110 :0] ( Глава 10. Упражнения 5. 03 из 05 ) ( 4.) VARIABLE CNT : SUMBLOCK ( n -- d ) 0 CNT ! BLOCK 0 0 RОТ 512 0 DO DUP I 2 * + @ DUP IF 1 CNT +! ТНEN SWAP >R 0 D+ R>
LOOP DROP : ( 5. ) : AVE ( n1 - n2 ) SUMBLOCK CNT @ 0 D/ DROP ; ( 6. ) : AD ( n -- ) PATBLOCK BLOCK @ 2 * 2+ DUP 1+ 1024 >
IF ." Block overrun" ABORT ELSE PATBLOCK BLOCK DUP >R + ! 1 R> ! UPDATE THEN ;
Блок 111 [111 :0] ( Глава 10. Упражнения 5. 04 из 05 ) ( 7.) : DD ( n -- ) 2 * 2+ PATBLOCK BLOCK DUP >R OVER + DUP 2- ROT 1024 SWAP - CMOVE -1 R> +! UPDATE ; ( 8. ) : SB ( n - d ) BLOCK DUP >R 0 0 ROT R> @ 0 DO DUP I 2 * + 2+ @ SWAP >R 0 D+ R> LOOP DROP ; : AV ( n1 -- n2) DUP SB ROT BLOCK @ 0 D/ DROP ; ( 9.) : SBS ( n -- d ) BLOCK DUP >R 0 0 ROT R> @ 0 DO DUP I 2 * + 6 + @ SWAP >R 0 D+ R> LOOP DROP ; : AVS ( n1 -- n2 ) DUP SBS ROT BLOCK @ 0 D/ DROP ;
Блок 112 [112 :0] ( Глава 10. Упражнения 5. 05 из 05 ) ( 9 продолж. ) : ADS ( n -- ) PATBLOCK BLOCK @ 2 * 6 + DUP 1024 2/ >
IF ." Block overrun" ABORT ELSE PATBLOCK BLOCK DUP >R + ! 1 R@ +! PATBLOCK SBS R> 2+ 2! UPDATE THEN ; : DDS ( n -- ) 2 * 6 + PATBLOCK BLOCK DUP >R OVER + DUP 2- ROT 1024 SWAP - CMOVE -1 R> + PATBLOCK SBS PATBLOCK BLOCK 2+ 2! UPDATE ; ( 10. ) : CHKSUM ( n1 -- n2 ) BLOCK 0 1024 0 DO OVER I + @ + 2 +LOOP SWAP DROP ; : ?BLK= ( n1 n2 -- флаг ) CHKSUM SWAP CHKSUM = ;
Блок 113 [113 :0] ( Глава 10. Упражнения 6. 01 из 02 ) ( 1.) : BLOCKWORD ( n1 n2 n3 -- #addr ) BLK @ >R >IN @ >R ROT BLK ! SWAP >IN ! WORD DUP C@ PAD SWAP 1+ CMOVE PAD R> >IN ! R> BLK ! ; ( 2.) VARIABLE POSITION 0 POSITION ! : BWORD ( n1 n2 -- #addr ) BLK @ >R >IN @ >R SWAP BLK ! POSITION @ >IN ! WORD DUP C@ PAD SWAP 1+ CMOVE >IN @ POSITION ! R> >IN ! R> BLK I PAD ; ( 3. ) : BLOCKNUMBER ( n1 n2 - n3) BWORD NUMBER DROP ;
Блок 114 [114 :0] ( Глава 10. Упражнения 6. 02 из 02 ) ( 4. ) : TOBLOCK ( n1 n2 n3 -- ) >R OVER SWAP BLOCK POSITION @ + >R 1+ OVER C@ R> OVER OVER + >R SWAP CMOVE C@ 1+ POSITION +! R> 1+ R> SWAP 1- С! UPDATE ; ( изменение POSITION полезно, т.к. оно позволяет размещать слова в блоке последовательно с минимальными издержками контроля. )
Блок 115 [115 :0] ( Глава 10. Упражнения 7. 01 из 02 ) ( 1. ) , : DATA-AVE ( первый последний т - средн. ) ROT ROT 1+ SWAP >R >R >R 0 0 R> R> R> OVER OVER - >R DO DUP I METFILE DATALOC @ SWAP >R 0 D+ R>
LOOP .S DROP R> 0 D/ DROP ; ( 2. ) : TEMP-AVE ( первый последний -- средн. ) 1+ SWAP >R >R 0 0 R> R> OVER OVER - >R DO I TEMP @ 0 D+ LOOP R> 0 D/ DROP ; ( 3. ) : CORRECT-TEMP ( начало последний -- ) 1+ SWAP DO I TEMP @ SWAP +! LOOP ;
Блок 116 [116 :0] ( Глава 10. Упражнения 7. 02 из 02 ) ( 4. ) : PUTFILE ( адр-файла адр-данных -- ) DUP @ 1+ 1 DO OVER OVER SWAP I 1- 1024 * + SWAP I 2 * @ BLOCK 1024 CMOVE UPDATE LOOP ; ( 5. ) : SAVEREC ( n1 n2 n3 n4 rec# -- ) DEPTH 5 < IF ." Wrong number of argument" ABORT ELSE METFILE RECLOC >R R@ 6 + ! R@ 4 + ! R@ 2+ ! R> ! THEN ;
Блок 117 [117 :0] ( Глава 10. Упражнения 8. 01 из 02 ) ( 1. ) VARIABLE DELIMITER 32 DELIMITER ! : GETWORD ( адр n -- PAD ) TIB PAD 100 + 80 CMOVE BLK ( Сохранение содержимого буфера) @ >R >IN @ >R TIB 80 0 FILL ( восстановление позднее) + TIB 64 CMOVE 0 BLK ! 0 >IN ! DELIMITER @ WORD DUP С@ 1+ PAD SWAP CMOVE PAD PAD 100 + TIB 80 CMOVE R> >IN ! R> BLK ! ; ( 2.) VARIABLE POSITION 0 POSITION ! : FILEWORD ( адр -- PAD ) TIB PAD 100 + 80 CMOVE BLK @ >R >IN @ >R TIB 80 0 FILL POSITION @ + TIB 64 CMOVE 0 BLK ! 0 >IN ! DELIMITER @ WORD DUP C@ 1+ PAD SWAP CMOVE PAD DUP С@ 1+ POSITION +! PAD 100 + TIB 80 CMOVE R> >IN ! R> BLK ! ;
Блок 118 [118 :0] ( Глава 10. Упражнения 8. 02 из 02 ) ( 3.) : FILENUMBER ( адр - n ) FILEWORD NUMBER DROP ; ( 4.) : TOFILE ( адр1 адр2 -- ) DUP >R POSITION @ + SWAP DUP C@ DUP POSITION +! SWAP 1+ ROT ROT CMOVE DELIMITER @ POSITION @ R> + C! 1 POSITION +! ;
Блок 119 [119 :0] ( Глава 10. Упражнения 8. 01 из 01 ) ( 1.) : NEXTFIELD ( -- ) ADDFILE FILEWORD DROP ; ( 2.) : NEXTREC ( -- ) 4 0 DO NEXTFIELD LOOP ; ( 3.) : FINDPHONE ( -- ) PAD SEARCH$ $! 0 POSITION ! SEARCH-NAME 3 0 DO NEXTFIELD LOOP ADDFILE FILEWORD COUNT TYPE ; ( 4. ) : DELREC ( -- ) POSITION @ ADDFILE + NEXTREC POSITION @ DUP >R ADDFILE + SWAP FINDEOF POSITION @ 4 + R> - CMOVE ;
Блок 120 [120 :0] ( Глава 11. Упражнения 1. 01 из 02 ) : 2VARIABLE ( -- ) CREATE 0 , 0 , ; : 2VARIABLE ( n -- ) CREATE , , @ @ ; ( Последнее описание не является стандартным ) ( 2.) : #CONSTANT ( -- ) CREATE 34 ЦORD DUP C@ 1+ ALLOT ; ( Строка переносится по адресу HERE с помощью WORD и резервируется память для поля параметров производного слова. ) ( 3. ) : RESERVE ( n --) CREATE DUP HERE SWAP ALLOT SWAP 0 FILL ; ( 4.) : BLOCKARRAY ( n -- ) CREATE , 1024 ALLOT ;
Блок 121 [121 :0] ( Глава 11. Упражнения 1. 02 из 02 ) ( 5.) : GETBLOCK ( адр - ) DUP @ BLOCK SWAP 2+ 1024 CMOVE ; ( 2+ необходимо, чтобы обойти откомпилированный номер блока.) : PUTBLOCK ( адр --) DUP @ BLOCK SWAP 2+ SWAP 1024 CMOVE UPDATE ; ( 6.) : B@ ( n1 адр -- n2 ) SWAP 2 * + @ ; : В! ( n1 n2 адр -- ) SWAP 2 * + ! ;
Блок 122 [122 :0] ( Глава 11. Упражнения 2. 01 из 04 ) ( 1. ) : 2CONSTANT CREATE , , DOES> DUP @ SWAP 2+ @ SWAP ; ( 2. ) : MAKEDATE ( месяц день год -- ) CREATE , , , DOES> >R R@ @ 0 TYPE ; ( 3. ) : COUNTER ( n -- ) CREATE , DOES> 1 SWAP +! ; ( Получение значения счетчика командами ' COUNTIT @ в орт-79 иля ' COUNTIT >BODY @ в Форт-83. ) ( 4. ) ( Введите производное слово оператора COUNTER в описание слова; счетчик будет инкрементироваться при каждом обращении. Сброс счетчика должен проводится при каждом запуске программы. )
Блок 123 (123 :t]: ( Глава 11. Упражнения 2. 02 из 04 ) ( 5.) : %COLOR ( n -- ) 100 255 */ 3 .R ." % " ; ( Это слово упрощает следующие три слова. ) : CYAN ( n - ) %COLOR ." Cyan " ; : YELLOW ( n - ) %COLOR ." Yellow " ; : MAGENTA ( n - ) %COLOR ." Magenta " ; : COLOR ( n1 n2 n3 -- ) CREATE ROT , SWAP , , DOES> >R R@ @ CYAN R@ 2+ @ YELLOW R> 4 + @ MAGENTA ; ( CYAN.
YELLOW и MAGENTA компилируются в таком порядке, чтобы упростить возврат при исполнении производных слов. ) ( 6. ) : QUADRATIC ( а b с -- ) CREATE ROT , SWAP , , DOES> >R DUP DUP * R@ @ * SWAP R@ 2+ @ * + R> 4 + @ + ; ( Заметьте, что коэффициенты компилируются в порядке a-b-c. )
Блок 124 [124 :0] ( Глава 11. Упражнения 2. 03 из 04 ) ( 7. ) : M-MENTEM ( n1 n2 -- ) CREATE SWAP , , DOES> >R DUP R@ @ * SWAP R> 2+ @ + / ; ( Для получения большей точности можно применять масштабирование. ) ( 8. ) : ** ( n1 n2 - n3 ) ?DUP 0= IF DROP 1 ELSE DUP 1 = IF DROP ELSE OVER SWAP 1- 0 DO OVER * LOOP SWAP DROP THEN THEN ; ( Это слово было описано в главе 8 и используется для упрощения описания POLYNOM ) ( Продолжеиие в следующем блоке )
Блок 125 [125 :0] ( Глава 11. Упражнения 2. 04 из 04 ) ( 8. продолж. ) : POLYNOM ( n1 n2 ... - ) CREATE DEPTH DUP , 0 DO DEPTH ( 1- в Форт-83 ) ROLL , LOOP DOES> DUP @ SWAP 2+ SWAP >R >R >R 0 R> R> R> 0 DO OVER OVER I 2 * + @ SWAP I ** * SWAP >R SWAP >R + R>
R> LOOP DROP DROP ; ( Коэффициенты компилируются в указанном порядке. "0" заносится на дно стека, чтобы получить результат, который вычислен в цикле do-loop. ) ( 9. ) : ( min max n -- ) CREATE , SWAP , , DOES> >R R@ @ R@ 2+ @ MAX R@ 4 + @ MIN DUP R> ! ; ( Заметьте, что "значение" производного слова скомпили- ровано в первую позицию, позволяя использовать ' или ' >BODY . )
Блок 126 [126 :0] ( Глава 11. Упражнения 3, 01 из 02 ) : DARRAY ( n -- ) CREATE 4 * ALLOT ) DOES> SWAP 4 * + ; ( 2. ) : 1ARRAY ( n - ) CREATE 2 * ALLOT DOES> SWAP 1- 2 * + ; : 1EARRAY ( n -- ) CREATE DUP , 2 * ALLOT DOES> >R 1- DUP 0 < OVER R@ @ 1- > OR IF ." Index error" ABORT ELSE 2 * 2+ R> + THEN ; ( 3. ) : 0CARRAY ( n --) CREATE HERE SWAP DUP ALLOT 0 FILL DOES> + ; ; 0ARRAY ( n -- ) CREATE HERE SWAP 2 * DUP ALLOT 0 FILL DOES> SWAP 2 * + ;
Блок 127 [127 :0] ( Глава 11. Упражнения 3. 02 из 02 ) ( 4.) : PRESERVE ( n1 n2 - ) CREATE DEPTH 0 DO DEPTH ROLL , LOOP ; ( Используйте 1- ROLL в Форт-83) ( 5.) : SAVE-TO-RETURN ( n1 n2 -- ) CREATE DEPTH DUP , 0 DO DEPTH ROLL , LOOP ( Используйте 1- ROLL в Форт-83 ) DOES> DUP @ 0 DO DUP I 2 * 2+ + @ SWAP LOOP DROP ; ( 6. ) : WORD >IN @ >R CREATE R> >IN ! 32 WORD C@ 1+ ALLOT DOES> COUNT TYPE ; ( Занося >IN в стек возвратов, WORD может проводить раэбор слова дважды.
Первый раз формируется заголовок, где имя используется оператором CREATE. Второй раз это же имя пересылается в поле параметров слова. )
Блок 128 [128 :0] ( Глава 13. Упражнения 1. 01 из 02 ) ( 1. ) : TASK ; Позволяет удалить редактор из словаря при отладке. DECIMAL гарантирует, что никая другая система счисления не будет случайно использована. ) ( 2. ) ( Это позволяет при редактировании изменить сразу ряд блоков.) ( 3. ) Таким образом задержки могут быть легко изменены. ) ( 4. ) ( Чтобы позволить с помощью констант определить задержки и сделать програмиу более читаемой ) ( 5. ) : PAGE 27 EMIT 42 EMIT ; ( или 27 42 CONTROL PACE ) : ЗЕС ( ряд столбец -- ) 27 EMIT 61 EMIT SWAP 32 + EMIT 32 + EMIT ;
Блок 129 [129 :0] ( Глава 13. Упражнения 1. 02 из 02 ) ( 6. ) 27 13 CONTROL 27 14 CONTROL 27 15 CONTROL ( Чтобы использовать достаточно убрать скобки) ( 7. ) ( Использование терминальных возможностей, а не их имитации обеспечивает большее быстродействие, более приятную работу и требует меньшей по размеру программы. )
Блок 130 [130 :0] ( Глава 13. Упражнения 2. 01 из 01 ) ( 1. ) Слова в KEYVECTORS предполагаются отлаженными, KEYDO может быть отлажено путем загрузки и исполнения про- граммы через KEYDO. Если оно не работает, нужно ис- пользовать в KEYDO слова-подставки. Блок 10 может быть отлажен при испытании EDITCASE, и затем, в конце концов, редактора. Здесь слова, если надо, могут использоваться слова-подставки. ) ( 2.) : CONTROL-CHAR? ( с -- с f ) DUP 27 < OVER 0 > AND ; : PRINTABLE-CHAR? ( с -- с t) DUP 31 > OVER 127 < AND ; : INSERT-MODE? ( - f ) I/R @ ;
Блок 191 [191 :0] ( Глава 14. Упражнения 01 из 02 ) ( 1. ) ( будет отображено FF FF 00 FF FF 00 10 00 ) ( 2.) ( ЭВМ видает FF FF FF FF 00 00 FF FF 00 00 FF 00 00 10 00 ) ( 3. ) ( WORD производят обычно раэбор по адресу HERE, поэтому область памяти между HERE и следующей используемой зоной, обычно PAD, может использоваться для разбора данных, поступающих с клавиатуры. ) ( 4.) : С, ( с -- ) HERE С! 1 DP +! ; : , ( n - ) HERE ! 2 DP +! ; ( DP, которая хранит указатель словаря, зависит от реализации и может в вашем Форт быть другая. )
Блок 132 [132:0] ( Глава 14. Упражнения 1. 02 из 02 ) ( 5. ) : .MEM ( -- ) SP@ PAD - U. ; ( SP@ зависит от реализации. ) ( 6. ) : NEWPICK ( n1 -- n2) 2 * 'S + @ ; ( 2 * SP@ 2- + @ FORTH-83 ) ( 'S [и SP@] зависят от типа версии. 2- необходимо для описания в Форт-83. так как там индекс PICK начинается с 0) ( 7. ) : NEW.S ( -- ) 'S S0 @ OVER OVER = IF ." Stack empty" DROP DROP ELSE 2- DO I @ -2 +LOOP THEN ; ( 8. ) : ZERО-STACK ( -- ) SP@ S0 @ SP@ - 2- 0 FILL ;
Блок 133 [133 :0] ( Глава 14. Упражнения 2. 01 из 01 ) ( 1. ) : >BODY ( cfa -- pfa) 2+ ; : >NAME ( cfa -- nfa) 6 - ; : >LINK ( cfa -- Ifa) 2- ; : BODY> ( pfa -- cfa) 2 - ; : NAME> ( nfa -- cfa) 4 + ; : LINK> ( lfa -- cfa) 2+ ; : N>LINK ( nfa -- lfa) 4 - ; : L>NANE ( lfa -- nfa) 4 - ; ( Это работает только с версиями Форта, описанными в этой книге. ) ( 2, 3. ) ( Вы должны найти ответы на эти вопросы, используя версию Форта, которой располагаете. ) ( 3. ) : COLONWORDS ( адр1 адр2 -- ) CR 1+ SWAP DO I @ 2526 = ( или другой адрес исполнительной программы "двоеточие" ) IF 1 U. THEN LOOP ;
Блок 134 [134 :0] ( Глава 14. Упражнения 3. 01 из 02 ) ( 1. ) ( Форма использование WORDS, где имя контекстного словаря. Использование полей связи и указателей словарей также обычные слова перед исполнением.) ( ???) ( 2. ) FORTH VOCABULARY A-VOC A-VOC DEFINITIONS : A-FIRST ." The first A-VOC word " ; : A-SECOND ." The second A-VOC word " ; : A-THIRD ." The third A-VOC word " ; : A-LAST ." The last A-VOC word " ; ( 3. ) WORDS лишь выдает список слов в контекстном словаре) ( 4. ) ( Слово из A-VOC не может быть найдено в словаре FORTH )
Блок 135 [135 :0] ( Глава 14. Упрахиеняи 3. 02 из 02 ) ( 5.) A-VOC VOCABULARY B-VOC В-VOC DEFINITIONS : B-FIRST ." The first В-VOC word " ; : B-SECOND ." The second B-VOC word " ; : B-THIRD ." The third B-VOC word " ; : B-LAST ." The last В-VOC word " ; ( Если A-LAST может размещаться в B-VOC, тогда ваши словари связаны.
В противном случае каждый из них связан только с Фортом. ) ( 6. ) В-МЩС DEFINITIONS : A-LAST ." Another В-VOC definition " ; ( Выберите одно из двух описании A-VOC и В-VOC. )
Блок 136 [136 :0] ( Глава 14. Упрахиения 4. 01 из 03 ) ( 2. ) : HELP CONTEXT @ [COMPILE] HELPS FIND ?DUP IF [ FIND HELPS ] LITERAL OVER U< IF EXECUTE ELSE DROP ." not in HELP list" THEN ELSE ." not found. " THEN CONTEXT ! ;
Блок 137 [137 :0] ( Глава 14. Упрахкения 4. 02 из 03 ) ( 2. ) VOCABULARY HELPS HELPS DEFINITIONS BLK @ 2+ CONSTANT BASEBLK ( указание на первый блок) 32 CONSTANT #/BLK ( число статей в блоке ) 32 CONSTANT LENGTH ( длина статьи ) : HELPER ( n -- ) CREATE , ( Создает индекс статей HELP) DOES> DUP #/BLK / BASEBLK + BLOCK SWAP LENGTH * + LENGTH -TRAILING TYPE CR ; 0 HELPER DUP 1 HELPER DROP 2 HELPER SWAP 3 HELPER OVER 4 HELPER ROT 5 HELPER - 6 HELPER + 7 HELPER * 8 HELPER / --> ( Каждое из слов должно соответствовать статье в блоке данных. )
Блок 138 [138 :0] ( Глава 14. Упражнения 4. 03 из 03 В след. блоке данные) ( 2. продолж. ) FORTH DEFINITIONS : HELP [COMPILE] HELPS FIND ?DUP IF [ FIND HELPS ] LITERAL OVER U< IF EXECUTE ELSE DROP ."Not in HELP list." THEN ELSE ." not found" THEN [COMPILE] FORTH ; ( Используйте ['] HELPS вместо [ FIND HELPS ] LITERAL в Форт-83. [COMPILE] необходимо только в Форт, где контекстные словари являются словами немедленного исполнения. ) ( Используйте редактор для запоминания описаний; следующий блок может служить примером. Эта версия HELP воспримет описания из любого числа блоков начиная с BASEBLK. )
Блок 139 [139 :0]
= stack ( n -- n n ) = stack ( n1 n2 -- n1 ) = stack ( n1 n2 -- n2 n1 ) = stack ( n1 n2 -- n1 n2 n1 ) = stack ( n1 n2 n3 -- n2 n3 n1 ) = substract ( n1 n2 -- n3 ) = add ( n1 n2 -- n3 ) = multiply ( n1 n2 -- n3 ) = divide ( n1 n2 -- n3 )
Блок 140 [140 :0]
( Глава 15. Упражнения 1. 01 из 02 ) ( 1.) : ?COMPILE ( CFA -- ) STATE @ IF , ELSE EXECUTE THEN ; ( 2. ) : 83COMPILE ( cfa f --) DUP 1 = IF DROP EXECUTE EXIT THEN STATE @ AND 0= IF EXECUTE ELSE , THEN ; ( В Форт-83 FIND производит поиск в словаре до компиляции или исполнения, т.е.
во время интерпретации. ) ( 3. ) : N' ( --cfa ) 32 WORD FIND 0= IF DROP ." Word net found " ABORT THEN ; ( 4.) : ?COMPILE ( cfa --) STATE @ IF DUP . , ELSE EXECUTE THEN ; ( 5.) ( >IN указывает на точку в тексте. откуда продолжается интерпретация после того, как слово найдено)
Блок 141 [141 :0] ( Глава 15. Упражнения 1. 02 из 02 ) ( 6.) Сброс указателя входного потока вызывает зацикливание) ( 7.) ( Цикл будет продолжаться, так как таковы условия во входном потоке ) ( 8. ) ( Будет отображено только 5, так как 0 во входном потоке остановит интерпретацию. )
Блок 142 [142 :0] ( Глава 15. Упражнения 2. 01 из 02 ) ( 2. ) Исполнительная программа "двоеточие" является одной и той же для всех слов типа двоеточие. Т.о. поле ) ( 3.) ( программы BASE? будет тем же самым. ) ( Используя FIND [ или ' ] в DUMP, вы мохете увидеть, что поля параметров содержат CFA слов описания. Вам следует уметь отслеживать исполнение.) ( 4. ) ( Если содержимое LF в 2DUMMY указывает на 1DUMMY, замените его содержимое так, чтобы оно указывало на то, на что указывает LF слова 1DUMMY. ) ( 5. ) ( Измените CFA в PFA слова 3DUMMY на CFA слова 1DUMMY. Чтобы 3DUMMY ничего не делало, занесите CFA слова EXIT в первую позицию поля параметров 3DUMMY. )
Блок 143 [143 :0] ( Глава 15. Упражнения 2. 02 из 02 ) ( 6. ) ( Выполним эксперимент и поменяем содержимое первой позиции в поле параметров на значение CFA слова, выполнение которого желательно. )
Блок 144 [144 :0l ( Глава 15. Упражнения 3. 01 из 02 ) ( 1.) : .LOC1 ( --) BLK @ . >IN @ . ; IMMEDIATE : .LOC2 ( --) BLK @ . >IN @ 64 / . ; IMMEDIATE ( 2. ) ( Помещаем это между [ и ] . ) ( 3. ) ( Помещаем это между [ ] или описываем ) : .SI .S ; IMMEDIATE ( 4. ) ( Вы выйдете из состояния компиляции и ; приведет к ошибке. ) ( 5. ) ( Да. [COMPILE] может компилировать обычные слова, но это избыточно. ) ( 6. ) ( Вы можете обнаружить в стеке 239, или ваш Форт контролирует при интерпретации ошибки и выдает сообщение об ошибке.)
Блок 145 [145 :0] ( Глава 15.
Упражнения 3. 02 из 02 ) ( 7. ) CREATE OPERATOR ] + - * / [ : MATH ( n1 n2 n3 - ) 1- 2 * OPERATOR + @ EXECUTE ; ( Понятно, что использование [ и ] является более простым способом формирования исполнительных векторов, чем применение FIND или ' .)
Блок 146 [146 :0] ( Глава 15. Упражнения 4. 01 из 01 ) ( 1. ) START-ЦHERE? BLK @ [COMPILE] LITERAL ; IMMEDIATE ( 2. ) : GET/# ( n -- ) PAD DUP 8 EXPECT 1- NUMBER DROP ; : ?RATE ." current rate? " GET# ; IMMEDIATE ( 3. ) : CONVERTS ( n -- ) ?RATE LITERAL 100 */ ; ( 4. ) : ENGLAND [ CR ." Dollars to pounds " ] ?RATE LITERAL 100 */ ; : DENMARK [ CR ." Dollars to kroners " ] ?RATE LITERAL 100 */ ; : GERMANY [ CR ." Dollars tо marks " ] ?RATE LITERAL 100 */ ; ( 6. ) : ?COMP ( -- ) STATE @ 0= IF ." Compile only! " ABORT THEN ; ( 7. ) ( TEST1 выполнит DUP . Выполнение TEST с клавиатуры даст ошибку, так как COMPILE содержат ?COMP . )
Блок 147 [147 :0] ( Глава 15. Упражнения 5. 01 из 03 ) ( 1.) ( Ячейка, предшествующая той, в которой записано чис- ло 3, содержит CFA слова LIT. Первая ячейка в поле параметров будет содержать CFA слова ЁBRANCH. Сразу вслед за ним следует число, абсолютный или относи- тельный адрес слова. Это позволит вам понять, как работает ЁBRANCH [с абсолютными или относительными CFA адресами]. После адреса следует CFA слова, ко- торое заносит в стек 1 и за которым следует CFA слова BRANCH. За числом 3 следует CFA слова EXIT.
Блок 148 [148 :0] ( Глава 15. Упражнения 5. 02 из 03 ) ( 2. ) : .CMP CR ." Here =" HERE U. ." Stack = " .S ; IMMEDIATE ( 3. ) HEX : LOOK-AT-lF ( f --) .CMP IF 1 .CМР ELSE 2 .CМР THEN .СМР 3 ; DECIMAL ( HERE увеличивается по мере компиляции ?BRANCH, LIT, адресов и чисел. Стек содержит число, которое зане сено туда оператором : ( и которое проверяется и удаляется оператором ; с целью проверки сохранности состояния стека]. За этим числом следует абсолютные или относительные адреса передачи управления, ис- пользуемые операторами ELSE и THEN.) ( 4. ) ( TEST выдаст на дисплей 5, так как LIT и 5 были скомпилированы в поле параметров с помощью [ 174 , 5 . ].)
Блок 149 [149 :0] ( Глава 15. Упражнения 5. 03 из 03 ) ( 5. ) ( Ниже предполагается, что 3301 равно CFA слова LIT. ) : NEWLITERAL ?СОМР 3301 , , ; IMMEDIATE : NEWDLITERAL ?COMP SWAP 3301 , , 3301 , , ; IMMEDIATE ( 6. ) ( Ниже предполагается, что 3265 равно CFA слова ?BRANCH и что 3257 равно CFA слова BRANCH. : NEWIF ?СОMР 3265 , HERE 0 , ; IMMEDIATE : NEWELSE ?COMP 3257 , HERE 0 , HERE ROT ! ; IMMEDIATE
Блок 150 [150 :0] ( Глава 15. Упражнения 6. 01 из 02 ) ( 1. ) : TASK ; FIND TASK @ CONSTANT COLON-ADDR ( ' TASK @ в 83 ) COLON-ADDR >R HERE R@ , ] ." Word#0 " EXIT [ CONSTANT 0WORD HERE R> , ] ." Word#1 " EXIT [ CONSTANT 1WORD ( 2. ) : ANYWORD [ 0WORD , 1WORD , ] ; ( 3. ) : MAKEWORD CREATE 1WORD , 0WORD , DOES> SWAP 2 * + @ EXECUTE ; ( 4. ) : GIVE-NAME CREATE , DOES> @ EXECUTE ; ( 5. ) COLON-ADDR HERE SWAP , ] ." Word#2 " EXIT [ : 2WORD [ SWAP , ] ; ( если в стеке хранится число, засланное оператором : . )
Блок 151 [151 :0] ( Глава 15. Упражнения 6. 02 из 02 ) ( 6. ) ( Опишите) : ?BR 3265 , ; : BR 3257 , ; ( или другие адреса ) ( Используется вместо COMPILE ?BRANCH и COMPILE BRANCH в описании IF и ELSE . ) ( 7. ) ( Опишите следующее ниже и используйте вместо COMPILE LIT в описании LITERAL . ) : LT 3301 , ; ( Или другой соответствующий адрес.)
Блок 152 [152 :0] ( Глава 15. Упражнения 7. 01 из 02 ) ( 1. ) ( Адреса являются ячейками в поле параметров, где запоминаются очередные CFA. подлежащие исполнению. ) ( 2. ) ( Осуществляется переход к завершению 3LEVEL. ) ( 3. ) ( Использование R> DROP в 3LEVEL удалит адрес, который определяет куда будет передано управление после выполнения слова, что вызовет сбой в работе внутреннего интерпретатора и разрушение системы. ) ( 4. ) ( WP можно использовать для получения значения константы) ( 5.) ( В обоих случаях EXIT передает управление в точку, откуда было осуществлено обращение к слову. )
Блок 153 [ 153 :0] ( Глава 15. Упражнения 7. 02 из 02 ) ( 6. ) ( LIT увеличивает число в стеке возвратов и ( удаляет из стека откомпилированное число.
Выполнение программы ." делает то же самое для скомпилированных строк. )
Блок 154 [154 :0] ( Глава 15. Упражнения 8. 01 из 01 ) ( 1. ) : FACTORIAL ( n -- ) 1 SWAP 1+ 2 DO I * LOOP ; ( 2. ) : SHOWASCII ( n1 n2 -- ) 1+ SWAP DO I 3 .R I SPACE EMIT 3 SPACES LOOP ; : SHOWASCII ( n1 n2 -- ) SWAP DUP DUP 3 .R SPACE EMIT 3 SPACES 1+ SWAP OVER OVER UNTIL DROP ; : RGENERATIONS ( 0 1 -- n ) SWAP 1+ SWAP DUP + DUP 2000 < IF MYSELF ELSE DROP THEN ;
Блок 155 [155 :0] ( Глава 16. Упражнения 1. 01 из 03 ) ( 1. ) ( Z80 DROP E1 NEXT POP HL NEXT 8088 DROP 5B NEXT POP BX NEXT Z80 DUP E1 E5 E5 NEXT POP HL PUSH HL PUSH HL NEXT 8088 DUP 5B 53 53 NEXT POP BX PUSH BX PUSH BX NEXT Z80 OVER E1 D1 D5 E5 D5 NEXT POP HL POP DE PUSH DE PUSH HL PUSH DE NEXT 8088 OVER 5B 5A 52 53 52 NEXT POP BX POP DX PUSH DX PUSH BX PUSH DX NEXT
Блок 156 [156 :0] ( Глава 16. Упражнения 1. 02 из 03 ) ( 2. ) ( HEX ASSEMBLER ) ( Z80 CREATE TUCK HERE DUP 2- ! E1 C, D1 C, E5 C, D5 С, E5 С, NEXT 8088 CREATE TUCK HERE DUP 2- ! 5В С, 5A C, 53 С, 52 С, 53 C, NEXT ( 3. ) ( Z80 CREATE NIP HERE DUP 2- ! E1 C, D1 C, D5 C, NEXT 8088 CREATE NIP HERE DUP 2- ! 5В С, 5A С, 53 С, NEXT ) ( 4. ) DECIMAL ( ROT = POP HL POP DE EX [SP],HL PUSH DE PUSH HL NEXT SWAP = POP HL EX [SP],HL PUSH HL NEXT
Блок 157 [157 :0] ( Глава 16. Упражнения 1. 03 из 03 ) ( 5. ) ( -ROT = POP HL POP DE EX (SP),HL PUSH HL PUSH DE NEXT -ROT = POP AX POP BX POP CX PUSH BX PUSH CX PUSH AX NEXT ) ( 6.) ( Приращение указателя стека осуществлятся командой INC SР или эквивалентной.)
Блок 158 [158 :0] ( Глава 16. Упражнения 2. 01 из 04 ) ( 1. ) ( Z80 ) CODE DUP HL POP HL PUSH HL PUSH NEXT END-CODE CODE OVER HL POP DE POP DE PUSH HL PUSH DE PUSH NEXT END-CODE CODE ROT DE POP HL POP E3 C, ( HL SP EX ) DE PUSH HL PUSH NEXT END-CODE CODE 2DUP HL POP DE POP DE PUSH HL PUSH DE PUSH HL PUSH NEXT END-CODE CODE TUCK HL POP DE POP HL PUSH DE PUSH HL PUSH NEXT END-CODE CODE NIP HL POP DE POP HL PUSH NEXT END-CODE CODE -ROT HL POP DE POP E3 C, ( HL SP EX ) DE PUSH HL PUSH NEXT END-CODE
Блок 159 [159 :0] ( Глава 16. Упражнения 2. 02 из 04 ) ( 1. продолж. ) ( 8088 ) CODE DUP BX POP BX PUSH BX PUSH NEXT END-CODE CODE OVER BX POP CX POP BX PUSH CX PUSH BX PUSH NEXT END-CODE CODE ROT BX POP CX POP DX POP CX PUSH DX PUSH BX PUSH NEXT END-CODE CODE 2DUP BX POP CX POP BX PUSH CX PUSH BX PUSH CX PUSH NEXT END-CODE CODE NIP BX POP CX POP BX PUSH NEXT END-CODE CODE TUCK BX POP CX POP BX PUSH CX PUSH BX PUSH NEXT END-CODE CODE -ROT BX POP CX POP DX POP BX PUSH CX PUSH DX PUSH NEXT END-CODE
Блок 160 [160 :0] ( Глава 16. Упражнения 2. 03 из 04 ) ( 2. ) ASSEMBLER DEFINITIONS : PSH AX PUSH NEXT END-CODE ; ( 3. ) ASSEMBLER DEFINITIONS : PSH3 BX PUSH DX PUSH AX PUSH NEXT END-CODE ; ( 4. ) ASSEMBLER DEFINITIONS : ;C NEXT END-CODE ; ( 5. ) FORTH DEFINITIONS CODE @REGS DI PUSH SI PUSH SP PUSH DX PUSH CX PUSH BX PUSH AX PUSH NEXT END-CODE : .REGS @REGS 7 0 DO 8 .R LOOP ; ( 6. ) CODE - DX POP AX POP DX AX SUB AX PUSH NEXT END-CODE
Блок 161 [161 :0] ( Глава 11. Упражнения 2. 04 из 04 ) ( 7а. ) : ARRAY CREATE 1+ 2* ALLOT ;CODE AX POP AX AX ADD BX AX ADD 2 # AX ADD AX PUSH NEXT END-CODE ( 7b. ) : DARRAY CREATE 1+ 4 * ALLOT ;CODE AX POP AX AX ADD AX AX ADD BX AX ADD 2 # AX ADD AX PUSH NEXT END-CODE ( 7c. ) ( Это требует лишь 1/3 времени от того. что нужно опнсаниям. в которых использовано DOES> ) : CONSTANT CREATE , ;CODE 2 # BX ADD [BX] PUSH NEXT END-CODE ( 7d. ) : 2CONSTANT CREATE , , ;CODE 4 # BX ADD [BX] PUSH 2 # BX SUB [BX] PUSH NEXT END-CODE ( Эти описания предполагают, что при обращении BX содержит CFA слова и что PFA отстоит от CFA на два байта. Это соответствует требованиям MMSFORTH. )
Блок 162 [162 :0] ( Глава 16. Упражнения 3. 01 из 01 ) ( 1. ) ASSEMBLER DEFINITIONS 0 CONSTANT ВС 2 CONSTANT DE 4 CONSTANT HL 6 CONSTANT AF : 1Z80ARG ( n -- ) CREATE , DOES> @ SWAP 8 * + С, ; 193 1Z80ARG (POP) 187 1Z80ARG (PUSH) FORTH DEFINITIONS ( 2. ) CODE IF=DROP AX POP BX POP AX BX CMP ~ Z IF BX PUSH AX PUSH THEN NEXT END-CODE ( 3. ) ( Следующее слово почти в 3 раза быстрее, чем 2 * .) CODE 2* AX POP AX AX ADD AX PUSH NEXT END-CODE ( 4. ) CODE 10* 0 # BX MOV 0 # CX MOV AX POP 10 # DX MOV BEGIN BX INC DX CX ADD AX BX CMP Z UNTIL CX PUSH NEXT END-CODE
Блок 163 [163 :0] ( Глава 16. Упражнения 4. 01 из 01 ) ( 1. ) LABEL SAVESTACK [ неиспольз. peг.] POP AX PUSH BX PUSH CX PUSH DX PUSH [тот же регистр] PUSH RET END-CODE ( Применяйте неиспользуемый регистр в вашем Форте для хранения адреса возврата, который заносится в стек при обращении к SAVESTACK) ( 2. ) CODE PLOTEMIT ( n1 n2 -- ) DX POP CX POP FF00 CALL NEXT END-CODE ( 3. ) CODE GETDATA ( n1 -- n2 ) AX POP FF00 CALL AX PUSH NEXT END-CODE ( 4. ) CODE CETDATA ( n1 -- n2 ) AX POP BX PUSH SI PUSH FF00 CALL SI POP BX POP AX PUSH NEXT END-CODE
