Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ CROSS.FS The Cross-Compiler 06oct92py |
| 2 : | \ Idea and implementation: Bernd Paysan (py) | ||
| 3 : | anton | 1.30 | |
| 4 : | \ Copyright (C) 1995 Free Software Foundation, Inc. | ||
| 5 : | |||
| 6 : | \ This file is part of Gforth. | ||
| 7 : | |||
| 8 : | \ Gforth is free software; you can redistribute it and/or | ||
| 9 : | \ modify it under the terms of the GNU General Public License | ||
| 10 : | \ as published by the Free Software Foundation; either version 2 | ||
| 11 : | \ of the License, or (at your option) any later version. | ||
| 12 : | |||
| 13 : | \ This program is distributed in the hope that it will be useful, | ||
| 14 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 15 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 16 : | \ GNU General Public License for more details. | ||
| 17 : | |||
| 18 : | \ You should have received a copy of the GNU General Public License | ||
| 19 : | \ along with this program; if not, write to the Free Software | ||
| 20 : | \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
| 21 : | anton | 1.1 | |
| 22 : | \ Log: | ||
| 23 : | \ changed in ; [ to state off 12may93jaw | ||
| 24 : | \ included place +place 12may93jaw | ||
| 25 : | \ for a created word (variable, constant...) | ||
| 26 : | \ is now an alias in the target voabulary. | ||
| 27 : | \ this means it is no longer necessary to | ||
| 28 : | \ switch between vocabularies for variable | ||
| 29 : | \ initialization 12may93jaw | ||
| 30 : | \ discovered error in DOES> | ||
| 31 : | \ replaced !does with (;code) 16may93jaw | ||
| 32 : | \ made complete redesign and | ||
| 33 : | \ introduced two vocs method | ||
| 34 : | \ to be asure that the right words | ||
| 35 : | \ are found 08jun93jaw | ||
| 36 : | \ btw: ! works not with 16 bit | ||
| 37 : | \ targets 09jun93jaw | ||
| 38 : | \ added: 2user and value 11jun93jaw | ||
| 39 : | |||
| 40 : | anton | 1.48 | \ needed? works better now!!! 01mar97jaw |
| 41 : | \ mach file is only loaded into target | ||
| 42 : | \ cell corrected | ||
| 43 : | jwilke | 1.52 | \ romable extansions 27apr97-5jun97jaw |
| 44 : | anton | 1.48 | |
| 45 : | |||
| 46 : | jwilke | 1.52 | hex \ the defualt base for the cross-compiler is hex !! |
| 47 : | Warnings off | ||
| 48 : | |||
| 49 : | \ words that are generaly useful | ||
| 50 : | |||
| 51 : | : >wordlist ( vocabulary-xt -- wordlist-struct ) | ||
| 52 : | also execute get-order swap >r 1- set-order r> ; | ||
| 53 : | |||
| 54 : | : umax 2dup u< IF swap THEN drop ; | ||
| 55 : | : umin 2dup u> IF swap THEN drop ; | ||
| 56 : | anton | 1.1 | |
| 57 : | pazsan | 1.23 | : string, ( c-addr u -- ) |
| 58 : | \ puts down string as cstring | ||
| 59 : | dup c, here swap chars dup allot move ; | ||
| 60 : | pazsan | 1.5 | |
| 61 : | jwilke | 1.52 | : SetValue ( n -- <name> ) |
| 62 : | \G Same behaviour as "Value" when the <name> is not defined | ||
| 63 : | \G Same behaviour as "to" when <name> is defined | ||
| 64 : | \G SetValue searches in the current vocabulary | ||
| 65 : | save-input bl word >r restore-input throw r> count | ||
| 66 : | get-current search-wordlist | ||
| 67 : | IF bl word drop >body ! ELSE Value THEN ; | ||
| 68 : | |||
| 69 : | : DefaultValue ( n -- <name> ) | ||
| 70 : | \G Same behaviour as "Value" when the <name> is not defined | ||
| 71 : | \G SetValue searches in the current vocabulary | ||
| 72 : | save-input bl word >r restore-input throw r> count | ||
| 73 : | get-current search-wordlist | ||
| 74 : | IF bl word drop drop drop ELSE Value THEN ; | ||
| 75 : | anton | 1.1 | |
| 76 : | hex | ||
| 77 : | |||
| 78 : | Vocabulary Cross | ||
| 79 : | Vocabulary Target | ||
| 80 : | Vocabulary Ghosts | ||
| 81 : | VOCABULARY Minimal | ||
| 82 : | only Forth also Target also also | ||
| 83 : | definitions Forth | ||
| 84 : | |||
| 85 : | : T previous Cross also Target ; immediate | ||
| 86 : | : G Ghosts ; immediate | ||
| 87 : | : H previous Forth also Cross ; immediate | ||
| 88 : | |||
| 89 : | forth definitions | ||
| 90 : | |||
| 91 : | : T previous Cross also Target ; immediate | ||
| 92 : | : G Ghosts ; immediate | ||
| 93 : | |||
| 94 : | : >cross also Cross definitions previous ; | ||
| 95 : | : >target also Target definitions previous ; | ||
| 96 : | : >minimal also Minimal definitions previous ; | ||
| 97 : | |||
| 98 : | H | ||
| 99 : | |||
| 100 : | >CROSS | ||
| 101 : | |||
| 102 : | jwilke | 1.52 | \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are |
| 103 : | \ for cross-compiling | ||
| 104 : | \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!! | ||
| 105 : | |||
| 106 : | : comment? ( c-addr u -- c-addr u ) | ||
| 107 : | 2dup s" (" compare 0= | ||
| 108 : | IF postpone ( | ||
| 109 : | ELSE 2dup s" \" compare 0= IF postpone \ THEN | ||
| 110 : | THEN ; | ||
| 111 : | |||
| 112 : | \ Begin CROSS COMPILER: | ||
| 113 : | |||
| 114 : | |||
| 115 : | |||
| 116 : | \ \ -------------------- Error Handling 05aug97jaw | ||
| 117 : | |||
| 118 : | \ Flags | ||
| 119 : | |||
| 120 : | also forth definitions \ these values may be predefined before | ||
| 121 : | \ the cross-compiler is loaded | ||
| 122 : | |||
| 123 : | false DefaultValue stack-warn \ check on empty stack at any definition | ||
| 124 : | false DefaultValue create-forward-warn \ warn on forward declaration of created words | ||
| 125 : | |||
| 126 : | [IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] | ||
| 127 : | [IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] | ||
| 128 : | |||
| 129 : | previous >CROSS | ||
| 130 : | |||
| 131 : | : .sourcepos | ||
| 132 : | cr sourcefilename type ." :" | ||
| 133 : | base @ decimal sourceline# . base ! ; | ||
| 134 : | |||
| 135 : | : warnhead | ||
| 136 : | \G display error-message head | ||
| 137 : | \G perhaps with linenumber and filename | ||
| 138 : | .sourcepos ." Warning: " ; | ||
| 139 : | |||
| 140 : | : empty? depth IF .sourcepos ." Stack not empty!" THEN ; | ||
| 141 : | |||
| 142 : | stack-warn [IF] | ||
| 143 : | : defempty? empty? ; | ||
| 144 : | [ELSE] | ||
| 145 : | : defempty? ; immediate | ||
| 146 : | [THEN] | ||
| 147 : | |||
| 148 : | |||
| 149 : | \ \ GhostNames Ghosts 9may93jaw | ||
| 150 : | |||
| 151 : | \ second name source to search trough list | ||
| 152 : | |||
| 153 : | VARIABLE GhostNames | ||
| 154 : | 0 GhostNames ! | ||
| 155 : | |||
| 156 : | : GhostName ( -- addr ) | ||
| 157 : | here GhostNames @ , GhostNames ! here 0 , | ||
| 158 : | bl word count | ||
| 159 : | \ 2dup type space | ||
| 160 : | string, \ !! cfalign ? | ||
| 161 : | align ; | ||
| 162 : | |||
| 163 : | \ Ghost Builder 06oct92py | ||
| 164 : | |||
| 165 : | \ <T T> new version with temp variable 10may93jaw | ||
| 166 : | |||
| 167 : | VARIABLE VocTemp | ||
| 168 : | |||
| 169 : | : <T get-current VocTemp ! also Ghosts definitions ; | ||
| 170 : | : T> previous VocTemp @ set-current ; | ||
| 171 : | |||
| 172 : | hex | ||
| 173 : | 4711 Constant <fwd> 4712 Constant <res> | ||
| 174 : | 4713 Constant <imm> 4714 Constant <do:> | ||
| 175 : | |||
| 176 : | \ iForth makes only immediate directly after create | ||
| 177 : | \ make atonce trick! ? | ||
| 178 : | |||
| 179 : | Variable atonce atonce off | ||
| 180 : | |||
| 181 : | : NoExec true ABORT" CROSS: Don't execute ghost" ; | ||
| 182 : | |||
| 183 : | : GhostHeader <fwd> , 0 , ['] NoExec , ; | ||
| 184 : | |||
| 185 : | : >magic ; \ type of ghost | ||
| 186 : | : >link cell+ ; \ pointer where ghost is in target, or if unresolved | ||
| 187 : | \ points to the where we have to resolve (linked-list) | ||
| 188 : | : >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost | ||
| 189 : | : >end 3 cells + ; \ room for additional tags | ||
| 190 : | \ for builder (create, variable...) words the | ||
| 191 : | \ execution symantics of words built are placed here | ||
| 192 : | |||
| 193 : | Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> | ||
| 194 : | Variable last-ghost \ last ghost that is created | ||
| 195 : | Variable last-header-ghost \ last ghost definitions with header | ||
| 196 : | |||
| 197 : | : Make-Ghost ( "name" -- ghost ) | ||
| 198 : | >in @ GhostName swap >in ! | ||
| 199 : | <T Create atonce @ IF immediate atonce off THEN | ||
| 200 : | here tuck swap ! ghostheader T> | ||
| 201 : | dup last-ghost ! | ||
| 202 : | DOES> dup executed-ghost ! >exec @ execute ; | ||
| 203 : | |||
| 204 : | \ ghost words 14oct92py | ||
| 205 : | \ changed: 10may93py/jaw | ||
| 206 : | |||
| 207 : | : gfind ( string -- ghost true/1 / string false ) | ||
| 208 : | \ searches for string in word-list ghosts | ||
| 209 : | dup count [ ' ghosts >wordlist ] ALiteral search-wordlist | ||
| 210 : | dup IF >r >body nip r> THEN ; | ||
| 211 : | |||
| 212 : | : gdiscover ( xt -- ghost true | xt false ) | ||
| 213 : | GhostNames | ||
| 214 : | BEGIN @ dup | ||
| 215 : | WHILE 2dup | ||
| 216 : | cell+ @ dup >magic @ <fwd> <> | ||
| 217 : | >r >link @ = r> and | ||
| 218 : | IF cell+ @ nip true EXIT THEN | ||
| 219 : | REPEAT | ||
| 220 : | drop false ; | ||
| 221 : | |||
| 222 : | VARIABLE Already | ||
| 223 : | |||
| 224 : | : ghost ( "name" -- ghost ) | ||
| 225 : | Already off | ||
| 226 : | >in @ bl word gfind IF Already on nip EXIT THEN | ||
| 227 : | drop >in ! Make-Ghost ; | ||
| 228 : | |||
| 229 : | : >ghostname ( ghost -- adr len ) | ||
| 230 : | GhostNames | ||
| 231 : | BEGIN @ dup | ||
| 232 : | WHILE 2dup cell+ @ = | ||
| 233 : | UNTIL nip 2 cells + count | ||
| 234 : | ELSE 2drop true abort" CROSS: Ghostnames inconsistent" | ||
| 235 : | THEN ; | ||
| 236 : | |||
| 237 : | ' >ghostname ALIAS @name | ||
| 238 : | |||
| 239 : | : forward? ( ghost -- flag ) | ||
| 240 : | >magic @ <fwd> = ; | ||
| 241 : | |||
| 242 : | \ Predefined ghosts 12dec92py | ||
| 243 : | |||
| 244 : | ghost 0= drop | ||
| 245 : | ghost branch ghost ?branch 2drop | ||
| 246 : | ghost (do) ghost (?do) 2drop | ||
| 247 : | ghost (for) drop | ||
| 248 : | ghost (loop) ghost (+loop) 2drop | ||
| 249 : | ghost (next) drop | ||
| 250 : | ghost unloop ghost ;S 2drop | ||
| 251 : | ghost lit ghost (compile) ghost ! 2drop drop | ||
| 252 : | ghost (does>) ghost noop 2drop | ||
| 253 : | ghost (.") ghost (S") ghost (ABORT") 2drop drop | ||
| 254 : | ghost ' drop | ||
| 255 : | ghost :docol ghost :doesjump ghost :dodoes 2drop drop | ||
| 256 : | ghost over ghost = ghost drop 2drop drop | ||
| 257 : | ghost - drop | ||
| 258 : | |||
| 259 : | \ \ Parameter for target systems 06oct92py | ||
| 260 : | |||
| 261 : | \ we define it ans like... | ||
| 262 : | wordlist Constant target-environment | ||
| 263 : | |||
| 264 : | VARIABLE env-current \ save information of current dictionary to restore with environ> | ||
| 265 : | |||
| 266 : | : >ENVIRON get-current env-current ! target-environment set-current ; | ||
| 267 : | : ENVIRON> env-current @ set-current ; | ||
| 268 : | pazsan | 1.43 | |
| 269 : | anton | 1.48 | >TARGET |
| 270 : | pazsan | 1.43 | |
| 271 : | jwilke | 1.52 | : environment? |
| 272 : | target-environment search-wordlist | ||
| 273 : | IF execute true ELSE false THEN ; | ||
| 274 : | |||
| 275 : | : e? name T environment? H 0= ABORT" environment variable not defined!" ; | ||
| 276 : | |||
| 277 : | : has? name T environment? H IF ELSE false THEN ; | ||
| 278 : | |||
| 279 : | : $has? T environment? H IF ELSE false THEN ; | ||
| 280 : | anton | 1.48 | |
| 281 : | jwilke | 1.52 | >ENVIRON |
| 282 : | true Value cross | ||
| 283 : | >TARGET | ||
| 284 : | |||
| 285 : | mach-file count included hex | ||
| 286 : | pazsan | 1.43 | |
| 287 : | jwilke | 1.52 | >TARGET |
| 288 : | pazsan | 1.43 | |
| 289 : | jwilke | 1.52 | [IFUNDEF] has-interpreter true Value has-interpreter [THEN] |
| 290 : | [IFUNDEF] itc true Value itc [THEN] | ||
| 291 : | [IFUNDEF] has-rom false Value has-rom [THEN] | ||
| 292 : | pazsan | 1.43 | |
| 293 : | >CROSS | ||
| 294 : | |||
| 295 : | jwilke | 1.52 | \ \ Create additional parameters 19jan95py |
| 296 : | pazsan | 1.19 | |
| 297 : | T | ||
| 298 : | anton | 1.48 | NIL Constant TNIL |
| 299 : | pazsan | 1.19 | cell Constant tcell |
| 300 : | cell<< Constant tcell<< | ||
| 301 : | cell>bit Constant tcell>bit | ||
| 302 : | bits/byte Constant tbits/byte | ||
| 303 : | float Constant tfloat | ||
| 304 : | 1 bits/byte lshift Constant maxbyte | ||
| 305 : | H | ||
| 306 : | |||
| 307 : | anton | 1.48 | \ Variables 06oct92py |
| 308 : | |||
| 309 : | Variable image | ||
| 310 : | Variable tlast TNIL tlast ! \ Last name field | ||
| 311 : | Variable tlastcfa \ Last code field | ||
| 312 : | Variable tdoes \ Resolve does> calls | ||
| 313 : | Variable bit$ | ||
| 314 : | jwilke | 1.52 | |
| 315 : | \ statistics 10jun97jaw | ||
| 316 : | |||
| 317 : | Variable headers-named 0 headers-named ! | ||
| 318 : | Variable user-vars 0 user-vars ! | ||
| 319 : | |||
| 320 : | \ Memory initialisation 05dec92py | ||
| 321 : | |||
| 322 : | [IFDEF] Memory \ Memory is a bigFORTH feature | ||
| 323 : | also Memory | ||
| 324 : | : initmem ( var len -- ) | ||
| 325 : | 2dup swap handle! >r @ r> erase ; | ||
| 326 : | toss | ||
| 327 : | [ELSE] | ||
| 328 : | : initmem ( var len -- ) | ||
| 329 : | tuck allocate abort" CROSS: No memory for target" | ||
| 330 : | ( len var adr ) dup rot ! | ||
| 331 : | ( len adr ) swap erase ; | ||
| 332 : | [THEN] | ||
| 333 : | |||
| 334 : | \ MakeKernal 12dec92py | ||
| 335 : | |||
| 336 : | : makekernel ( targetsize -- targetsize ) | ||
| 337 : | bit$ over 1- tcell>bit rshift 1+ initmem | ||
| 338 : | image over initmem ; | ||
| 339 : | |||
| 340 : | >MINIMAL | ||
| 341 : | : makekernel makekernel ; | ||
| 342 : | |||
| 343 : | |||
| 344 : | >CROSS | ||
| 345 : | |||
| 346 : | \ memregion.fs | ||
| 347 : | |||
| 348 : | |||
| 349 : | Variable last-defined-region \ pointer to last defined region | ||
| 350 : | Variable region-link \ linked list with all regions | ||
| 351 : | Variable mirrored-link \ linked list for mirrored regions | ||
| 352 : | 0 dup mirrored-link ! region-link ! | ||
| 353 : | |||
| 354 : | |||
| 355 : | : >rdp 2 cells + ; | ||
| 356 : | : >rlen cell+ ; | ||
| 357 : | : >rstart ; | ||
| 358 : | |||
| 359 : | |||
| 360 : | : region ( addr len -- ) \G create a new region | ||
| 361 : | \ check whether predefined region exists | ||
| 362 : | save-input bl word find >r >r restore-input throw r> r> 0= | ||
| 363 : | IF \ make region | ||
| 364 : | drop | ||
| 365 : | save-input create restore-input throw | ||
| 366 : | here last-defined-region ! | ||
| 367 : | over ( startaddr ) , ( length ) , ( dp ) , | ||
| 368 : | region-link linked name string, | ||
| 369 : | ELSE \ store new parameters in region | ||
| 370 : | bl word drop | ||
| 371 : | >body >r r@ last-defined-region ! | ||
| 372 : | r@ cell+ ! dup r@ ! r> 2 cells + ! | ||
| 373 : | THEN ; | ||
| 374 : | |||
| 375 : | : borders ( region -- startaddr endaddr ) \G returns lower and upper region border | ||
| 376 : | dup @ swap cell+ @ over + ; | ||
| 377 : | |||
| 378 : | : extent ( region -- startaddr len ) \G returns the really used area | ||
| 379 : | dup @ swap 2 cells + @ over - ; | ||
| 380 : | |||
| 381 : | : area ( region -- startaddr totallen ) \G returns the total area | ||
| 382 : | dup @ swap cell+ @ ; | ||
| 383 : | |||
| 384 : | : mirrored \G mark a region as mirrored | ||
| 385 : | mirrored-link | ||
| 386 : | linked last-defined-region @ , ; | ||
| 387 : | |||
| 388 : | : .addr | ||
| 389 : | base @ >r hex | ||
| 390 : | tcell 2 u> | ||
| 391 : | IF s>d <# # # # # '. hold # # # # #> type | ||
| 392 : | ELSE s>d <# # # # # # #> type | ||
| 393 : | THEN r> base ! ; | ||
| 394 : | |||
| 395 : | : .regions \G display region statistic | ||
| 396 : | |||
| 397 : | \ we want to list the regions in the right order | ||
| 398 : | \ so first collect all regions on stack | ||
| 399 : | 0 region-link @ | ||
| 400 : | BEGIN dup WHILE dup @ REPEAT drop | ||
| 401 : | BEGIN dup | ||
| 402 : | WHILE cr 3 cells - >r | ||
| 403 : | r@ 4 cells + count tuck type | ||
| 404 : | 12 swap - 0 max spaces space | ||
| 405 : | ." Start: " r@ @ dup .addr space | ||
| 406 : | ." End: " r@ 1 cells + @ + .addr space | ||
| 407 : | ." DP: " r> 2 cells + @ .addr | ||
| 408 : | REPEAT drop | ||
| 409 : | s" rom" $has? 0= ?EXIT | ||
| 410 : | cr ." Mirrored:" | ||
| 411 : | mirrored-link @ | ||
| 412 : | BEGIN dup | ||
| 413 : | WHILE space dup cell+ @ 4 cells + count type @ | ||
| 414 : | REPEAT drop cr | ||
| 415 : | ; | ||
| 416 : | |||
| 417 : | \ -------- predefined regions | ||
| 418 : | |||
| 419 : | 0 0 region address-space | ||
| 420 : | \ total memory addressed and used by the target system | ||
| 421 : | |||
| 422 : | 0 0 region dictionary | ||
| 423 : | \ rom area for the compiler | ||
| 424 : | |||
| 425 : | has? rom | ||
| 426 : | [IF] | ||
| 427 : | 0 0 region ram-dictionary mirrored | ||
| 428 : | \ ram area for the compiler | ||
| 429 : | [ELSE] | ||
| 430 : | ' dictionary ALIAS ram-dictionary | ||
| 431 : | [THEN] | ||
| 432 : | |||
| 433 : | 0 0 region return-stack | ||
| 434 : | |||
| 435 : | 0 0 region data-stack | ||
| 436 : | |||
| 437 : | 0 0 region tib-region | ||
| 438 : | |||
| 439 : | ' dictionary ALIAS rom-dictionary | ||
| 440 : | |||
| 441 : | |||
| 442 : | : setup-target ( -- ) \G initialize targets memory space | ||
| 443 : | s" rom" $has? | ||
| 444 : | IF \ check for ram and rom... | ||
| 445 : | address-space area nip | ||
| 446 : | ram-dictionary area nip | ||
| 447 : | rom-dictionary area nip | ||
| 448 : | and and 0= | ||
| 449 : | ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" | ||
| 450 : | THEN | ||
| 451 : | address-space area nip | ||
| 452 : | IF | ||
| 453 : | address-space area | ||
| 454 : | ELSE | ||
| 455 : | dictionary area | ||
| 456 : | THEN | ||
| 457 : | dup 0= | ||
| 458 : | ABORT" CROSS: define at least address-space or dictionary!!" | ||
| 459 : | + makekernel drop ; | ||
| 460 : | |||
| 461 : | \ switched tdp for rom support 03jun97jaw | ||
| 462 : | |||
| 463 : | \ second value is here to store some maximal value for statistics | ||
| 464 : | \ tempdp is also embedded here but has nothing to do with rom support | ||
| 465 : | \ (needs switched dp) | ||
| 466 : | |||
| 467 : | variable tempdp 0 , \ temporary dp for resolving | ||
| 468 : | variable tempdp-save | ||
| 469 : | |||
| 470 : | 0 [IF] | ||
| 471 : | variable romdp 0 , \ Dictionary-Pointer for ramarea | ||
| 472 : | variable ramdp 0 , \ Dictionary-Pointer for romarea | ||
| 473 : | |||
| 474 : | \ | ||
| 475 : | variable sramdp \ start of ram-area for forth | ||
| 476 : | variable sromdp \ start of rom-area for forth | ||
| 477 : | |||
| 478 : | [THEN] | ||
| 479 : | |||
| 480 : | |||
| 481 : | 0 value tdp | ||
| 482 : | variable fixed \ flag: true: no automatic switching | ||
| 483 : | \ false: switching is done automatically | ||
| 484 : | |||
| 485 : | \ Switch-Policy: | ||
| 486 : | \ | ||
| 487 : | \ a header is always compiled into rom | ||
| 488 : | \ after a created word (create and variable) compilation goes to ram | ||
| 489 : | \ | ||
| 490 : | \ Be careful: If you want to make the data behind create into rom | ||
| 491 : | \ you have to put >rom before create! | ||
| 492 : | |||
| 493 : | variable constflag constflag off | ||
| 494 : | |||
| 495 : | : (switchram) | ||
| 496 : | fixed @ ?EXIT has-rom 0= ?EXIT | ||
| 497 : | ram-dictionary >rdp to tdp ; | ||
| 498 : | |||
| 499 : | : switchram | ||
| 500 : | constflag @ | ||
| 501 : | IF constflag off ELSE (switchram) THEN ; | ||
| 502 : | |||
| 503 : | : switchrom | ||
| 504 : | fixed @ ?EXIT rom-dictionary >rdp to tdp ; | ||
| 505 : | |||
| 506 : | : >tempdp ( addr -- ) | ||
| 507 : | tdp tempdp-save ! tempdp to tdp tdp ! ; | ||
| 508 : | : tempdp> ( -- ) | ||
| 509 : | tempdp-save @ to tdp ; | ||
| 510 : | |||
| 511 : | : >ram fixed off (switchram) fixed on ; | ||
| 512 : | : >rom fixed off switchrom fixed on ; | ||
| 513 : | : >auto fixed off switchrom ; | ||
| 514 : | |||
| 515 : | |||
| 516 : | |||
| 517 : | \ : romstart dup sromdp ! romdp ! ; | ||
| 518 : | \ : ramstart dup sramdp ! ramdp ! ; | ||
| 519 : | |||
| 520 : | \ default compilation goed to rom | ||
| 521 : | \ when romable support is off, only the rom switch is used (!!) | ||
| 522 : | >auto | ||
| 523 : | |||
| 524 : | anton | 1.48 | : there tdp @ ; |
| 525 : | |||
| 526 : | jwilke | 1.52 | >TARGET |
| 527 : | anton | 1.48 | |
| 528 : | jwilke | 1.52 | \ \ Target Memory Handling |
| 529 : | anton | 1.1 | |
| 530 : | \ Byte ordering and cell size 06oct92py | ||
| 531 : | |||
| 532 : | pazsan | 1.19 | : cell+ tcell + ; |
| 533 : | : cells tcell<< lshift ; | ||
| 534 : | anton | 1.1 | : chars ; |
| 535 : | anton | 1.48 | : char+ 1 + ; |
| 536 : | pazsan | 1.19 | : floats tfloat * ; |
| 537 : | anton | 1.6 | |
| 538 : | anton | 1.1 | >CROSS |
| 539 : | pazsan | 1.19 | : cell/ tcell<< rshift ; |
| 540 : | anton | 1.1 | >TARGET |
| 541 : | 20 CONSTANT bl | ||
| 542 : | jwilke | 1.52 | \ TNIL Constant NIL |
| 543 : | anton | 1.1 | |
| 544 : | >CROSS | ||
| 545 : | |||
| 546 : | pazsan | 1.20 | bigendian |
| 547 : | [IF] | ||
| 548 : | jwilke | 1.52 | : S! ( n addr -- ) >r s>d r> tcell bounds swap 1- |
| 549 : | pazsan | 1.20 | DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; |
| 550 : | jwilke | 1.52 | : S@ ( addr -- n ) >r 0 0 r> tcell bounds |
| 551 : | pazsan | 1.20 | DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; |
| 552 : | pazsan | 1.19 | [ELSE] |
| 553 : | jwilke | 1.52 | : S! ( n addr -- ) >r s>d r> tcell bounds |
| 554 : | pazsan | 1.20 | DO maxbyte ud/mod rot I c! LOOP 2drop ; |
| 555 : | jwilke | 1.52 | : S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- |
| 556 : | pazsan | 1.20 | DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; |
| 557 : | anton | 1.1 | [THEN] |
| 558 : | |||
| 559 : | >CROSS | ||
| 560 : | \ Bit string manipulation 06oct92py | ||
| 561 : | \ 9may93jaw | ||
| 562 : | CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, | ||
| 563 : | : bits ( n -- n ) chars Bittable + c@ ; | ||
| 564 : | |||
| 565 : | : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; | ||
| 566 : | : +bit ( addr n -- ) >bit over c@ or swap c! ; | ||
| 567 : | pazsan | 1.4 | : -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
| 568 : | anton | 1.1 | : relon ( taddr -- ) bit$ @ swap cell/ +bit ; |
| 569 : | pazsan | 1.4 | : reloff ( taddr -- ) bit$ @ swap cell/ -bit ; |
| 570 : | anton | 1.1 | |
| 571 : | \ Target memory access 06oct92py | ||
| 572 : | |||
| 573 : | : align+ ( taddr -- rest ) | ||
| 574 : | anton | 1.48 | tcell tuck 1- and - [ tcell 1- ] Literal and ; |
| 575 : | anton | 1.22 | : cfalign+ ( taddr -- rest ) |
| 576 : | pazsan | 1.39 | \ see kernel.fs:cfaligned |
| 577 : | pazsan | 1.43 | /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; |
| 578 : | anton | 1.1 | |
| 579 : | >TARGET | ||
| 580 : | : aligned ( taddr -- ta-addr ) dup align+ + ; | ||
| 581 : | \ assumes cell alignment granularity (as GNU C) | ||
| 582 : | |||
| 583 : | anton | 1.22 | : cfaligned ( taddr1 -- taddr2 ) |
| 584 : | pazsan | 1.39 | \ see kernel.fs |
| 585 : | anton | 1.22 | dup cfalign+ + ; |
| 586 : | |||
| 587 : | anton | 1.1 | >CROSS |
| 588 : | : >image ( taddr -- absaddr ) image @ + ; | ||
| 589 : | >TARGET | ||
| 590 : | jwilke | 1.52 | : @ ( taddr -- w ) >image S@ ; |
| 591 : | : ! ( w taddr -- ) >image S! ; | ||
| 592 : | anton | 1.1 | : c@ ( taddr -- char ) >image c@ ; |
| 593 : | : c! ( char taddr -- ) >image c! ; | ||
| 594 : | anton | 1.7 | : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
| 595 : | : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; | ||
| 596 : | anton | 1.1 | |
| 597 : | \ Target compilation primitives 06oct92py | ||
| 598 : | \ included A! 16may93jaw | ||
| 599 : | |||
| 600 : | : here ( -- there ) there ; | ||
| 601 : | : allot ( n -- ) tdp +! ; | ||
| 602 : | jwilke | 1.52 | : , ( w -- ) T here H tcell T allot ! H T here drop H ; |
| 603 : | anton | 1.1 | : c, ( char -- ) T here 1 allot c! H ; |
| 604 : | : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; | ||
| 605 : | anton | 1.22 | : cfalign ( -- ) |
| 606 : | T here H cfalign+ 0 ?DO bl T c, H LOOP ; | ||
| 607 : | anton | 1.1 | |
| 608 : | : A! dup relon T ! H ; | ||
| 609 : | : A, ( w -- ) T here H relon T , H ; | ||
| 610 : | |||
| 611 : | >CROSS | ||
| 612 : | |||
| 613 : | jwilke | 1.52 | : tcmove ( source dest len -- ) |
| 614 : | \G cmove in target memory | ||
| 615 : | bounds | ||
| 616 : | ?DO dup T c@ H I T c! H 1+ | ||
| 617 : | LOOP drop ; | ||
| 618 : | anton | 1.1 | |
| 619 : | >TARGET | ||
| 620 : | jwilke | 1.52 | H also Forth definitions \ ." asm: " order |
| 621 : | anton | 1.1 | |
| 622 : | jwilke | 1.52 | : X also target bl word find |
| 623 : | IF state @ IF compile, | ||
| 624 : | ELSE execute THEN | ||
| 625 : | ELSE previous ABORT" Cross: access method not supported!" | ||
| 626 : | THEN | ||
| 627 : | previous ; immediate | ||
| 628 : | anton | 1.1 | |
| 629 : | jwilke | 1.52 | [IFDEF] asm-include asm-include [THEN] hex |
| 630 : | anton | 1.1 | |
| 631 : | jwilke | 1.52 | previous |
| 632 : | >CROSS H | ||
| 633 : | anton | 1.1 | |
| 634 : | jwilke | 1.52 | \ \ -------------------- Compiler Plug Ins 01aug97jaw |
| 635 : | anton | 1.1 | |
| 636 : | jwilke | 1.52 | Defer lit, ( n -- ) |
| 637 : | Defer alit, ( n -- ) | ||
| 638 : | Defer branch, ( target-addr -- ) | ||
| 639 : | Defer ?branch, ( target-addr -- ) | ||
| 640 : | Defer branchmark, ( -- branch-addr ) | ||
| 641 : | Defer ?branchmark, ( -- branch-addr ) | ||
| 642 : | Defer branchto, | ||
| 643 : | Defer branchtoresolve, ( branch-addr -- ) | ||
| 644 : | Defer branchfrom, ( -- ) | ||
| 645 : | Defer branchtomark, ( -- target-addr ) | ||
| 646 : | Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position | ||
| 647 : | Defer colon-resolve ( tcfa addr -- ) | ||
| 648 : | Defer addr-resolve ( target-addr addr -- ) | ||
| 649 : | anton | 1.1 | |
| 650 : | jwilke | 1.52 | [IFUNDEF] ca>native |
| 651 : | defer ca>native | ||
| 652 : | [THEN] | ||
| 653 : | anton | 1.1 | |
| 654 : | jwilke | 1.52 | >TARGET |
| 655 : | DEFER >body \ we need the system >body | ||
| 656 : | \ and the target >body | ||
| 657 : | >CROSS | ||
| 658 : | T 2 cells H VALUE xt>body | ||
| 659 : | DEFER doprim, | ||
| 660 : | DEFER docol, \ compiles start of definition and doer | ||
| 661 : | DEFER doer, | ||
| 662 : | DEFER fini, \ compiles end of definition ;s | ||
| 663 : | DEFER doeshandler, | ||
| 664 : | DEFER dodoes, | ||
| 665 : | |||
| 666 : | DEFER ]comp \ starts compilation | ||
| 667 : | DEFER comp[ \ ends compilation | ||
| 668 : | |||
| 669 : | : (cc) T a, H ; ' (cc) IS colon, | ||
| 670 : | : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve | ||
| 671 : | : (ar) T ! H ; ' (ar) IS addr-resolve | ||
| 672 : | anton | 1.1 | |
| 673 : | jwilke | 1.52 | >TARGET |
| 674 : | : compile, colon, ; | ||
| 675 : | >CROSS | ||
| 676 : | anton | 1.1 | |
| 677 : | |||
| 678 : | |||
| 679 : | jwilke | 1.52 | \ resolve structure |
| 680 : | anton | 1.1 | |
| 681 : | jwilke | 1.52 | : >next ; \ link to next field |
| 682 : | : >tag cell+ ; \ indecates type of reference: 0: call, 1: address | ||
| 683 : | : >taddr cell+ cell+ ; | ||
| 684 : | : >ghost 3 cells + ; | ||
| 685 : | anton | 1.48 | |
| 686 : | jwilke | 1.52 | : refered ( ghost tag -- ) |
| 687 : | swap >r here r@ >link @ , r@ >link ! ( tag ) , | ||
| 688 : | T here aligned H , r> drop last-header-ghost @ , ; | ||
| 689 : | anton | 1.48 | |
| 690 : | jwilke | 1.52 | Defer resolve-warning |
| 691 : | anton | 1.1 | |
| 692 : | jwilke | 1.52 | : reswarn-test ( ghost res-struct -- ghost res-struct ) |
| 693 : | over cr ." Resolving " >ghostname type dup ." in " >ghost @ >ghostname type ; | ||
| 694 : | anton | 1.1 | |
| 695 : | jwilke | 1.52 | : reswarn-forward ( ghost res-struct -- ghost res-struct ) |
| 696 : | over warnhead >ghostname type dup ." is referenced in " | ||
| 697 : | >ghost @ >ghostname type ; | ||
| 698 : | anton | 1.1 | |
| 699 : | jwilke | 1.52 | \ ' reswarn-test IS resolve-warning |
| 700 : | |||
| 701 : | anton | 1.1 | \ resolve 14oct92py |
| 702 : | |||
| 703 : | jwilke | 1.52 | : resolve-loop ( ghost tcfa -- ghost tcfa ) |
| 704 : | >r dup >link | ||
| 705 : | BEGIN @ dup WHILE | ||
| 706 : | resolve-warning | ||
| 707 : | r@ over >taddr @ | ||
| 708 : | 2 pick >tag @ | ||
| 709 : | IF addr-resolve | ||
| 710 : | ELSE colon-resolve | ||
| 711 : | THEN | ||
| 712 : | REPEAT drop r> ; | ||
| 713 : | |||
| 714 : | \ : resolve-loop ( ghost tcfa -- ghost tcfa ) | ||
| 715 : | \ >r dup >link @ | ||
| 716 : | \ BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; | ||
| 717 : | anton | 1.1 | |
| 718 : | \ exists 9may93jaw | ||
| 719 : | |||
| 720 : | jwilke | 1.52 | Variable TWarnings |
| 721 : | TWarnings on | ||
| 722 : | Variable Exists-Warnings | ||
| 723 : | Exists-Warnings on | ||
| 724 : | |||
| 725 : | anton | 1.1 | : exists ( ghost tcfa -- ) |
| 726 : | over GhostNames | ||
| 727 : | BEGIN @ dup | ||
| 728 : | WHILE 2dup cell+ @ = | ||
| 729 : | UNTIL | ||
| 730 : | jwilke | 1.52 | 2 cells + count |
| 731 : | TWarnings @ Exists-Warnings @ and | ||
| 732 : | IF warnhead type ." exists" | ||
| 733 : | ELSE 2drop THEN | ||
| 734 : | drop swap >link ! | ||
| 735 : | pazsan | 1.24 | ELSE true abort" CROSS: Ghostnames inconsistent " |
| 736 : | anton | 1.1 | THEN ; |
| 737 : | |||
| 738 : | : resolve ( ghost tcfa -- ) | ||
| 739 : | jwilke | 1.52 | \ resolve referencies to ghost with tcfa |
| 740 : | over forward? 0= IF exists EXIT THEN | ||
| 741 : | resolve-loop over >link ! <res> swap >magic ! | ||
| 742 : | ['] noop IS resolve-warning | ||
| 743 : | ; | ||
| 744 : | anton | 1.1 | |
| 745 : | \ gexecute ghost, 01nov92py | ||
| 746 : | |||
| 747 : | jwilke | 1.52 | : is-forward ( ghost -- ) |
| 748 : | \ >link dup @ there rot ! T A, H ; | ||
| 749 : | 0 refered -1 colon, ; | ||
| 750 : | |||
| 751 : | : is-resolved ( ghost -- ) | ||
| 752 : | >link @ colon, ; \ compile-call | ||
| 753 : | |||
| 754 : | : gexecute ( ghost -- ) | ||
| 755 : | dup @ <fwd> = IF is-forward ELSE is-resolved THEN ; | ||
| 756 : | |||
| 757 : | : addr, ( ghost -- ) | ||
| 758 : | dup @ <fwd> = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; | ||
| 759 : | |||
| 760 : | \ !! : ghost, ghost gexecute ; | ||
| 761 : | anton | 1.1 | |
| 762 : | \ .unresolved 11may93jaw | ||
| 763 : | |||
| 764 : | variable ResolveFlag | ||
| 765 : | |||
| 766 : | \ ?touched 11may93jaw | ||
| 767 : | |||
| 768 : | jwilke | 1.52 | : ?touched ( ghost -- flag ) dup forward? swap >link @ |
| 769 : | anton | 1.1 | 0 <> and ; |
| 770 : | |||
| 771 : | : ?resolved ( ghostname -- ) | ||
| 772 : | dup cell+ @ ?touched | ||
| 773 : | IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ; | ||
| 774 : | |||
| 775 : | >MINIMAL | ||
| 776 : | : .unresolved ( -- ) | ||
| 777 : | ResolveFlag off cr ." Unresolved: " | ||
| 778 : | Ghostnames | ||
| 779 : | BEGIN @ dup | ||
| 780 : | WHILE dup ?resolved | ||
| 781 : | anton | 1.10 | REPEAT drop ResolveFlag @ |
| 782 : | IF | ||
| 783 : | anton | 1.48 | -1 abort" Unresolved words!" |
| 784 : | anton | 1.10 | ELSE |
| 785 : | ." Nothing!" | ||
| 786 : | THEN | ||
| 787 : | cr ; | ||
| 788 : | anton | 1.1 | |
| 789 : | jwilke | 1.52 | : .stats |
| 790 : | base @ >r decimal | ||
| 791 : | cr ." named Headers: " headers-named @ . | ||
| 792 : | \ cr ." MaxRam*" ramdp @ . | ||
| 793 : | \ cr ." MaxRom*" romdp @ . | ||
| 794 : | r> base ! ; | ||
| 795 : | |||
| 796 : | anton | 1.1 | >CROSS |
| 797 : | \ Header states 12dec92py | ||
| 798 : | |||
| 799 : | : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; | ||
| 800 : | |||
| 801 : | VARIABLE ^imm | ||
| 802 : | |||
| 803 : | >TARGET | ||
| 804 : | anton | 1.36 | : immediate 40 flag! |
| 805 : | pazsan | 1.18 | ^imm @ @ dup <imm> = IF drop EXIT THEN |
| 806 : | anton | 1.1 | <res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
| 807 : | <imm> ^imm @ ! ; | ||
| 808 : | anton | 1.36 | : restrict 20 flag! ; |
| 809 : | jwilke | 1.52 | |
| 810 : | : isdoer <do:> last-header-ghost @ >magic ! ; | ||
| 811 : | anton | 1.1 | >CROSS |
| 812 : | |||
| 813 : | \ ALIAS2 ansforth conform alias 9may93jaw | ||
| 814 : | |||
| 815 : | : ALIAS2 create here 0 , DOES> @ execute ; | ||
| 816 : | \ usage: | ||
| 817 : | pazsan | 1.18 | \ ' <name> alias2 bla ! |
| 818 : | anton | 1.1 | |
| 819 : | \ Target Header Creation 01nov92py | ||
| 820 : | |||
| 821 : | jwilke | 1.52 | >TARGET |
| 822 : | anton | 1.1 | : string, ( addr count -- ) |
| 823 : | pazsan | 1.28 | dup T c, H bounds ?DO I c@ T c, H LOOP ; |
| 824 : | jwilke | 1.52 | : name, ( "name" -- ) bl word count T string, cfalign H ; |
| 825 : | anton | 1.1 | : view, ( -- ) ( dummy ) ; |
| 826 : | jwilke | 1.52 | >CROSS |
| 827 : | anton | 1.1 | |
| 828 : | pazsan | 1.25 | \ Target Document Creation (goes to crossdoc.fd) 05jul95py |
| 829 : | |||
| 830 : | anton | 1.48 | s" doc/crossdoc.fd" r/w create-file throw value doc-file-id |
| 831 : | pazsan | 1.25 | \ contains the file-id of the documentation file |
| 832 : | |||
| 833 : | pazsan | 1.40 | : T-\G ( -- ) |
| 834 : | pazsan | 1.25 | source >in @ /string doc-file-id write-line throw |
| 835 : | pazsan | 1.40 | postpone \ ; |
| 836 : | pazsan | 1.25 | |
| 837 : | pazsan | 1.39 | Variable to-doc to-doc on |
| 838 : | pazsan | 1.25 | |
| 839 : | : cross-doc-entry ( -- ) | ||
| 840 : | to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header | ||
| 841 : | IF | ||
| 842 : | s" " doc-file-id write-line throw | ||
| 843 : | s" make-doc " doc-file-id write-file throw | ||
| 844 : | tlast @ >image count $1F and doc-file-id write-file throw | ||
| 845 : | >in @ | ||
| 846 : | [char] ( parse 2drop | ||
| 847 : | [char] ) parse doc-file-id write-file throw | ||
| 848 : | s" )" doc-file-id write-file throw | ||
| 849 : | [char] \ parse 2drop | ||
| 850 : | pazsan | 1.40 | T-\G |
| 851 : | pazsan | 1.25 | >in ! |
| 852 : | pazsan | 1.39 | THEN ; |
| 853 : | pazsan | 1.25 | |
| 854 : | pazsan | 1.28 | \ Target TAGS creation |
| 855 : | |||
| 856 : | pazsan | 1.39 | s" kernel.TAGS" r/w create-file throw value tag-file-id |
| 857 : | pazsan | 1.28 | \ contains the file-id of the tags file |
| 858 : | |||
| 859 : | Create tag-beg 2 c, 7F c, bl c, | ||
| 860 : | Create tag-end 2 c, bl c, 01 c, | ||
| 861 : | Create tag-bof 1 c, 0C c, | ||
| 862 : | |||
| 863 : | 2variable last-loadfilename 0 0 last-loadfilename 2! | ||
| 864 : | |||
| 865 : | : put-load-file-name ( -- ) | ||
| 866 : | loadfilename 2@ last-loadfilename 2@ d<> | ||
| 867 : | IF | ||
| 868 : | tag-bof count tag-file-id write-line throw | ||
| 869 : | anton | 1.31 | sourcefilename 2dup |
| 870 : | pazsan | 1.28 | tag-file-id write-file throw |
| 871 : | last-loadfilename 2! | ||
| 872 : | s" ,0" tag-file-id write-line throw | ||
| 873 : | THEN ; | ||
| 874 : | |||
| 875 : | : cross-tag-entry ( -- ) | ||
| 876 : | tlast @ 0<> \ not an anonymous (i.e. noname) header | ||
| 877 : | IF | ||
| 878 : | put-load-file-name | ||
| 879 : | source >in @ min tag-file-id write-file throw | ||
| 880 : | tag-beg count tag-file-id write-file throw | ||
| 881 : | tlast @ >image count $1F and tag-file-id write-file throw | ||
| 882 : | tag-end count tag-file-id write-file throw | ||
| 883 : | anton | 1.31 | base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw |
| 884 : | pazsan | 1.28 | \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw |
| 885 : | s" ,0" tag-file-id write-line throw | ||
| 886 : | base ! | ||
| 887 : | THEN ; | ||
| 888 : | |||
| 889 : | pazsan | 1.43 | \ Check for words |
| 890 : | |||
| 891 : | Defer skip? ' false IS skip? | ||
| 892 : | |||
| 893 : | : defined? ( -- flag ) \ name | ||
| 894 : | jwilke | 1.52 | ghost forward? 0= ; |
| 895 : | pazsan | 1.43 | |
| 896 : | : needed? ( -- flag ) \ name | ||
| 897 : | anton | 1.48 | \G returns a false flag when |
| 898 : | \G a word is not defined | ||
| 899 : | \G a forward reference exists | ||
| 900 : | \G so the definition is not skipped! | ||
| 901 : | bl word gfind | ||
| 902 : | jwilke | 1.52 | IF dup forward? |
| 903 : | anton | 1.48 | nip |
| 904 : | 0= | ||
| 905 : | ELSE drop true THEN ; | ||
| 906 : | pazsan | 1.43 | |
| 907 : | pazsan | 1.44 | : doer? ( -- flag ) \ name |
| 908 : | ghost >magic @ <do:> = ; | ||
| 909 : | |||
| 910 : | pazsan | 1.43 | : skip-defs ( -- ) |
| 911 : | BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; | ||
| 912 : | |||
| 913 : | pazsan | 1.28 | \ Target header creation |
| 914 : | |||
| 915 : | jwilke | 1.52 | |
| 916 : | anton | 1.1 | VARIABLE CreateFlag CreateFlag off |
| 917 : | |||
| 918 : | jwilke | 1.52 | : 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ; |
| 919 : | : .sym | ||
| 920 : | bounds | ||
| 921 : | DO I c@ dup | ||
| 922 : | CASE '/ OF drop ." \/" ENDOF | ||
| 923 : | '\ OF drop ." \\" ENDOF | ||
| 924 : | dup OF emit ENDOF | ||
| 925 : | ENDCASE | ||
| 926 : | LOOP ; | ||
| 927 : | |||
| 928 : | pazsan | 1.43 | : (Theader ( "name" -- ghost ) |
| 929 : | \ >in @ bl word count type 2 spaces >in ! | ||
| 930 : | jwilke | 1.52 | \ wordheaders will always be compiled to rom |
| 931 : | switchrom | ||
| 932 : | pazsan | 1.43 | T align H view, |
| 933 : | anton | 1.1 | tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! |
| 934 : | jwilke | 1.52 | 1 headers-named +! \ Statistic |
| 935 : | >in @ T name, H >in ! T here H tlastcfa ! | ||
| 936 : | \ Symbol table | ||
| 937 : | \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! | ||
| 938 : | anton | 1.1 | CreateFlag @ IF |
| 939 : | pazsan | 1.18 | >in @ alias2 swap >in ! \ create alias in target |
| 940 : | >in @ ghost swap >in ! | ||
| 941 : | swap also ghosts ' previous swap ! \ tick ghost and store in alias | ||
| 942 : | CreateFlag off | ||
| 943 : | anton | 1.1 | ELSE ghost THEN |
| 944 : | jwilke | 1.52 | dup Last-Header-Ghost ! |
| 945 : | anton | 1.1 | dup >magic ^imm ! \ a pointer for immediate |
| 946 : | Already @ IF dup >end tdoes ! | ||
| 947 : | ELSE 0 tdoes ! THEN | ||
| 948 : | pazsan | 1.25 | 80 flag! |
| 949 : | pazsan | 1.28 | cross-doc-entry cross-tag-entry ; |
| 950 : | anton | 1.1 | |
| 951 : | VARIABLE ;Resolve 1 cells allot | ||
| 952 : | jwilke | 1.52 | \ this is the resolver information from ":" |
| 953 : | \ resolving is done by ";" | ||
| 954 : | anton | 1.1 | |
| 955 : | pazsan | 1.11 | : Theader ( "name" -- ghost ) |
| 956 : | (THeader dup there resolve 0 ;Resolve ! ; | ||
| 957 : | anton | 1.1 | |
| 958 : | >TARGET | ||
| 959 : | : Alias ( cfa -- ) \ name | ||
| 960 : | pazsan | 1.43 | >in @ skip? IF 2drop EXIT THEN >in ! |
| 961 : | dup 0< has-prims 0= and | ||
| 962 : | IF | ||
| 963 : | ." needs prim: " >in @ bl word count type >in ! cr | ||
| 964 : | THEN | ||
| 965 : | (THeader over resolve T A, H 80 flag! ; | ||
| 966 : | pazsan | 1.42 | : Alias: ( cfa -- ) \ name |
| 967 : | pazsan | 1.43 | >in @ skip? IF 2drop EXIT THEN >in ! |
| 968 : | dup 0< has-prims 0= and | ||
| 969 : | IF | ||
| 970 : | ." needs doer: " >in @ bl word count type >in ! cr | ||
| 971 : | THEN | ||
| 972 : | ghost tuck swap resolve <do:> swap >magic ! ; | ||
| 973 : | anton | 1.1 | >CROSS |
| 974 : | |||
| 975 : | \ Conditionals and Comments 11may93jaw | ||
| 976 : | |||
| 977 : | : ;Cond | ||
| 978 : | postpone ; | ||
| 979 : | swap ! ; immediate | ||
| 980 : | |||
| 981 : | : Cond: ( -- ) \ name {code } ; | ||
| 982 : | atonce on | ||
| 983 : | ghost | ||
| 984 : | >exec | ||
| 985 : | :NONAME ; | ||
| 986 : | |||
| 987 : | : restrict? ( -- ) | ||
| 988 : | \ aborts on interprete state - ae | ||
| 989 : | state @ 0= ABORT" CROSS: Restricted" ; | ||
| 990 : | |||
| 991 : | : Comment ( -- ) | ||
| 992 : | >in @ atonce on ghost swap >in ! ' swap >exec ! ; | ||
| 993 : | |||
| 994 : | Comment ( Comment \ | ||
| 995 : | |||
| 996 : | \ compile 10may93jaw | ||
| 997 : | |||
| 998 : | : compile ( -- ) \ name | ||
| 999 : | restrict? | ||
| 1000 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile " |
| 1001 : | anton | 1.1 | 0> ( immediate? ) |
| 1002 : | IF >exec @ compile, | ||
| 1003 : | ELSE postpone literal postpone gexecute THEN ; | ||
| 1004 : | immediate | ||
| 1005 : | |||
| 1006 : | jwilke | 1.52 | : [G'] |
| 1007 : | \G ticks a ghost and returns its address | ||
| 1008 : | bl word gfind 0= ABORT" CROSS: Ghost don't exists" | ||
| 1009 : | state @ | ||
| 1010 : | IF postpone literal | ||
| 1011 : | THEN ; immediate | ||
| 1012 : | |||
| 1013 : | : ghost>cfa | ||
| 1014 : | dup forward? ABORT" CROSS: forward " >link @ ; | ||
| 1015 : | |||
| 1016 : | >TARGET | ||
| 1017 : | |||
| 1018 : | : ' ( -- cfa ) | ||
| 1019 : | \ returns the target-cfa of a ghost | ||
| 1020 : | bl word gfind 0= ABORT" CROSS: Ghost don't exists" | ||
| 1021 : | ghost>cfa ; | ||
| 1022 : | |||
| 1023 : | Cond: ['] T ' H alit, ;Cond | ||
| 1024 : | |||
| 1025 : | >CROSS | ||
| 1026 : | |||
| 1027 : | : [T'] | ||
| 1028 : | \ returns the target-cfa of a ghost, or compiles it as literal | ||
| 1029 : | postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate | ||
| 1030 : | pazsan | 1.42 | |
| 1031 : | jwilke | 1.52 | \ \ threading modell 13dec92py |
| 1032 : | \ modularized 14jun97jaw | ||
| 1033 : | |||
| 1034 : | : fillcfa ( usedcells -- ) | ||
| 1035 : | T cells H xt>body swap - 0 ?DO 0 T c, H LOOP ; | ||
| 1036 : | |||
| 1037 : | : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H | ||
| 1038 : | |||
| 1039 : | : (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, | ||
| 1040 : | |||
| 1041 : | : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, | ||
| 1042 : | |||
| 1043 : | : (doprim,) ( -- ) | ||
| 1044 : | there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) IS doprim, | ||
| 1045 : | |||
| 1046 : | : (doeshandler,) ( -- ) | ||
| 1047 : | T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) IS doeshandler, | ||
| 1048 : | |||
| 1049 : | : (dodoes,) ( does-action-ghost -- ) | ||
| 1050 : | ]comp [G'] :dodoes gexecute comp[ | ||
| 1051 : | addr, | ||
| 1052 : | T here H tcell - reloff 2 fillcfa ; ' (dodoes,) IS dodoes, | ||
| 1053 : | |||
| 1054 : | : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, | ||
| 1055 : | |||
| 1056 : | : (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit, | ||
| 1057 : | |||
| 1058 : | : (fini,) compile ;s ; ' (fini,) IS fini, | ||
| 1059 : | pazsan | 1.42 | |
| 1060 : | pazsan | 1.43 | [IFUNDEF] (code) |
| 1061 : | Defer (code) | ||
| 1062 : | Defer (end-code) | ||
| 1063 : | [THEN] | ||
| 1064 : | |||
| 1065 : | anton | 1.1 | >TARGET |
| 1066 : | pazsan | 1.43 | : Code |
| 1067 : | jwilke | 1.52 | defempty? |
| 1068 : | anton | 1.48 | (THeader there resolve |
| 1069 : | [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF] | ||
| 1070 : | jwilke | 1.52 | doprim, |
| 1071 : | anton | 1.48 | [THEN] |
| 1072 : | depth (code) ; | ||
| 1073 : | pazsan | 1.43 | |
| 1074 : | : Code: | ||
| 1075 : | jwilke | 1.52 | defempty? |
| 1076 : | anton | 1.48 | ghost dup there ca>native resolve <do:> swap >magic ! |
| 1077 : | pazsan | 1.43 | depth (code) ; |
| 1078 : | |||
| 1079 : | : end-code | ||
| 1080 : | jwilke | 1.52 | (end-code) |
| 1081 : | pazsan | 1.43 | depth ?dup IF 1- <> ABORT" CROSS: Stack changed" |
| 1082 : | ELSE true ABORT" CROSS: Stack empty" THEN | ||
| 1083 : | jwilke | 1.52 | ; |
| 1084 : | anton | 1.14 | |
| 1085 : | Cond: chars ;Cond | ||
| 1086 : | anton | 1.1 | |
| 1087 : | >CROSS | ||
| 1088 : | jwilke | 1.52 | |
| 1089 : | anton | 1.1 | \ tLiteral 12dec92py |
| 1090 : | |||
| 1091 : | >TARGET | ||
| 1092 : | pazsan | 1.40 | Cond: \G T-\G ;Cond |
| 1093 : | |||
| 1094 : | anton | 1.1 | Cond: Literal ( n -- ) restrict? lit, ;Cond |
| 1095 : | Cond: ALiteral ( n -- ) restrict? alit, ;Cond | ||
| 1096 : | |||
| 1097 : | : Char ( "<char>" -- ) bl word char+ c@ ; | ||
| 1098 : | Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond | ||
| 1099 : | |||
| 1100 : | pazsan | 1.43 | \ some special literals 27jan97jaw |
| 1101 : | |||
| 1102 : | jwilke | 1.52 | \ !! Known Bug: Special Literals and plug-ins work only correct |
| 1103 : | \ on 16 and 32 Bit Targets and 32 Bit Hosts! | ||
| 1104 : | |||
| 1105 : | pazsan | 1.43 | Cond: MAXU |
| 1106 : | jwilke | 1.52 | restrict? |
| 1107 : | tcell 1 cells u> | ||
| 1108 : | IF compile lit tcell 0 ?DO FF T c, H LOOP | ||
| 1109 : | ELSE $ffffffff lit, THEN | ||
| 1110 : | ;Cond | ||
| 1111 : | pazsan | 1.43 | |
| 1112 : | Cond: MINI | ||
| 1113 : | jwilke | 1.52 | restrict? |
| 1114 : | tcell 1 cells u> | ||
| 1115 : | IF compile lit bigendian | ||
| 1116 : | IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP | ||
| 1117 : | ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H | ||
| 1118 : | THEN | ||
| 1119 : | ELSE tcell 2 = IF $8000 ELSE $80000000 THEN lit, THEN | ||
| 1120 : | ;Cond | ||
| 1121 : | pazsan | 1.43 | |
| 1122 : | Cond: MAXI | ||
| 1123 : | jwilke | 1.52 | restrict? |
| 1124 : | tcell 1 cells u> | ||
| 1125 : | IF compile lit bigendian | ||
| 1126 : | IF 7F T c, H tcell 1 ?DO FF T c, H LOOP | ||
| 1127 : | ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H | ||
| 1128 : | THEN | ||
| 1129 : | ELSE tcell 2 = IF $7fff ELSE $7fffffff THEN lit, THEN | ||
| 1130 : | pazsan | 1.43 | ;Cond |
| 1131 : | |||
| 1132 : | anton | 1.1 | >CROSS |
| 1133 : | \ Target compiling loop 12dec92py | ||
| 1134 : | \ ">tib trick thrown out 10may93jaw | ||
| 1135 : | \ number? defined at the top 11may93jaw | ||
| 1136 : | |||
| 1137 : | \ compiled word might leave items on stack! | ||
| 1138 : | : tcom ( in name -- ) | ||
| 1139 : | gfind ?dup IF 0> IF nip >exec @ execute | ||
| 1140 : | ELSE nip gexecute THEN EXIT THEN | ||
| 1141 : | number? dup IF 0> IF swap lit, THEN lit, drop | ||
| 1142 : | ELSE 2drop >in ! | ||
| 1143 : | ghost gexecute THEN ; | ||
| 1144 : | |||
| 1145 : | >TARGET | ||
| 1146 : | \ : ; DOES> 13dec92py | ||
| 1147 : | \ ] 9may93py/jaw | ||
| 1148 : | |||
| 1149 : | : ] state on | ||
| 1150 : | BEGIN | ||
| 1151 : | pazsan | 1.13 | BEGIN >in @ bl word |
| 1152 : | anton | 1.1 | dup c@ 0= WHILE 2drop refill 0= |
| 1153 : | ABORT" CROSS: End of file while target compiling" | ||
| 1154 : | REPEAT | ||
| 1155 : | tcom | ||
| 1156 : | state @ | ||
| 1157 : | 0= | ||
| 1158 : | UNTIL ; | ||
| 1159 : | |||
| 1160 : | \ by the way: defining a second interpreter (a compiler-)loop | ||
| 1161 : | \ is not allowed if a system should be ans conform | ||
| 1162 : | |||
| 1163 : | : : ( -- colon-sys ) \ Name | ||
| 1164 : | jwilke | 1.52 | defempty? |
| 1165 : | constflag off \ don't let this flag work over colon defs | ||
| 1166 : | \ just to go sure nothing unwanted happens | ||
| 1167 : | pazsan | 1.43 | >in @ skip? IF drop skip-defs EXIT THEN >in ! |
| 1168 : | anton | 1.1 | (THeader ;Resolve ! there ;Resolve cell+ ! |
| 1169 : | jwilke | 1.52 | docol, ]comp depth T ] H ; |
| 1170 : | anton | 1.1 | |
| 1171 : | pazsan | 1.37 | : :noname ( -- colon-sys ) |
| 1172 : | jwilke | 1.52 | T cfalign H there docol, 0 ;Resolve ! depth T ] H ; |
| 1173 : | pazsan | 1.37 | |
| 1174 : | pazsan | 1.2 | Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
| 1175 : | anton | 1.6 | |
| 1176 : | Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond | ||
| 1177 : | pazsan | 1.2 | |
| 1178 : | jwilke | 1.52 | >CROSS |
| 1179 : | : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT" | ||
| 1180 : | ;Resolve cell+ @ ; | ||
| 1181 : | |||
| 1182 : | >TARGET | ||
| 1183 : | |||
| 1184 : | Cond: recurse ( -- ) Last-Ghost @ gexecute ;Cond | ||
| 1185 : | |||
| 1186 : | anton | 1.1 | Cond: ; ( -- ) restrict? |
| 1187 : | depth ?dup IF 1- <> ABORT" CROSS: Stack changed" | ||
| 1188 : | ELSE true ABORT" CROSS: Stack empty" THEN | ||
| 1189 : | jwilke | 1.52 | fini, |
| 1190 : | comp[ | ||
| 1191 : | state off | ||
| 1192 : | anton | 1.1 | ;Resolve @ |
| 1193 : | IF ;Resolve @ ;Resolve cell+ @ resolve THEN | ||
| 1194 : | ;Cond | ||
| 1195 : | Cond: [ restrict? state off ;Cond | ||
| 1196 : | |||
| 1197 : | >CROSS | ||
| 1198 : | jwilke | 1.52 | : !does ( does-action -- ) |
| 1199 : | \ !! zusammenziehen und dodoes, machen! | ||
| 1200 : | pazsan | 1.42 | tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ; |
| 1201 : | jwilke | 1.52 | \ !! geht so nicht, da dodoes, ghost will! |
| 1202 : | \ tlastcfa @ >tempdp dodoes, tempdp> ; | ||
| 1203 : | anton | 1.1 | |
| 1204 : | >TARGET | ||
| 1205 : | Cond: DOES> restrict? | ||
| 1206 : | jwilke | 1.52 | compile (does>) doeshandler, |
| 1207 : | \ resolve words made by builders | ||
| 1208 : | tdoes @ ?dup IF @ T here H resolve THEN | ||
| 1209 : | anton | 1.1 | ;Cond |
| 1210 : | jwilke | 1.52 | : DOES> switchrom doeshandler, T here H !does depth T ] H ; |
| 1211 : | anton | 1.1 | |
| 1212 : | >CROSS | ||
| 1213 : | \ Creation 01nov92py | ||
| 1214 : | |||
| 1215 : | \ Builder 11may93jaw | ||
| 1216 : | |||
| 1217 : | jwilke | 1.52 | : Builder ( Create-xt do:-xt "name" -- ) |
| 1218 : | \ builds up a builder in current vocabulary | ||
| 1219 : | \ create-xt is executed when word is interpreted | ||
| 1220 : | \ do:-xt is executet when the created word from builder is executed | ||
| 1221 : | \ for do:-xt an additional entry after the normal ghost-enrys is used | ||
| 1222 : | |||
| 1223 : | anton | 1.1 | >in @ alias2 swap dup >in ! >r >r |
| 1224 : | Make-Ghost rot swap >exec ! , | ||
| 1225 : | r> r> >in ! | ||
| 1226 : | pazsan | 1.11 | also ghosts ' previous swap ! ; |
| 1227 : | \ DOES> dup >exec @ execute ; | ||
| 1228 : | anton | 1.1 | |
| 1229 : | jwilke | 1.52 | : gdoes, ( ghost -- ) |
| 1230 : | \ makes the codefield for a word that is built | ||
| 1231 : | >end @ dup forward? 0= | ||
| 1232 : | IF | ||
| 1233 : | pazsan | 1.42 | dup >magic @ <do:> = |
| 1234 : | jwilke | 1.52 | IF doer, EXIT THEN |
| 1235 : | THEN | ||
| 1236 : | \ compile :dodoes gexecute | ||
| 1237 : | \ T here H tcell - reloff | ||
| 1238 : | dodoes, | ||
| 1239 : | ; | ||
| 1240 : | anton | 1.1 | |
| 1241 : | jwilke | 1.52 | : TCreate ( <name> -- ) |
| 1242 : | executed-ghost @ | ||
| 1243 : | anton | 1.1 | CreateFlag on |
| 1244 : | jwilke | 1.52 | create-forward-warn |
| 1245 : | IF ['] reswarn-forward IS resolve-warning THEN | ||
| 1246 : | pazsan | 1.11 | Theader >r dup gdoes, |
| 1247 : | jwilke | 1.52 | \ stores execution symantic in the built word |
| 1248 : | >end @ >exec @ r> >exec ! ; | ||
| 1249 : | |||
| 1250 : | : RTCreate ( <name> -- ) | ||
| 1251 : | \ creates a new word with code-field in ram | ||
| 1252 : | executed-ghost @ | ||
| 1253 : | CreateFlag on | ||
| 1254 : | create-forward-warn | ||
| 1255 : | IF ['] reswarn-forward IS resolve-warning THEN | ||
| 1256 : | \ make Alias | ||
| 1257 : | (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost ) | ||
| 1258 : | \ store poiter to code-field | ||
| 1259 : | switchram T cfalign H | ||
| 1260 : | there swap T ! H | ||
| 1261 : | there tlastcfa ! | ||
| 1262 : | dup there resolve 0 ;Resolve ! | ||
| 1263 : | >r dup gdoes, | ||
| 1264 : | pazsan | 1.11 | >end @ >exec @ r> >exec ! ; |
| 1265 : | anton | 1.1 | |
| 1266 : | : Build: ( -- [xt] [colon-sys] ) | ||
| 1267 : | jwilke | 1.52 | :noname postpone TCreate ; |
| 1268 : | |||
| 1269 : | : BuildSmart: ( -- [xt] [colon-sys] ) | ||
| 1270 : | :noname | ||
| 1271 : | [ has-rom [IF] ] | ||
| 1272 : | postpone RTCreate | ||
| 1273 : | [ [ELSE] ] | ||
| 1274 : | postpone TCreate | ||
| 1275 : | [ [THEN] ] ; | ||
| 1276 : | anton | 1.1 | |
| 1277 : | : gdoes> ( ghost -- addr flag ) | ||
| 1278 : | jwilke | 1.52 | executed-ghost @ |
| 1279 : | anton | 1.1 | state @ IF gexecute true EXIT THEN |
| 1280 : | jwilke | 1.52 | >link @ T >body H false ; |
| 1281 : | anton | 1.1 | |
| 1282 : | \ DO: ;DO 11may93jaw | ||
| 1283 : | \ changed to ?EXIT 10may93jaw | ||
| 1284 : | |||
| 1285 : | : DO: ( -- addr [xt] [colon-sys] ) | ||
| 1286 : | here ghostheader | ||
| 1287 : | pazsan | 1.11 | :noname postpone gdoes> postpone ?EXIT ; |
| 1288 : | anton | 1.1 | |
| 1289 : | pazsan | 1.42 | : by: ( -- addr [xt] [colon-sys] ) \ name |
| 1290 : | ghost | ||
| 1291 : | :noname postpone gdoes> postpone ?EXIT ; | ||
| 1292 : | |||
| 1293 : | jwilke | 1.52 | : ;DO ( addr [xt] [colon-sys] -- addr ) |
| 1294 : | anton | 1.1 | postpone ; ( S addr xt ) |
| 1295 : | over >exec ! ; immediate | ||
| 1296 : | |||
| 1297 : | : by ( -- addr ) \ Name | ||
| 1298 : | ghost >end @ ; | ||
| 1299 : | |||
| 1300 : | >TARGET | ||
| 1301 : | \ Variables and Constants 05dec92py | ||
| 1302 : | |||
| 1303 : | jwilke | 1.52 | Build: ( n -- ) ; |
| 1304 : | by: :docon ( ghost -- n ) T @ H ;DO | ||
| 1305 : | Builder (Constant) | ||
| 1306 : | |||
| 1307 : | Build: ( n -- ) T , H ; | ||
| 1308 : | by (Constant) | ||
| 1309 : | Builder Constant | ||
| 1310 : | |||
| 1311 : | Build: ( n -- ) T A, H ; | ||
| 1312 : | by (Constant) | ||
| 1313 : | Builder AConstant | ||
| 1314 : | |||
| 1315 : | Build: ( d -- ) T , , H ; | ||
| 1316 : | DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO | ||
| 1317 : | Builder 2Constant | ||
| 1318 : | |||
| 1319 : | BuildSmart: ; | ||
| 1320 : | pazsan | 1.42 | by: :dovar ( ghost -- addr ) ;DO |
| 1321 : | anton | 1.1 | Builder Create |
| 1322 : | |||
| 1323 : | jwilke | 1.52 | has-rom [IF] |
| 1324 : | Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; | ||
| 1325 : | by (Constant) | ||
| 1326 : | Builder Variable | ||
| 1327 : | [ELSE] | ||
| 1328 : | anton | 1.1 | Build: T 0 , H ; |
| 1329 : | by Create | ||
| 1330 : | Builder Variable | ||
| 1331 : | jwilke | 1.52 | [THEN] |
| 1332 : | anton | 1.1 | |
| 1333 : | jwilke | 1.52 | has-rom [IF] |
| 1334 : | Build: ( n -- ) T here 0 , H switchram T align here swap ! 0 , H ( switchrom ) ; | ||
| 1335 : | by (Constant) | ||
| 1336 : | Builder AVariable | ||
| 1337 : | [ELSE] | ||
| 1338 : | anton | 1.1 | Build: T 0 A, H ; |
| 1339 : | by Create | ||
| 1340 : | Builder AVariable | ||
| 1341 : | jwilke | 1.52 | [THEN] |
| 1342 : | anton | 1.1 | |
| 1343 : | pazsan | 1.3 | \ User variables 04may94py |
| 1344 : | |||
| 1345 : | >CROSS | ||
| 1346 : | Variable tup 0 tup ! | ||
| 1347 : | Variable tudp 0 tudp ! | ||
| 1348 : | : u, ( n -- udp ) | ||
| 1349 : | tup @ tudp @ + T ! H | ||
| 1350 : | pazsan | 1.19 | tudp @ dup T cell+ H tudp ! ; |
| 1351 : | pazsan | 1.3 | : au, ( n -- udp ) |
| 1352 : | tup @ tudp @ + T A! H | ||
| 1353 : | pazsan | 1.19 | tudp @ dup T cell+ H tudp ! ; |
| 1354 : | pazsan | 1.3 | >TARGET |
| 1355 : | |||
| 1356 : | Build: T 0 u, , H ; | ||
| 1357 : | pazsan | 1.42 | by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO |
| 1358 : | anton | 1.1 | Builder User |
| 1359 : | |||
| 1360 : | pazsan | 1.3 | Build: T 0 u, , 0 u, drop H ; |
| 1361 : | by User | ||
| 1362 : | anton | 1.1 | Builder 2User |
| 1363 : | |||
| 1364 : | pazsan | 1.3 | Build: T 0 au, , H ; |
| 1365 : | by User | ||
| 1366 : | anton | 1.1 | Builder AUser |
| 1367 : | |||
| 1368 : | jwilke | 1.52 | BuildSmart: T , H ; |
| 1369 : | pazsan | 1.44 | by (Constant) |
| 1370 : | anton | 1.1 | Builder Value |
| 1371 : | |||
| 1372 : | jwilke | 1.52 | BuildSmart: T A, H ; |
| 1373 : | pazsan | 1.44 | by (Constant) |
| 1374 : | pazsan | 1.32 | Builder AValue |
| 1375 : | |||
| 1376 : | jwilke | 1.52 | BuildSmart: ( -- ) [T'] noop T A, H ; |
| 1377 : | pazsan | 1.42 | by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
| 1378 : | anton | 1.1 | Builder Defer |
| 1379 : | pazsan | 1.37 | |
| 1380 : | jwilke | 1.52 | BuildSmart: ( inter comp -- ) swap T immediate A, A, H ; |
| 1381 : | pazsan | 1.37 | DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
| 1382 : | anton | 1.38 | Builder interpret/compile: |
| 1383 : | pazsan | 1.24 | |
| 1384 : | \ Sturctures 23feb95py | ||
| 1385 : | |||
| 1386 : | >CROSS | ||
| 1387 : | : nalign ( addr1 n -- addr2 ) | ||
| 1388 : | \ addr2 is the aligned version of addr1 wrt the alignment size n | ||
| 1389 : | 1- tuck + swap invert and ; | ||
| 1390 : | >TARGET | ||
| 1391 : | |||
| 1392 : | pazsan | 1.44 | Build: ; |
| 1393 : | by: :dofield T @ H + ;DO | ||
| 1394 : | Builder (Field) | ||
| 1395 : | |||
| 1396 : | anton | 1.51 | Build: ( align1 offset1 align size "name" -- align2 offset2 ) |
| 1397 : | rot dup T , H ( align1 align size offset1 ) | ||
| 1398 : | + >r nalign r> ; | ||
| 1399 : | pazsan | 1.44 | by (Field) |
| 1400 : | pazsan | 1.24 | Builder Field |
| 1401 : | |||
| 1402 : | anton | 1.51 | : struct T 1 chars 0 H ; |
| 1403 : | pazsan | 1.24 | : end-struct T 2Constant H ; |
| 1404 : | |||
| 1405 : | jwilke | 1.52 | : cell% ( n -- size align ) |
| 1406 : | anton | 1.51 | T 1 cells H dup ; |
| 1407 : | pazsan | 1.24 | |
| 1408 : | \ ' 2Constant Alias2 end-struct | ||
| 1409 : | \ 0 1 T Chars H 2Constant struct | ||
| 1410 : | anton | 1.1 | |
| 1411 : | jwilke | 1.52 | 0 [IF] |
| 1412 : | |||
| 1413 : | anton | 1.1 | \ structural conditionals 17dec92py |
| 1414 : | |||
| 1415 : | >CROSS | ||
| 1416 : | : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; | ||
| 1417 : | : sys? ( sys -- sys ) dup 0= ?struc ; | ||
| 1418 : | jwilke | 1.52 | : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
| 1419 : | |||
| 1420 : | : branchoffset ( src dest -- ) - ; | ||
| 1421 : | : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; | ||
| 1422 : | : <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ; | ||
| 1423 : | anton | 1.1 | >TARGET |
| 1424 : | |||
| 1425 : | \ Structural Conditionals 12dec92py | ||
| 1426 : | |||
| 1427 : | Cond: BUT restrict? sys? swap ;Cond | ||
| 1428 : | Cond: YET restrict? sys? dup ;Cond | ||
| 1429 : | |||
| 1430 : | >CROSS | ||
| 1431 : | Variable tleavings | ||
| 1432 : | >TARGET | ||
| 1433 : | |||
| 1434 : | Cond: DONE ( addr -- ) restrict? tleavings @ | ||
| 1435 : | BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT | ||
| 1436 : | tleavings ! drop ;Cond | ||
| 1437 : | |||
| 1438 : | >CROSS | ||
| 1439 : | : (leave T here H tleavings @ T , H tleavings ! ; | ||
| 1440 : | >TARGET | ||
| 1441 : | |||
| 1442 : | Cond: LEAVE restrict? compile branch (leave ;Cond | ||
| 1443 : | Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond | ||
| 1444 : | |||
| 1445 : | \ Structural Conditionals 12dec92py | ||
| 1446 : | |||
| 1447 : | Cond: AHEAD restrict? compile branch >mark ;Cond | ||
| 1448 : | Cond: IF restrict? compile ?branch >mark ;Cond | ||
| 1449 : | jwilke | 1.52 | Cond: THEN restrict? sys? branchto, dup T @ H ?struc >resolve ;Cond |
| 1450 : | anton | 1.1 | Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond |
| 1451 : | |||
| 1452 : | jwilke | 1.52 | Cond: BEGIN restrict? T branchto, here ( dup ." B" hex. ) H ;Cond |
| 1453 : | anton | 1.1 | Cond: WHILE restrict? sys? compile IF swap ;Cond |
| 1454 : | Cond: AGAIN restrict? sys? compile branch <resolve ;Cond | ||
| 1455 : | Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond | ||
| 1456 : | Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond | ||
| 1457 : | pazsan | 1.45 | |
| 1458 : | Cond: CASE restrict? 0 ;Cond | ||
| 1459 : | jwilke | 1.52 | Cond: OF restrict? 1+ >r compile over compile = |
| 1460 : | compile IF compile drop r> ;Cond | ||
| 1461 : | Cond: ENDOF restrict? >r compile ELSE r> ;Cond | ||
| 1462 : | Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond | ||
| 1463 : | |||
| 1464 : | \ Structural Conditionals 12dec92py | ||
| 1465 : | |||
| 1466 : | Cond: DO restrict? compile (do) T here H ;Cond | ||
| 1467 : | Cond: ?DO restrict? compile (?do) T (leave here H ;Cond | ||
| 1468 : | Cond: FOR restrict? compile (for) T here H ;Cond | ||
| 1469 : | |||
| 1470 : | >CROSS | ||
| 1471 : | : loop] dup <resolve tcell - compile DONE compile unloop ; | ||
| 1472 : | >TARGET | ||
| 1473 : | |||
| 1474 : | Cond: LOOP restrict? sys? compile (loop) loop] ;Cond | ||
| 1475 : | Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond | ||
| 1476 : | Cond: NEXT restrict? sys? compile (next) loop] ;Cond | ||
| 1477 : | |||
| 1478 : | [ELSE] | ||
| 1479 : | |||
| 1480 : | \ structural conditionals 17dec92py | ||
| 1481 : | |||
| 1482 : | >CROSS | ||
| 1483 : | : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; | ||
| 1484 : | : sys? ( sys -- sys ) dup 0= ?struc ; | ||
| 1485 : | : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; | ||
| 1486 : | |||
| 1487 : | : branchoffset ( src dest -- ) - ; | ||
| 1488 : | |||
| 1489 : | : >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; | ||
| 1490 : | |||
| 1491 : | : <resolve ( sys -- ) T here ( dup ." <" hex. ) branchoffset , H ; | ||
| 1492 : | |||
| 1493 : | :noname compile branch T here branchoffset , H ; IS branch, | ||
| 1494 : | :noname compile ?branch T here branchoffset , H ; IS ?branch, | ||
| 1495 : | :noname compile branch T here 0 , H ; IS branchmark, | ||
| 1496 : | :noname compile ?branch T here 0 , H ; IS ?branchmark, | ||
| 1497 : | :noname dup T @ H ?struc T here over branchoffset swap ! H ; IS branchtoresolve, | ||
| 1498 : | :noname branchto, T here H ; IS branchtomark, | ||
| 1499 : | |||
| 1500 : | >TARGET | ||
| 1501 : | |||
| 1502 : | \ Structural Conditionals 12dec92py | ||
| 1503 : | |||
| 1504 : | Cond: BUT restrict? sys? swap ;Cond | ||
| 1505 : | Cond: YET restrict? sys? dup ;Cond | ||
| 1506 : | |||
| 1507 : | >CROSS | ||
| 1508 : | Variable tleavings | ||
| 1509 : | >TARGET | ||
| 1510 : | |||
| 1511 : | Cond: DONE ( addr -- ) restrict? tleavings @ | ||
| 1512 : | BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT | ||
| 1513 : | tleavings ! drop ;Cond | ||
| 1514 : | |||
| 1515 : | >CROSS | ||
| 1516 : | : (leave T here H tleavings @ T , H tleavings ! ; | ||
| 1517 : | >TARGET | ||
| 1518 : | |||
| 1519 : | Cond: LEAVE restrict? compile branch (leave ;Cond | ||
| 1520 : | Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond | ||
| 1521 : | |||
| 1522 : | \ Structural Conditionals 12dec92py | ||
| 1523 : | |||
| 1524 : | Cond: AHEAD restrict? branchmark, ;Cond | ||
| 1525 : | Cond: IF restrict? ?branchmark, ;Cond | ||
| 1526 : | Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond | ||
| 1527 : | Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond | ||
| 1528 : | |||
| 1529 : | Cond: BEGIN restrict? branchtomark, ;Cond | ||
| 1530 : | Cond: WHILE restrict? sys? compile IF swap ;Cond | ||
| 1531 : | Cond: AGAIN restrict? sys? branch, ;Cond | ||
| 1532 : | Cond: UNTIL restrict? sys? ?branch, ;Cond | ||
| 1533 : | Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond | ||
| 1534 : | |||
| 1535 : | Cond: CASE restrict? 0 ;Cond | ||
| 1536 : | Cond: OF restrict? 1+ >r compile over compile = | ||
| 1537 : | compile IF compile drop r> ;Cond | ||
| 1538 : | pazsan | 1.45 | Cond: ENDOF restrict? >r compile ELSE r> ;Cond |
| 1539 : | Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond | ||
| 1540 : | anton | 1.1 | |
| 1541 : | \ Structural Conditionals 12dec92py | ||
| 1542 : | |||
| 1543 : | Cond: DO restrict? compile (do) T here H ;Cond | ||
| 1544 : | anton | 1.48 | Cond: ?DO restrict? compile (?do) T (leave here H ;Cond |
| 1545 : | anton | 1.1 | Cond: FOR restrict? compile (for) T here H ;Cond |
| 1546 : | |||
| 1547 : | >CROSS | ||
| 1548 : | anton | 1.48 | : loop] dup <resolve tcell - compile DONE compile unloop ; |
| 1549 : | anton | 1.1 | >TARGET |
| 1550 : | |||
| 1551 : | Cond: LOOP restrict? sys? compile (loop) loop] ;Cond | ||
| 1552 : | Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond | ||
| 1553 : | Cond: NEXT restrict? sys? compile (next) loop] ;Cond | ||
| 1554 : | |||
| 1555 : | jwilke | 1.52 | [THEN] |
| 1556 : | |||
| 1557 : | anton | 1.1 | \ String words 23feb93py |
| 1558 : | |||
| 1559 : | jwilke | 1.52 | : ," [char] " parse T string, align H ; |
| 1560 : | anton | 1.1 | |
| 1561 : | Cond: ." restrict? compile (.") T ," H ;Cond | ||
| 1562 : | Cond: S" restrict? compile (S") T ," H ;Cond | ||
| 1563 : | Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond | ||
| 1564 : | |||
| 1565 : | Cond: IS T ' >body H compile ALiteral compile ! ;Cond | ||
| 1566 : | : IS T ' >body ! H ; | ||
| 1567 : | pazsan | 1.9 | Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
| 1568 : | : TO T ' >body ! H ; | ||
| 1569 : | anton | 1.1 | |
| 1570 : | jwilke | 1.52 | Cond: defers T ' >body @ compile, H ;Cond |
| 1571 : | : on T -1 swap ! H ; | ||
| 1572 : | : off T 0 swap ! H ; | ||
| 1573 : | |||
| 1574 : | anton | 1.1 | \ LINKED ERR" ENV" 2ENV" 18may93jaw |
| 1575 : | |||
| 1576 : | \ linked list primitive | ||
| 1577 : | : linked T here over @ A, swap ! H ; | ||
| 1578 : | jwilke | 1.52 | : chained T linked A, H ; |
| 1579 : | anton | 1.1 | |
| 1580 : | : err" s" ErrLink linked" evaluate T , H | ||
| 1581 : | jwilke | 1.52 | [char] " parse T string, align H ; |
| 1582 : | anton | 1.1 | |
| 1583 : | : env" [char] " parse s" EnvLink linked" evaluate | ||
| 1584 : | jwilke | 1.52 | T string, align , H ; |
| 1585 : | anton | 1.1 | |
| 1586 : | : 2env" [char] " parse s" EnvLink linked" evaluate | ||
| 1587 : | jwilke | 1.52 | here >r T string, align , , H |
| 1588 : | anton | 1.1 | r> dup T c@ H 80 and swap T c! H ; |
| 1589 : | |||
| 1590 : | \ compile must be last 22feb93py | ||
| 1591 : | |||
| 1592 : | Cond: compile ( -- ) restrict? \ name | ||
| 1593 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile" |
| 1594 : | anton | 1.1 | 0> IF gexecute |
| 1595 : | ELSE dup >magic @ <imm> = | ||
| 1596 : | IF gexecute | ||
| 1597 : | ELSE compile (compile) gexecute THEN THEN ;Cond | ||
| 1598 : | |||
| 1599 : | Cond: postpone ( -- ) restrict? \ name | ||
| 1600 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile" |
| 1601 : | anton | 1.1 | 0> IF gexecute |
| 1602 : | ELSE dup >magic @ <imm> = | ||
| 1603 : | IF gexecute | ||
| 1604 : | ELSE compile (compile) gexecute THEN THEN ;Cond | ||
| 1605 : | |||
| 1606 : | >MINIMAL | ||
| 1607 : | also minimal | ||
| 1608 : | \ Usefull words 13feb93py | ||
| 1609 : | |||
| 1610 : | : KB 400 * ; | ||
| 1611 : | |||
| 1612 : | \ define new [IFDEF] and [IFUNDEF] 20may93jaw | ||
| 1613 : | |||
| 1614 : | pazsan | 1.43 | : defined? defined? ; |
| 1615 : | pazsan | 1.44 | : needed? needed? ; |
| 1616 : | : doer? doer? ; | ||
| 1617 : | anton | 1.1 | |
| 1618 : | jwilke | 1.52 | \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too |
| 1619 : | |||
| 1620 : | : directive? | ||
| 1621 : | bl word count [ ' target >wordlist ] aliteral search-wordlist | ||
| 1622 : | dup IF nip THEN ; | ||
| 1623 : | |||
| 1624 : | : [IFDEF] >in @ directive? swap >in ! | ||
| 1625 : | 0= IF defined? ELSE name 2drop true THEN | ||
| 1626 : | postpone [IF] ; | ||
| 1627 : | |||
| 1628 : | pazsan | 1.43 | : [IFUNDEF] defined? 0= postpone [IF] ; |
| 1629 : | anton | 1.1 | |
| 1630 : | \ C: \- \+ Conditional Compiling 09jun93jaw | ||
| 1631 : | |||
| 1632 : | pazsan | 1.43 | : C: >in @ defined? 0= |
| 1633 : | anton | 1.1 | IF >in ! T : H |
| 1634 : | ELSE drop | ||
| 1635 : | BEGIN bl word dup c@ | ||
| 1636 : | IF count comment? s" ;" compare 0= ?EXIT | ||
| 1637 : | ELSE refill 0= ABORT" CROSS: Out of Input while C:" | ||
| 1638 : | THEN | ||
| 1639 : | AGAIN | ||
| 1640 : | THEN ; | ||
| 1641 : | |||
| 1642 : | also minimal | ||
| 1643 : | |||
| 1644 : | jwilke | 1.52 | \G doesn't skip line when bit is set in debugmask |
| 1645 : | : \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; | ||
| 1646 : | |||
| 1647 : | anton | 1.48 | \G interprets the line if word is not defined |
| 1648 : | pazsan | 1.43 | : \- defined? IF postpone \ THEN ; |
| 1649 : | anton | 1.48 | |
| 1650 : | \G interprets the line if word is defined | ||
| 1651 : | pazsan | 1.43 | : \+ defined? 0= IF postpone \ THEN ; |
| 1652 : | anton | 1.1 | |
| 1653 : | anton | 1.48 | Cond: \- \- ;Cond |
| 1654 : | Cond: \+ \+ ;Cond | ||
| 1655 : | jwilke | 1.52 | Cond: \D \D ;Cond |
| 1656 : | anton | 1.48 | |
| 1657 : | : ?? bl word find IF execute ELSE drop 0 THEN ; | ||
| 1658 : | |||
| 1659 : | : needed: | ||
| 1660 : | \G defines ghost for words that we want to be compiled | ||
| 1661 : | BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; | ||
| 1662 : | |||
| 1663 : | anton | 1.1 | : [IF] postpone [IF] ; |
| 1664 : | : [THEN] postpone [THEN] ; | ||
| 1665 : | : [ELSE] postpone [ELSE] ; | ||
| 1666 : | |||
| 1667 : | Cond: [IF] [IF] ;Cond | ||
| 1668 : | Cond: [IFDEF] [IFDEF] ;Cond | ||
| 1669 : | Cond: [IFUNDEF] [IFUNDEF] ;Cond | ||
| 1670 : | Cond: [THEN] [THEN] ;Cond | ||
| 1671 : | Cond: [ELSE] [ELSE] ;Cond | ||
| 1672 : | |||
| 1673 : | anton | 1.48 | previous |
| 1674 : | |||
| 1675 : | anton | 1.1 | \ save-cross 17mar93py |
| 1676 : | |||
| 1677 : | anton | 1.48 | >CROSS |
| 1678 : | anton | 1.34 | Create magic s" Gforth10" here over allot swap move |
| 1679 : | pazsan | 1.26 | |
| 1680 : | anton | 1.48 | char 1 bigendian + tcell + magic 7 + c! |
| 1681 : | pazsan | 1.26 | |
| 1682 : | anton | 1.34 | : save-cross ( "image-name" "binary-name" -- ) |
| 1683 : | bl parse ." Saving to " 2dup type cr | ||
| 1684 : | anton | 1.1 | w/o bin create-file throw >r |
| 1685 : | anton | 1.48 | TNIL IF |
| 1686 : | pazsan | 1.43 | s" #! " r@ write-file throw |
| 1687 : | bl parse r@ write-file throw | ||
| 1688 : | s" -i" r@ write-file throw | ||
| 1689 : | #lf r@ emit-file throw | ||
| 1690 : | r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) | ||
| 1691 : | ?do | ||
| 1692 : | bl over emit-file throw | ||
| 1693 : | loop | ||
| 1694 : | drop | ||
| 1695 : | magic 8 r@ write-file throw \ write magic | ||
| 1696 : | ELSE | ||
| 1697 : | bl parse 2drop | ||
| 1698 : | THEN | ||
| 1699 : | jwilke | 1.52 | image @ there |
| 1700 : | r@ write-file throw \ write image | ||
| 1701 : | anton | 1.48 | TNIL IF |
| 1702 : | bit$ @ there 1- tcell>bit rshift 1+ | ||
| 1703 : | pazsan | 1.16 | r@ write-file throw \ write tags |
| 1704 : | pazsan | 1.43 | THEN |
| 1705 : | anton | 1.1 | r> close-file throw ; |
| 1706 : | |||
| 1707 : | jwilke | 1.52 | : save-region ( addr len -- ) |
| 1708 : | bl parse w/o bin create-file throw >r | ||
| 1709 : | swap image @ + swap r@ write-file throw | ||
| 1710 : | r> close-file throw ; | ||
| 1711 : | |||
| 1712 : | anton | 1.1 | \ words that should be in minimal |
| 1713 : | jwilke | 1.52 | |
| 1714 : | create s-buffer 50 chars allot | ||
| 1715 : | |||
| 1716 : | anton | 1.48 | >MINIMAL |
| 1717 : | also minimal | ||
| 1718 : | anton | 1.1 | |
| 1719 : | anton | 1.48 | bigendian Constant bigendian |
| 1720 : | jwilke | 1.52 | : here there ; |
| 1721 : | : >ram >ram ; | ||
| 1722 : | : >rom >rom ; | ||
| 1723 : | : >auto >auto ; | ||
| 1724 : | : >tempdp >tempdp ; | ||
| 1725 : | : tempdp> tempdp> ; | ||
| 1726 : | : const constflag on ; | ||
| 1727 : | : warnings name 3 = 0= twarnings ! drop ; | ||
| 1728 : | |||
| 1729 : | |||
| 1730 : | anton | 1.48 | : save-cross save-cross ; |
| 1731 : | jwilke | 1.52 | : save-region save-region ; |
| 1732 : | : tdump swap >image swap dump ; | ||
| 1733 : | |||
| 1734 : | anton | 1.48 | also forth |
| 1735 : | jwilke | 1.52 | [IFDEF] Label : Label defempty? Label ; [THEN] |
| 1736 : | [IFDEF] start-macros : start-macros defempty? start-macros ; [THEN] | ||
| 1737 : | [IFDEF] builttag : builttag builttag ; [THEN] | ||
| 1738 : | anton | 1.48 | previous |
| 1739 : | |||
| 1740 : | jwilke | 1.52 | : s" [char] " parse s-buffer place s-buffer count ; \ for environment? |
| 1741 : | pazsan | 1.43 | : + + ; |
| 1742 : | jwilke | 1.52 | : 1+ 1 + ; |
| 1743 : | : 2+ 2 + ; | ||
| 1744 : | pazsan | 1.43 | : or or ; |
| 1745 : | : 1- 1- ; | ||
| 1746 : | : - - ; | ||
| 1747 : | jwilke | 1.52 | : and and ; |
| 1748 : | : or or ; | ||
| 1749 : | pazsan | 1.43 | : 2* 2* ; |
| 1750 : | : * * ; | ||
| 1751 : | : / / ; | ||
| 1752 : | : dup dup ; | ||
| 1753 : | : over over ; | ||
| 1754 : | : swap swap ; | ||
| 1755 : | : rot rot ; | ||
| 1756 : | : drop drop ; | ||
| 1757 : | : = = ; | ||
| 1758 : | : 0= 0= ; | ||
| 1759 : | : lshift lshift ; | ||
| 1760 : | : 2/ 2/ ; | ||
| 1761 : | pazsan | 1.19 | : . . ; |
| 1762 : | anton | 1.1 | |
| 1763 : | pazsan | 1.43 | : all-words ['] false IS skip? ; |
| 1764 : | : needed-words ['] needed? IS skip? ; | ||
| 1765 : | : undef-words ['] defined? IS skip? ; | ||
| 1766 : | anton | 1.1 | |
| 1767 : | pazsan | 1.40 | : \ postpone \ ; immediate |
| 1768 : | pazsan | 1.47 | : \G T-\G ; immediate |
| 1769 : | pazsan | 1.40 | : ( postpone ( ; immediate |
| 1770 : | anton | 1.1 | : include bl word count included ; |
| 1771 : | jwilke | 1.52 | : require require ; |
| 1772 : | anton | 1.1 | : .( [char] ) parse type ; |
| 1773 : | jwilke | 1.52 | : ." [char] " parse type ; |
| 1774 : | anton | 1.1 | : cr cr ; |
| 1775 : | |||
| 1776 : | : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation | ||
| 1777 : | only forth also minimal definitions | ||
| 1778 : | |||
| 1779 : | \ cross-compiler words | ||
| 1780 : | |||
| 1781 : | : decimal decimal ; | ||
| 1782 : | : hex hex ; | ||
| 1783 : | |||
| 1784 : | pazsan | 1.3 | : tudp T tudp H ; |
| 1785 : | pazsan | 1.39 | : tup T tup H ; |
| 1786 : | |||
| 1787 : | : doc-off false T to-doc H ! ; | ||
| 1788 : | : doc-on true T to-doc H ! ; | ||
| 1789 : | jwilke | 1.52 | [IFDEF] dbg : dbg dbg ; [THEN] |
| 1790 : | pazsan | 1.39 | |
| 1791 : | minimal | ||
| 1792 : | anton | 1.1 | |
| 1793 : | \ for debugging... | ||
| 1794 : | : order order ; | ||
| 1795 : | jwilke | 1.52 | : hwords words ; |
| 1796 : | : words also ghosts words previous ; | ||
| 1797 : | anton | 1.1 | : .s .s ; |
| 1798 : | : bye bye ; | ||
| 1799 : | |||
| 1800 : | \ turnkey direction | ||
| 1801 : | : H forth ; immediate | ||
| 1802 : | : T minimal ; immediate | ||
| 1803 : | : G ghosts ; immediate | ||
| 1804 : | |||
| 1805 : | : turnkey 0 set-order also Target definitions | ||
| 1806 : | also Minimal also ; | ||
| 1807 : | |||
| 1808 : | \ these ones are pefered: | ||
| 1809 : | |||
| 1810 : | : lock turnkey ; | ||
| 1811 : | : unlock forth also cross ; | ||
| 1812 : | jwilke | 1.52 | |
| 1813 : | : [[ also unlock ; | ||
| 1814 : | : ]] previous previous ; | ||
| 1815 : | anton | 1.1 | |
| 1816 : | unlock definitions also minimal | ||
| 1817 : | : lock lock ; | ||
| 1818 : | lock |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |