Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ SEE.FS highend SEE for ANSforth 16may93jaw |
| 2 : | |||
| 3 : | anton | 1.9 | \ Copyright (C) 1995 Free Software Foundation, Inc. |
| 4 : | |||
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | \ as published by the Free Software Foundation; either version 2 | ||
| 10 : | \ of the License, or (at your option) any later version. | ||
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | \ along with this program; if not, write to the Free Software | ||
| 19 : | \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 20 : | |||
| 21 : | |||
| 22 : | anton | 1.1 | \ May be cross-compiled |
| 23 : | |||
| 24 : | \ I'm sorry. This is really not "forthy" enough. | ||
| 25 : | |||
| 26 : | \ Ideas: Level should be a stack | ||
| 27 : | |||
| 28 : | anton | 1.10 | require termsize.fs |
| 29 : | |||
| 30 : | anton | 1.1 | decimal |
| 31 : | |||
| 32 : | \ Screen format words 16may93jaw | ||
| 33 : | |||
| 34 : | VARIABLE C-Output 1 C-Output ! | ||
| 35 : | VARIABLE C-Formated 1 C-Formated ! | ||
| 36 : | VARIABLE C-Highlight 0 C-Highlight ! | ||
| 37 : | VARIABLE C-Clearline 0 C-Clearline ! | ||
| 38 : | |||
| 39 : | VARIABLE XPos | ||
| 40 : | VARIABLE YPos | ||
| 41 : | VARIABLE Level | ||
| 42 : | |||
| 43 : | : Format C-Formated @ C-Output @ and | ||
| 44 : | IF dup spaces XPos +! ELSE drop THEN ; | ||
| 45 : | |||
| 46 : | : level+ 7 Level +! | ||
| 47 : | Level @ XPos @ - | ||
| 48 : | dup 0> IF Format ELSE drop THEN ; | ||
| 49 : | |||
| 50 : | : level- -7 Level +! ; | ||
| 51 : | |||
| 52 : | VARIABLE nlflag | ||
| 53 : | |||
| 54 : | DEFER nlcount ' noop IS nlcount | ||
| 55 : | |||
| 56 : | : nl nlflag on ; | ||
| 57 : | : (nl) nlcount | ||
| 58 : | XPos @ Level @ = ?Exit | ||
| 59 : | C-Formated @ IF | ||
| 60 : | C-Output @ | ||
| 61 : | anton | 1.10 | IF C-Clearline @ IF cols XPos @ - spaces |
| 62 : | anton | 1.1 | ELSE cr THEN |
| 63 : | 1 YPos +! 0 XPos ! | ||
| 64 : | Level @ spaces | ||
| 65 : | THEN Level @ XPos ! THEN ; | ||
| 66 : | |||
| 67 : | : warp? ( len -- len ) | ||
| 68 : | nlflag @ IF (nl) nlflag off THEN | ||
| 69 : | anton | 1.10 | XPos @ over + cols u>= IF (nl) THEN ; |
| 70 : | anton | 1.1 | |
| 71 : | : ctype ( adr len -- ) | ||
| 72 : | warp? dup XPos +! C-Output @ IF type ELSE 2drop THEN ; | ||
| 73 : | |||
| 74 : | : cemit 1 warp? | ||
| 75 : | over bl = Level @ XPos @ = and | ||
| 76 : | IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN | ||
| 77 : | THEN ; | ||
| 78 : | |||
| 79 : | DEFER .string | ||
| 80 : | |||
| 81 : | [IFDEF] Green | ||
| 82 : | VARIABLE Colors Colors on | ||
| 83 : | |||
| 84 : | : (.string) ( c-addr u n -- ) | ||
| 85 : | over warp? drop | ||
| 86 : | Colors @ | ||
| 87 : | IF C-Highlight @ ?dup | ||
| 88 : | IF CT@ swap CT@ or | ||
| 89 : | ELSE CT@ | ||
| 90 : | THEN | ||
| 91 : | attr! ELSE drop THEN | ||
| 92 : | ctype ct @ attr! ; | ||
| 93 : | [ELSE] | ||
| 94 : | : (.string) ( c-addr u n -- ) | ||
| 95 : | drop ctype ; | ||
| 96 : | [THEN] | ||
| 97 : | |||
| 98 : | ' (.string) IS .string | ||
| 99 : | |||
| 100 : | |||
| 101 : | : .struc Str# .string ; | ||
| 102 : | |||
| 103 : | \ CODES 15may93jaw | ||
| 104 : | |||
| 105 : | 21 CONSTANT RepeatCode | ||
| 106 : | 22 CONSTANT AgainCode | ||
| 107 : | 23 CONSTANT UntilCode | ||
| 108 : | \ 09 CONSTANT WhileCode | ||
| 109 : | 10 CONSTANT ElseCode | ||
| 110 : | 11 CONSTANT AheadCode | ||
| 111 : | 13 CONSTANT WhileCode2 | ||
| 112 : | 14 CONSTANT Disable | ||
| 113 : | |||
| 114 : | \ FORMAT WORDS 13jun93jaw | ||
| 115 : | |||
| 116 : | VARIABLE C-Stop | ||
| 117 : | VARIABLE Branches | ||
| 118 : | |||
| 119 : | VARIABLE BranchPointer | ||
| 120 : | VARIABLE SearchPointer | ||
| 121 : | CREATE BranchTable 500 allot | ||
| 122 : | here 3 cells - | ||
| 123 : | ACONSTANT MaxTable | ||
| 124 : | |||
| 125 : | : FirstBranch BranchTable cell+ SearchPointer ! ; | ||
| 126 : | |||
| 127 : | : (BranchAddr?) ( a-addr -- a-addr true | false ) | ||
| 128 : | SearchPointer @ | ||
| 129 : | BEGIN dup BranchPointer @ u< | ||
| 130 : | WHILE | ||
| 131 : | dup @ 2 pick <> | ||
| 132 : | WHILE 3 cells + | ||
| 133 : | REPEAT | ||
| 134 : | nip dup 3 cells + SearchPointer ! true | ||
| 135 : | ELSE | ||
| 136 : | 2drop false | ||
| 137 : | THEN ; | ||
| 138 : | |||
| 139 : | : BranchAddr? | ||
| 140 : | FirstBranch (BranchAddr?) ; | ||
| 141 : | |||
| 142 : | ' (BranchAddr?) ALIAS MoreBranchAddr? | ||
| 143 : | |||
| 144 : | : CheckEnd ( a-addr -- true | false ) | ||
| 145 : | BranchTable cell+ | ||
| 146 : | BEGIN dup BranchPointer @ u< | ||
| 147 : | WHILE | ||
| 148 : | dup @ 2 pick u<= | ||
| 149 : | WHILE 3 cells + | ||
| 150 : | REPEAT | ||
| 151 : | 2drop false | ||
| 152 : | ELSE | ||
| 153 : | 2drop true | ||
| 154 : | THEN ; | ||
| 155 : | |||
| 156 : | \ | ||
| 157 : | \ addrw addrt | ||
| 158 : | \ BEGIN ... WHILE ... AGAIN ... THEN | ||
| 159 : | \ ^ ! ! ^ | ||
| 160 : | \ ----------+--------+ ! | ||
| 161 : | \ ! ! | ||
| 162 : | \ +-------------------+ | ||
| 163 : | \ | ||
| 164 : | \ | ||
| 165 : | |||
| 166 : | : CheckWhile ( a-addrw a-addrt -- true | false ) | ||
| 167 : | BranchTable | ||
| 168 : | BEGIN dup BranchPointer @ u< | ||
| 169 : | WHILE dup @ 3 pick u> | ||
| 170 : | over @ 3 pick u< and | ||
| 171 : | IF dup cell+ @ 3 pick u< | ||
| 172 : | IF 2drop drop true EXIT THEN | ||
| 173 : | THEN | ||
| 174 : | 3 cells + | ||
| 175 : | REPEAT | ||
| 176 : | 2drop drop false ; | ||
| 177 : | |||
| 178 : | : ,Branch ( a-addr -- ) | ||
| 179 : | BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow" | ||
| 180 : | ! | ||
| 181 : | 1 cells BranchPointer +! ; | ||
| 182 : | |||
| 183 : | : Type! ( u -- ) | ||
| 184 : | BranchPointer @ 1 cells - ! ; | ||
| 185 : | |||
| 186 : | : Branch! ( a-addr rel -- a-addr ) | ||
| 187 : | over + over ,Branch ,Branch 0 ,Branch ; | ||
| 188 : | |||
| 189 : | \ DEFER CheckUntil | ||
| 190 : | VARIABLE NoOutput | ||
| 191 : | VARIABLE C-Pass | ||
| 192 : | |||
| 193 : | 0 CONSTANT ScanMode | ||
| 194 : | 1 CONSTANT DisplayMode | ||
| 195 : | 2 CONSTANT DebugMode | ||
| 196 : | |||
| 197 : | : Scan? ( -- flag ) C-Pass @ 0= ; | ||
| 198 : | : Display? ( -- flag ) C-Pass @ 1 = ; | ||
| 199 : | : Debug? ( -- flag ) C-Pass @ 2 = ; | ||
| 200 : | |||
| 201 : | : back? ( n -- flag ) 0< ; | ||
| 202 : | : ahead? ( n -- flag ) 0> ; | ||
| 203 : | |||
| 204 : | : c-(compile) | ||
| 205 : | anton | 1.10 | Display? |
| 206 : | IF | ||
| 207 : | s" POSTPONE " Com# .string | ||
| 208 : | dup @ look 0= ABORT" SEE: No valid XT" | ||
| 209 : | name>string 0 .string bl cemit | ||
| 210 : | THEN | ||
| 211 : | cell+ ; | ||
| 212 : | anton | 1.1 | |
| 213 : | : c-lit | ||
| 214 : | pazsan | 1.8 | Display? IF |
| 215 : | dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 216 : | THEN | ||
| 217 : | cell+ ; | ||
| 218 : | |||
| 219 : | : c-@local# | ||
| 220 : | Display? IF | ||
| 221 : | S" @local" 0 .string | ||
| 222 : | dup @ dup 1 cells / abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 223 : | THEN | ||
| 224 : | cell+ ; | ||
| 225 : | anton | 1.1 | |
| 226 : | pazsan | 1.6 | : c-flit |
| 227 : | pazsan | 1.8 | Display? IF |
| 228 : | dup f@ scratch represent 0= | ||
| 229 : | IF 2drop scratch 3 min 0 .string | ||
| 230 : | ELSE | ||
| 231 : | IF '- cemit THEN 1- | ||
| 232 : | scratch over c@ cemit '. cemit 1 /string 0 .string | ||
| 233 : | 'E cemit | ||
| 234 : | dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 235 : | THEN THEN | ||
| 236 : | float+ ; | ||
| 237 : | |||
| 238 : | : c-f@local# | ||
| 239 : | Display? IF | ||
| 240 : | S" f@local" 0 .string | ||
| 241 : | dup @ dup 1 floats / abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 242 : | THEN | ||
| 243 : | cell+ ; | ||
| 244 : | |||
| 245 : | : c-laddr# | ||
| 246 : | Display? IF | ||
| 247 : | S" laddr# " 0 .string | ||
| 248 : | dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 249 : | THEN | ||
| 250 : | cell+ ; | ||
| 251 : | |||
| 252 : | : c-lp+!# | ||
| 253 : | Display? IF | ||
| 254 : | S" lp+!# " 0 .string | ||
| 255 : | dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 256 : | THEN | ||
| 257 : | cell+ ; | ||
| 258 : | pazsan | 1.6 | |
| 259 : | anton | 1.1 | : c-s" |
| 260 : | count 2dup + aligned -rot | ||
| 261 : | Display? | ||
| 262 : | IF [char] S cemit [char] " cemit bl cemit 0 .string | ||
| 263 : | [char] " cemit bl cemit | ||
| 264 : | ELSE 2drop | ||
| 265 : | THEN ; | ||
| 266 : | |||
| 267 : | : c-." | ||
| 268 : | count 2dup + aligned -rot | ||
| 269 : | Display? | ||
| 270 : | IF [char] . cemit | ||
| 271 : | [char] " cemit bl cemit 0 .string | ||
| 272 : | [char] " cemit bl cemit | ||
| 273 : | ELSE 2drop | ||
| 274 : | THEN ; | ||
| 275 : | |||
| 276 : | : c-c" | ||
| 277 : | count 2dup + aligned -rot | ||
| 278 : | Display? | ||
| 279 : | IF [char] C cemit [char] " cemit bl cemit 0 .string | ||
| 280 : | [char] " cemit bl cemit | ||
| 281 : | ELSE 2drop | ||
| 282 : | THEN ; | ||
| 283 : | |||
| 284 : | |||
| 285 : | : Forward? ( a-addr true | false -- ) | ||
| 286 : | IF dup dup @ swap 1 cells - @ - | ||
| 287 : | Ahead? IF true ELSE drop false THEN | ||
| 288 : | \ only if forward jump | ||
| 289 : | ELSE false THEN ; | ||
| 290 : | |||
| 291 : | : RepeatCheck | ||
| 292 : | IF BEGIN 2dup | ||
| 293 : | 1 cells - @ swap dup @ + | ||
| 294 : | u<= | ||
| 295 : | WHILE drop dup cell+ | ||
| 296 : | MoreBranchAddr? 0= | ||
| 297 : | UNTIL false | ||
| 298 : | ELSE true | ||
| 299 : | THEN | ||
| 300 : | ELSE false | ||
| 301 : | THEN ; | ||
| 302 : | |||
| 303 : | : c-branch | ||
| 304 : | Scan? | ||
| 305 : | IF dup @ Branch! | ||
| 306 : | dup @ back? | ||
| 307 : | IF \ might be: AGAIN, REPEAT | ||
| 308 : | dup cell+ BranchAddr? Forward? | ||
| 309 : | RepeatCheck | ||
| 310 : | IF RepeatCode Type! | ||
| 311 : | cell+ Disable swap ! | ||
| 312 : | ELSE AgainCode Type! | ||
| 313 : | THEN | ||
| 314 : | ELSE dup cell+ BranchAddr? Forward? | ||
| 315 : | IF ElseCode Type! drop | ||
| 316 : | ELSE AheadCode Type! | ||
| 317 : | THEN | ||
| 318 : | THEN | ||
| 319 : | THEN | ||
| 320 : | Display? | ||
| 321 : | IF | ||
| 322 : | dup @ back? | ||
| 323 : | IF \ might be: AGAIN, REPEAT | ||
| 324 : | level- nl | ||
| 325 : | dup cell+ BranchAddr? Forward? | ||
| 326 : | RepeatCheck | ||
| 327 : | IF drop S" REPEAT " .struc nl | ||
| 328 : | ELSE S" AGAIN " .struc nl | ||
| 329 : | THEN | ||
| 330 : | ELSE dup cell+ BranchAddr? Forward? | ||
| 331 : | IF dup cell+ @ WhileCode2 = | ||
| 332 : | IF nl S" ELSE" .struc level+ | ||
| 333 : | ELSE level- nl S" ELSE" .struc level+ THEN | ||
| 334 : | cell+ Disable swap ! | ||
| 335 : | ELSE S" AHEAD" .struc level+ | ||
| 336 : | THEN | ||
| 337 : | THEN | ||
| 338 : | THEN | ||
| 339 : | Debug? | ||
| 340 : | IF dup @ + | ||
| 341 : | ELSE cell+ | ||
| 342 : | THEN ; | ||
| 343 : | |||
| 344 : | : MyBranch ( a-addr -- a-addr a-addr2 ) | ||
| 345 : | dup @ over + | ||
| 346 : | BranchAddr? | ||
| 347 : | BEGIN | ||
| 348 : | WHILE 1 cells - @ | ||
| 349 : | over <> | ||
| 350 : | WHILE dup @ over + | ||
| 351 : | MoreBranchAddr? | ||
| 352 : | REPEAT | ||
| 353 : | SearchPointer @ 3 cells - | ||
| 354 : | ELSE true ABORT" SEE: Table failure" | ||
| 355 : | THEN ; | ||
| 356 : | |||
| 357 : | : DebugBranch | ||
| 358 : | Debug? | ||
| 359 : | IF dup @ over + swap THEN ; \ return 2 different addresses | ||
| 360 : | |||
| 361 : | : c-?branch | ||
| 362 : | Scan? | ||
| 363 : | IF dup @ Branch! | ||
| 364 : | dup @ Back? | ||
| 365 : | IF UntilCode Type! THEN | ||
| 366 : | THEN | ||
| 367 : | Display? | ||
| 368 : | IF dup @ Back? | ||
| 369 : | IF level- nl S" UNTIL " .struc nl | ||
| 370 : | ELSE dup dup @ over + | ||
| 371 : | CheckWhile | ||
| 372 : | IF MyBranch | ||
| 373 : | cell+ dup @ 0= | ||
| 374 : | IF WhileCode2 swap ! | ||
| 375 : | ELSE drop THEN | ||
| 376 : | level- nl | ||
| 377 : | pazsan | 1.8 | S" WHILE " .struc |
| 378 : | anton | 1.1 | level+ |
| 379 : | pazsan | 1.8 | ELSE nl S" IF " .struc level+ |
| 380 : | anton | 1.1 | THEN |
| 381 : | THEN | ||
| 382 : | THEN | ||
| 383 : | DebugBranch | ||
| 384 : | cell+ ; | ||
| 385 : | |||
| 386 : | pazsan | 1.8 | : c-?branch-lp+!# c-?branch cell+ ; |
| 387 : | : c-branch-lp+!# c-branch cell+ ; | ||
| 388 : | |||
| 389 : | anton | 1.1 | : c-do |
| 390 : | Display? IF nl S" DO" .struc level+ THEN ; | ||
| 391 : | |||
| 392 : | : c-?do | ||
| 393 : | Display? IF nl S" ?DO" .struc level+ THEN | ||
| 394 : | DebugBranch cell+ ; | ||
| 395 : | |||
| 396 : | : c-for | ||
| 397 : | Display? IF nl S" FOR" .struc level+ THEN ; | ||
| 398 : | |||
| 399 : | : c-next | ||
| 400 : | Display? IF level- nl S" NEXT " .struc nl THEN | ||
| 401 : | DebugBranch cell+ cell+ ; | ||
| 402 : | |||
| 403 : | : c-loop | ||
| 404 : | Display? IF level- nl S" LOOP " .struc nl THEN | ||
| 405 : | DebugBranch cell+ cell+ ; | ||
| 406 : | |||
| 407 : | : c-+loop | ||
| 408 : | Display? IF level- nl S" +LOOP " .struc nl THEN | ||
| 409 : | DebugBranch cell+ cell+ ; | ||
| 410 : | |||
| 411 : | pazsan | 1.8 | : c-s+loop |
| 412 : | Display? IF level- nl S" S+LOOP " .struc nl THEN | ||
| 413 : | DebugBranch cell+ cell+ ; | ||
| 414 : | |||
| 415 : | : c--loop | ||
| 416 : | Display? IF level- nl S" -LOOP " .struc nl THEN | ||
| 417 : | DebugBranch cell+ cell+ ; | ||
| 418 : | |||
| 419 : | : c-next-lp+!# c-next cell+ ; | ||
| 420 : | : c-loop-lp+!# c-loop cell+ ; | ||
| 421 : | : c-+loop-lp+!# c-+loop cell+ ; | ||
| 422 : | : c-s+loop-lp+!# c-s+loop cell+ ; | ||
| 423 : | : c--loop-lp+!# c--loop cell+ ; | ||
| 424 : | |||
| 425 : | anton | 1.1 | : c-leave |
| 426 : | Display? IF S" LEAVE " .struc THEN | ||
| 427 : | Debug? IF dup @ + THEN cell+ ; | ||
| 428 : | |||
| 429 : | : c-?leave | ||
| 430 : | Display? IF S" ?LEAVE " .struc THEN | ||
| 431 : | cell+ DebugBranch swap cell+ swap cell+ ; | ||
| 432 : | |||
| 433 : | : c-exit dup 1 cells - | ||
| 434 : | CheckEnd | ||
| 435 : | IF Display? IF nlflag off S" ;" Com# .string THEN | ||
| 436 : | C-Stop on | ||
| 437 : | ELSE Display? IF S" EXIT " .struc THEN | ||
| 438 : | THEN | ||
| 439 : | Debug? IF drop THEN ; | ||
| 440 : | |||
| 441 : | anton | 1.7 | : c-does> \ end of create part |
| 442 : | anton | 1.1 | Display? IF S" DOES> " Com# .string THEN |
| 443 : | Cell+ cell+ ; | ||
| 444 : | |||
| 445 : | : c-abort" | ||
| 446 : | count 2dup + aligned -rot | ||
| 447 : | Display? | ||
| 448 : | IF S" ABORT" .struc | ||
| 449 : | [char] " cemit bl cemit 0 .string | ||
| 450 : | [char] " cemit bl cemit | ||
| 451 : | ELSE 2drop | ||
| 452 : | THEN ; | ||
| 453 : | |||
| 454 : | |||
| 455 : | CREATE C-Table | ||
| 456 : | pazsan | 1.8 | ' lit A, ' c-lit A, |
| 457 : | ' @local# A, ' c-@local# A, | ||
| 458 : | ' flit A, ' c-flit A, | ||
| 459 : | ' f@local# A, ' c-f@local# A, | ||
| 460 : | ' laddr# A, ' c-laddr# A, | ||
| 461 : | ' lp+!# A, ' c-lp+!# A, | ||
| 462 : | ' (s") A, ' c-s" A, | ||
| 463 : | ' (.") A, ' c-." A, | ||
| 464 : | ' "lit A, ' c-c" A, | ||
| 465 : | ' leave A, ' c-leave A, | ||
| 466 : | ' ?leave A, ' c-?leave A, | ||
| 467 : | ' (do) A, ' c-do A, | ||
| 468 : | ' (?do) A, ' c-?do A, | ||
| 469 : | ' (for) A, ' c-for A, | ||
| 470 : | ' ?branch A, ' c-?branch A, | ||
| 471 : | ' branch A, ' c-branch A, | ||
| 472 : | ' (loop) A, ' c-loop A, | ||
| 473 : | ' (+loop) A, ' c-+loop A, | ||
| 474 : | ' (s+loop) A, ' c-s+loop A, | ||
| 475 : | ' (-loop) A, ' c--loop A, | ||
| 476 : | ' (next) A, ' c-next A, | ||
| 477 : | ' ?branch-lp+!# A, ' c-?branch-lp+!# A, | ||
| 478 : | ' branch-lp+!# A, ' c-branch-lp+!# A, | ||
| 479 : | ' (loop)-lp+!# A, ' c-loop-lp+!# A, | ||
| 480 : | ' (+loop)-lp+!# A, ' c-+loop-lp+!# A, | ||
| 481 : | ' (s+loop)-lp+!# A, ' c-s+loop-lp+!# A, | ||
| 482 : | ' (-loop)-lp+!# A, ' c--loop-lp+!# A, | ||
| 483 : | ' (next)-lp+!# A, ' c-next-lp+!# A, | ||
| 484 : | ' ;s A, ' c-exit A, | ||
| 485 : | ' (does>) A, ' c-does> A, | ||
| 486 : | ' (abort") A, ' c-abort" A, | ||
| 487 : | ' (compile) A, ' c-(compile) A, | ||
| 488 : | anton | 1.1 | 0 , |
| 489 : | |||
| 490 : | \ DOTABLE 15may93jaw | ||
| 491 : | |||
| 492 : | : DoTable ( cfa -- flag ) | ||
| 493 : | C-Table | ||
| 494 : | BEGIN dup @ dup | ||
| 495 : | WHILE 2 pick <> | ||
| 496 : | WHILE 2 cells + | ||
| 497 : | REPEAT | ||
| 498 : | nip cell+ @ EXECUTE | ||
| 499 : | true | ||
| 500 : | ELSE | ||
| 501 : | 2drop drop false | ||
| 502 : | THEN ; | ||
| 503 : | |||
| 504 : | : BranchTo? ( a-addr -- a-addr ) | ||
| 505 : | Display? IF dup BranchAddr? | ||
| 506 : | IF BEGIN cell+ @ dup 20 u> | ||
| 507 : | IF drop nl S" BEGIN " .struc level+ | ||
| 508 : | ELSE | ||
| 509 : | dup Disable <> | ||
| 510 : | IF WhileCode2 = | ||
| 511 : | IF nl S" THEN " .struc nl ELSE | ||
| 512 : | level- nl S" THEN " .struc nl THEN | ||
| 513 : | ELSE drop THEN | ||
| 514 : | THEN | ||
| 515 : | dup MoreBranchAddr? 0= | ||
| 516 : | UNTIL | ||
| 517 : | THEN | ||
| 518 : | THEN ; | ||
| 519 : | |||
| 520 : | : analyse ( a-addr1 -- a-addr2 ) | ||
| 521 : | Branches @ IF BranchTo? THEN | ||
| 522 : | dup cell+ swap @ | ||
| 523 : | dup >r DoTable r> swap IF drop EXIT THEN | ||
| 524 : | Display? | ||
| 525 : | pazsan | 1.3 | IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!" |
| 526 : | ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit | ||
| 527 : | anton | 1.1 | ELSE drop |
| 528 : | THEN ; | ||
| 529 : | |||
| 530 : | : c-init | ||
| 531 : | 0 YPos ! 0 XPos ! | ||
| 532 : | 0 Level ! nlflag off | ||
| 533 : | BranchTable BranchPointer ! | ||
| 534 : | c-stop off | ||
| 535 : | Branches on ; | ||
| 536 : | |||
| 537 : | : makepass ( a-addr -- ) | ||
| 538 : | c-stop off | ||
| 539 : | BEGIN | ||
| 540 : | analyse | ||
| 541 : | c-stop @ | ||
| 542 : | UNTIL drop ; | ||
| 543 : | |||
| 544 : | DEFER dosee | ||
| 545 : | |||
| 546 : | : dopri .name ." is primitive" cr ; | ||
| 547 : | pazsan | 1.4 | : dovar ." Variable " .name cr ; |
| 548 : | : douse ." User " .name cr ; | ||
| 549 : | : docon dup cell+ (name>) >body @ . ." Constant " .name cr ; | ||
| 550 : | : doval dup cell+ (name>) >body @ . ." Value " .name cr ; | ||
| 551 : | : dodef ." Defer " dup >r .name cr | ||
| 552 : | pazsan | 1.8 | r@ cell+ (name>) >body @ look |
| 553 : | 0= ABORT" SEE: No valid xt in deferred word" | ||
| 554 : | dup dosee cr | ||
| 555 : | ." ' " .name r> ." IS " .name cr ; | ||
| 556 : | pazsan | 1.5 | : dodoe ." Create " dup .name cr |
| 557 : | S" DOES> " Com# .string XPos @ Level ! name> | ||
| 558 : | >does-code dup C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN | ||
| 559 : | anton | 1.1 | ScanMode c-pass ! dup makepass |
| 560 : | DisplayMode c-pass ! makepass ; | ||
| 561 : | pazsan | 1.4 | : doali here @ .name ." Alias " .name cr |
| 562 : | anton | 1.1 | here @ dosee ; |
| 563 : | anton | 1.10 | : docol |
| 564 : | S" : " Com# .string | ||
| 565 : | dup name>string 2 pick wordinfo .string bl cemit bl cemit | ||
| 566 : | ( XPos @ ) 2 Level ! | ||
| 567 : | name> >body | ||
| 568 : | C-Pass @ DebugMode = | ||
| 569 : | IF | ||
| 570 : | ScanMode c-pass ! EXIT | ||
| 571 : | THEN | ||
| 572 : | ScanMode c-pass ! dup makepass | ||
| 573 : | DisplayMode c-pass ! makepass ; | ||
| 574 : | anton | 1.1 | |
| 575 : | create wordtypes | ||
| 576 : | Pri# , ' dopri A, | ||
| 577 : | Var# , ' dovar A, | ||
| 578 : | Con# , ' docon A, | ||
| 579 : | Val# , ' doval A, | ||
| 580 : | Def# , ' dodef A, | ||
| 581 : | Doe# , ' dodoe A, | ||
| 582 : | Ali# , ' doali A, | ||
| 583 : | Col# , ' docol A, | ||
| 584 : | pazsan | 1.4 | Use# , ' douse A, |
| 585 : | anton | 1.1 | 0 , |
| 586 : | |||
| 587 : | : (dosee) ( lfa -- ) | ||
| 588 : | pazsan | 1.4 | dup dup cell+ c@ >r |
| 589 : | anton | 1.1 | wordinfo |
| 590 : | wordtypes | ||
| 591 : | BEGIN dup @ dup | ||
| 592 : | pazsan | 1.4 | WHILE 2 pick = IF cell+ @ nip EXECUTE |
| 593 : | r> dup 32 and IF ." immediate" THEN | ||
| 594 : | 64 and IF ." restrict" THEN EXIT THEN | ||
| 595 : | anton | 1.1 | 2 cells + |
| 596 : | REPEAT | ||
| 597 : | pazsan | 1.4 | 2drop rdrop |
| 598 : | anton | 1.1 | .name ." Don't know how to handle" cr ; |
| 599 : | |||
| 600 : | ' (dosee) IS dosee | ||
| 601 : | |||
| 602 : | : xtc ( xt -- ) \ do see at xt | ||
| 603 : | Look 0= ABORT" SEE: No valid XT" | ||
| 604 : | cr c-init | ||
| 605 : | dosee ; | ||
| 606 : | pazsan | 1.3 | |
| 607 : | pazsan | 1.4 | : see name sfind 0= IF ." Word unknown" cr exit THEN |
| 608 : | pazsan | 1.3 | xtc ; |
| 609 : | anton | 1.1 | |
| 610 : | : lfc cr c-init cell+ dosee ; | ||
| 611 : | : nfc cr c-init dosee ; | ||
| 612 : | |||
| 613 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |