Details | Last modification | View Log | RSS feed
| Rev | Author | Line No. | Line |
|---|---|---|---|
| 4867 | leency | 1 | ( Трансляция исходных текстов программ. |
| 2 | ОС-независимые определения. |
||
| 3 | Copyright [C] 1992-1999 A.Cherezov ac@forth.org |
||
| 4 | Преобразование из 16-разрядного в 32-разрядный код - 1995-96гг |
||
| 5 | Ревизия - сентябрь 1999 |
||
| 6 | ) |
||
| 7 | |||
| 8 | VECT OK. |
||
| 9 | VECT |
||
| 10 | VECT ?LITERAL |
||
| 11 | VECT ?SLITERAL |
||
| 12 | USER-VALUE SOURCE-ID-XT \ если не равен нулю, то содержит заполняющее |
||
| 13 | |||
| 14 | : DEPTH ( -- +n ) \ 94 |
||
| 15 | \ +n - число одинарных ячеек, находящихся на стеке данных перед |
||
| 16 | \ тем как туда было помещено +n. |
||
| 17 | SP@ S0 @ - NEGATE 4 U/ |
||
| 18 | ; |
||
| 19 | : ?STACK ( -> ) \ выдать ошибку "исчерпание стека", если он более чем пуст |
||
| 20 | SP@ S0 @ SWAP U< IF S0 @ SP! -4 THROW THEN |
||
| 21 | ; |
||
| 22 | : ?COMP ( -> ) |
||
| 23 | STATE @ 0= IF -312 THROW THEN ( Только для режима компиляции ) |
||
| 24 | ; |
||
| 25 | |||
| 26 | : WORD ( char " |
||
| 27 | \ Пропустить ведущие разделители. Выбрать символы, ограниченные |
||
| 28 | \ разделителем char. |
||
| 29 | \ Исключительная ситуация возникает, если длина извлеченной строки |
||
| 30 | \ больше максимальной длины строки со счетчиком. |
||
| 31 | \ c-addr - адрес переменной области, содержащей извлеченное слово |
||
| 32 | \ в виде строки со счетчиком. |
||
| 33 | \ Если разбираемая область пуста или содержит только разделители, |
||
| 34 | \ результирующая строка имеет нулевую длину. |
||
| 35 | \ В конец строки помещается пробел, не включаемый в длину строки. |
||
| 36 | \ Программа может изменять символы в строке. |
||
| 37 | DUP PSKIP PARSE |
||
| 38 | DUP HERE C! HERE 1+ SWAP CMOVE |
||
| 39 | BL HERE COUNT + ! |
||
| 40 | HERE |
||
| 41 | ; |
||
| 42 | 1 [IF] |
||
| 43 | : ' ( " |
||
| 44 | \ Пропустить ведущие пробелы. Выделить name, ограниченное пробелом. Найти name |
||
| 45 | \ и вернуть xt, выполнимый токен для name. Неопределенная ситуация возникает, |
||
| 46 | \ если name не найдено. |
||
| 47 | \ Во время интерпретации ' name EXECUTE равносильно name. |
||
| 48 | PARSE-WORD SFIND 0= |
||
| 49 | IF -321 THROW THEN ( -? ) |
||
| 50 | ; |
||
| 51 | |||
| 52 | [THEN] |
||
| 53 | |||
| 54 | : CHAR ( " |
||
| 55 | \ Пропустить ведущие разделители. Выделить имя, органиченное пробелами. |
||
| 56 | \ Положить код его первого символа на стек. |
||
| 57 | PARSE-WORD DROP C@ ; |
||
| 58 | |||
| 59 | CREATE ILAST-WORD 0 , 0 , |
||
| 60 | |||
| 61 | : INTERPRET_ ( -> ) \ интерпретировать входной поток |
||
| 62 | SAVEERR? ON |
||
| 63 | BEGIN |
||
| 64 | PARSE-WORD DUP |
||
| 65 | WHILE 2DUP ILAST-WORD 2! |
||
| 66 | \ ." <" TYPE ." >" |
||
| 67 | SFIND ?DUP |
||
| 68 | IF |
||
| 69 | STATE @ = |
||
| 70 | IF COMPILE, ELSE EXECUTE THEN |
||
| 71 | ELSE |
||
| 72 | S" NOTFOUND" SFIND |
||
| 73 | IF EXECUTE |
||
| 74 | ELSE 2DROP ?SLITERAL THEN |
||
| 75 | \ ?SLITERAL |
||
| 76 | THEN |
||
| 77 | ?STACK |
||
| 78 | REPEAT 2DROP |
||
| 79 | ; |
||
| 80 | |||
| 81 | VARIABLE &INTERPRET |
||
| 82 | ' INTERPRET_ &INTERPRET ! |
||
| 83 | |||
| 84 | : INTERPRET &INTERPRET @ EXECUTE ; |
||
| 85 | |||
| 86 | \ : HALT ( ERRNUM -> ) \ выход с кодом ошибки |
||
| 87 | \ >R exit ; |
||
| 88 | |||
| 89 | : .SN ( n --) |
||
| 90 | \ Распечатать n верхних элементов стека |
||
| 91 | >R BEGIN |
||
| 92 | R@ |
||
| 93 | WHILE |
||
| 94 | SP@ R@ 1- CELLS + @ DUP 0< |
||
| 95 | IF DUP U>D <# #S #> TYPE |
||
| 96 | ." (" ABS 0 <# #S [CHAR] - HOLD #> TYPE ." ) " ELSE . THEN |
||
| 97 | R> 1- >R |
||
| 98 | REPEAT RDROP |
||
| 99 | ; |
||
| 100 | |||
| 101 | : OK1 |
||
| 102 | STATE @ 0= |
||
| 103 | IF ." Ok" DEPTH 70 UMIN |
||
| 104 | |||
| 105 | THEN |
||
| 106 | ; |
||
| 107 | |||
| 108 | : EVAL-WORD ( a u -- ) |
||
| 109 | \ интерпретировать ( транслировать) слово с именем a u |
||
| 110 | SFIND ?DUP IF |
||
| 111 | STATE @ = IF |
||
| 112 | COMPILE, ELSE |
||
| 113 | EXECUTE THEN |
||
| 114 | ELSE |
||
| 115 | -2003 THROW THEN |
||
| 116 | ; |
||
| 117 | |||
| 118 | : [ \ 94 CORE |
||
| 119 | \ Интерпретация: семантика неопределена. |
||
| 120 | \ Компиляция: Выполнить семантику выполнения, данную ниже. |
||
| 121 | \ Выполнение: ( -- ) |
||
| 122 | \ Установить состояние интерпретации. [ слово немедленного выполнения. |
||
| 123 | STATE 0! |
||
| 124 | ; IMMEDIATE |
||
| 125 | |||
| 126 | : ] ( -- ) \ 94 CORE |
||
| 127 | \ Установить состояние компиляции. |
||
| 128 | TRUE STATE ! |
||
| 129 | ; |
||
| 130 | |||
| 131 | : QUIT ( -- ) ( R: i*x ) \ CORE 94 |
||
| 132 | \ Сбросить стек возвратов, записать ноль в SOURCE-ID. |
||
| 133 | \ Установить стандартный входной поток и состояние интерпретации. |
||
| 134 | \ Не выводить сообщений. Повторять следующее: |
||
| 135 | \ - Принять строку из входного потока во входной буфер, обнулить >IN |
||
| 136 | \ и интепретировать. |
||
| 137 | \ - Вывести зависящее от реализации системное приглашение, если |
||
| 138 | \ система находится в состоянии интерпретации, все процессы завершены, |
||
| 139 | \ и нет неоднозначных ситуаций. |
||
| 140 | |||
| 141 | \ R0 @ RP! ( не делаем этого, чтобы позволить "['] QUIT CATCH" ) |
||
| 142 | CONSOLE-HANDLES |
||
| 143 | |||
| 144 | [COMPILE] [ |
||
| 145 | |||
| 146 | ; |
||
| 147 | |||
| 148 | : MAIN1 ( -- ) |
||
| 149 | BEGIN REFILL |
||
| 150 | WHILE INTERPRET OK. |
||
| 151 | REPEAT _BYE |
||
| 152 | ; |
||
| 153 | ' MAIN1 TO |
||
| 154 | |||
| 155 | : SAVE-SOURCE ( -- i*x i ) |
||
| 156 | SOURCE-ID-XT SOURCE-ID >IN @ SOURCE CURSTR @ 6 |
||
| 157 | ; |
||
| 158 | |||
| 159 | : RESTORE-SOURCE ( i*x i -- ) |
||
| 160 | 6 <> IF ABORT THEN |
||
| 161 | CURSTR ! SOURCE! >IN ! TO SOURCE-ID TO SOURCE-ID-XT |
||
| 162 | ; |
||
| 163 | |||
| 164 | : EVALUATE-WITH ( ( i*x c-addr u xt -- j*x ) |
||
| 165 | \ Считая c-addr u входным потоком, вычислить её интерпретатором xt. |
||
| 166 | SAVE-SOURCE N>R |
||
| 167 | >R SOURCE! -1 TO SOURCE-ID |
||
| 168 | R> ( ['] INTERPRET) CATCH |
||
| 169 | NR> RESTORE-SOURCE |
||
| 170 | THROW |
||
| 171 | ; |
||
| 172 | |||
| 173 | : EVALUATE ( i*x c-addr u -- j*x ) \ 94 |
||
| 174 | \ Сохраняет текущие спецификации входного потока. |
||
| 175 | \ Записывает -1 в SOURCE-ID. Делает строку, заданную c-addr u, |
||
| 176 | \ входным потоком и входным буфером, устанавливает >IN в 0 |
||
| 177 | \ и интерпретирует. Когда строка разобрана до конца - восстанавливает |
||
| 178 | \ спецификации предыдущего входного потока. |
||
| 179 | \ Другие изменения стека определяются выполняемыми по EVALUATE словами. |
||
| 180 | ['] INTERPRET EVALUATE-WITH |
||
| 181 | ; |
||
| 182 | |||
| 183 | : FQUIT |
||
| 184 | BEGIN REFILL |
||
| 185 | WHILE INTERPRET |
||
| 186 | REPEAT ; |
||
| 187 | |||
| 188 | : INCLUDE-FILE ( i*x fileid -- j*x ) \ 94 FILE |
||
| 189 | >IN @ >R |
||
| 190 | SOURCE-ID >R TO SOURCE-ID |
||
| 191 | RP@ #TIB @ ALIGNED - RP! |
||
| 192 | TIB RP@ #TIB @ CMOVE |
||
| 193 | SOURCE 2>R |
||
| 194 | \ TCR ." IF" |
||
| 195 | ['] FQUIT CATCH SAVEERR |
||
| 196 | \ ['] NOOP CATCH SAVEERR |
||
| 197 | |||
| 198 | 2R> SOURCE! |
||
| 199 | RP@ TIB #TIB @ CMOVE |
||
| 200 | RP@ #TIB @ ALIGNED + RP! |
||
| 201 | R> TO SOURCE-ID |
||
| 202 | R> >IN ! THROW ; |
||
| 203 | |||
| 204 | : INCLUDED_ ( c-addr u ---- ) |
||
| 205 | \ Open the file with name c-addr u and interpret all lines contained in it. |
||
| 206 | R/O OPEN-FILE THROW \ ABORT" Can't open include file" |
||
| 207 | DUP >R |
||
| 208 | ['] INCLUDE-FILE CATCH |
||
| 209 | R> CLOSE-FILE DROP THROW |
||
| 210 | ; |
||
| 211 | |||
| 212 | : REQUIRED ( waddr wu laddr lu -- ) |
||
| 213 | 2SWAP SFIND |
||
| 214 | IF DROP 2DROP |
||
| 215 | ELSE 2DROP INCLUDED_ THEN |
||
| 216 | ; |
||
| 217 | : REQUIRE ( "word" "libpath" -- ) |
||
| 218 | PARSE-NAME PARSE-NAME 2DUP + 0 SWAP C! |
||
| 219 | REQUIRED |
||
| 220 | ; |
||
| 221 | |||
| 222 | : AUTOEXEC S" /sys/INIT.F" INCLUDED_ ; |