Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ CROSS.FS The Cross-Compiler 06oct92py |
| 2 : | pazsan | 1.15 | \ $Id: cross.fs,v 1.14 1994/10/24 19:15:53 anton Exp $ |
| 3 : | anton | 1.1 | \ Idea and implementation: Bernd Paysan (py) |
| 4 : | pazsan | 1.15 | \ Copyright 1992-94 by the GNU Forth Development Group |
| 5 : | anton | 1.1 | |
| 6 : | \ Log: | ||
| 7 : | \ changed in ; [ to state off 12may93jaw | ||
| 8 : | \ included place +place 12may93jaw | ||
| 9 : | \ for a created word (variable, constant...) | ||
| 10 : | \ is now an alias in the target voabulary. | ||
| 11 : | \ this means it is no longer necessary to | ||
| 12 : | \ switch between vocabularies for variable | ||
| 13 : | \ initialization 12may93jaw | ||
| 14 : | \ discovered error in DOES> | ||
| 15 : | \ replaced !does with (;code) 16may93jaw | ||
| 16 : | \ made complete redesign and | ||
| 17 : | \ introduced two vocs method | ||
| 18 : | \ to be asure that the right words | ||
| 19 : | \ are found 08jun93jaw | ||
| 20 : | \ btw: ! works not with 16 bit | ||
| 21 : | \ targets 09jun93jaw | ||
| 22 : | \ added: 2user and value 11jun93jaw | ||
| 23 : | |||
| 24 : | pazsan | 1.9 | \ include other.fs \ ansforth extentions for cross |
| 25 : | anton | 1.1 | |
| 26 : | pazsan | 1.5 | : comment? ( c-addr u -- c-addr u ) |
| 27 : | 2dup s" (" compare 0= | ||
| 28 : | IF postpone ( | ||
| 29 : | ELSE 2dup s" \" compare 0= IF postpone \ THEN | ||
| 30 : | THEN ; | ||
| 31 : | |||
| 32 : | anton | 1.1 | decimal |
| 33 : | |||
| 34 : | \ Begin CROSS COMPILER: | ||
| 35 : | |||
| 36 : | \ GhostNames 9may93jaw | ||
| 37 : | \ second name source to search trough list | ||
| 38 : | |||
| 39 : | VARIABLE GhostNames | ||
| 40 : | 0 GhostNames ! | ||
| 41 : | : GhostName ( -- addr ) | ||
| 42 : | here GhostNames @ , GhostNames ! here 0 , | ||
| 43 : | pazsan | 1.13 | bl word count |
| 44 : | anton | 1.1 | \ 2dup type space |
| 45 : | dup c, here over chars allot swap move align ; | ||
| 46 : | |||
| 47 : | hex | ||
| 48 : | |||
| 49 : | |||
| 50 : | Vocabulary Cross | ||
| 51 : | Vocabulary Target | ||
| 52 : | Vocabulary Ghosts | ||
| 53 : | VOCABULARY Minimal | ||
| 54 : | only Forth also Target also also | ||
| 55 : | definitions Forth | ||
| 56 : | |||
| 57 : | : T previous Cross also Target ; immediate | ||
| 58 : | : G Ghosts ; immediate | ||
| 59 : | : H previous Forth also Cross ; immediate | ||
| 60 : | |||
| 61 : | forth definitions | ||
| 62 : | |||
| 63 : | : T previous Cross also Target ; immediate | ||
| 64 : | : G Ghosts ; immediate | ||
| 65 : | |||
| 66 : | : >cross also Cross definitions previous ; | ||
| 67 : | : >target also Target definitions previous ; | ||
| 68 : | : >minimal also Minimal definitions previous ; | ||
| 69 : | |||
| 70 : | H | ||
| 71 : | |||
| 72 : | >CROSS | ||
| 73 : | |||
| 74 : | \ Variables 06oct92py | ||
| 75 : | |||
| 76 : | -1 Constant NIL | ||
| 77 : | Variable image | ||
| 78 : | Variable tlast NIL tlast ! \ Last name field | ||
| 79 : | Variable tlastcfa \ Last code field | ||
| 80 : | Variable tdoes \ Resolve does> calls | ||
| 81 : | Variable bit$ | ||
| 82 : | Variable tdp | ||
| 83 : | : there tdp @ ; | ||
| 84 : | |||
| 85 : | \ Parameter for target systems 06oct92py | ||
| 86 : | |||
| 87 : | pazsan | 1.13 | included |
| 88 : | anton | 1.1 | |
| 89 : | >TARGET | ||
| 90 : | |||
| 91 : | \ Byte ordering and cell size 06oct92py | ||
| 92 : | |||
| 93 : | : cell+ cell + ; | ||
| 94 : | : cells cell<< lshift ; | ||
| 95 : | : chars ; | ||
| 96 : | anton | 1.6 | : floats float * ; |
| 97 : | |||
| 98 : | anton | 1.1 | >CROSS |
| 99 : | : cell/ cell<< rshift ; | ||
| 100 : | >TARGET | ||
| 101 : | 20 CONSTANT bl | ||
| 102 : | -1 Constant NIL | ||
| 103 : | -2 Constant :docol | ||
| 104 : | -3 Constant :docon | ||
| 105 : | -4 Constant :dovar | ||
| 106 : | pazsan | 1.3 | -5 Constant :douser |
| 107 : | anton | 1.10 | -6 Constant :dodefer |
| 108 : | -7 Constant :dodoes | ||
| 109 : | -8 Constant :doesjump | ||
| 110 : | anton | 1.1 | |
| 111 : | >CROSS | ||
| 112 : | |||
| 113 : | anton | 1.12 | bigendian 0 pad ! -1 pad c! pad @ 0< |
| 114 : | anton | 1.1 | = [IF] : bswap ; immediate |
| 115 : | [ELSE] : bswap ( big / little -- little / big ) 0 | ||
| 116 : | cell 1- FOR bits/byte lshift over | ||
| 117 : | [ 1 bits/byte lshift 1- ] Literal and or | ||
| 118 : | swap bits/byte rshift swap NEXT nip ; | ||
| 119 : | [THEN] | ||
| 120 : | |||
| 121 : | \ Memory initialisation 05dec92py | ||
| 122 : | \ Fixed bug in else part 11may93jaw | ||
| 123 : | |||
| 124 : | [IFDEF] Memory \ Memory is a bigFORTH feature | ||
| 125 : | pazsan | 1.5 | also Memory |
| 126 : | anton | 1.1 | : initmem ( var len -- ) |
| 127 : | 2dup swap handle! >r @ r> erase ; | ||
| 128 : | pazsan | 1.5 | toss |
| 129 : | anton | 1.1 | [ELSE] |
| 130 : | : initmem ( var len -- ) | ||
| 131 : | tuck allocate abort" CROSS: No memory for target" | ||
| 132 : | ( len var adr ) dup rot ! | ||
| 133 : | ( len adr ) swap erase ; | ||
| 134 : | [THEN] | ||
| 135 : | |||
| 136 : | \ MakeKernal 12dec92py | ||
| 137 : | |||
| 138 : | >MINIMAL | ||
| 139 : | : makekernal ( targetsize -- targetsize ) | ||
| 140 : | bit$ over 1- cell>bit rshift 1+ initmem | ||
| 141 : | image over initmem tdp off ; | ||
| 142 : | |||
| 143 : | >CROSS | ||
| 144 : | \ Bit string manipulation 06oct92py | ||
| 145 : | \ 9may93jaw | ||
| 146 : | CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, | ||
| 147 : | : bits ( n -- n ) chars Bittable + c@ ; | ||
| 148 : | |||
| 149 : | : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; | ||
| 150 : | : +bit ( addr n -- ) >bit over c@ or swap c! ; | ||
| 151 : | pazsan | 1.4 | : -bit ( addr n -- ) >bit invert over c@ and swap c! ; |
| 152 : | anton | 1.1 | : relon ( taddr -- ) bit$ @ swap cell/ +bit ; |
| 153 : | pazsan | 1.4 | : reloff ( taddr -- ) bit$ @ swap cell/ -bit ; |
| 154 : | anton | 1.1 | |
| 155 : | \ Target memory access 06oct92py | ||
| 156 : | |||
| 157 : | : align+ ( taddr -- rest ) | ||
| 158 : | cell tuck 1- and - [ cell 1- ] Literal and ; | ||
| 159 : | |||
| 160 : | >TARGET | ||
| 161 : | : aligned ( taddr -- ta-addr ) dup align+ + ; | ||
| 162 : | \ assumes cell alignment granularity (as GNU C) | ||
| 163 : | |||
| 164 : | >CROSS | ||
| 165 : | : >image ( taddr -- absaddr ) image @ + ; | ||
| 166 : | >TARGET | ||
| 167 : | : @ ( taddr -- w ) >image @ bswap ; | ||
| 168 : | : ! ( w taddr -- ) >r bswap r> >image ! ; | ||
| 169 : | : c@ ( taddr -- char ) >image c@ ; | ||
| 170 : | : c! ( char taddr -- ) >image c! ; | ||
| 171 : | anton | 1.7 | : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; |
| 172 : | : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; | ||
| 173 : | anton | 1.1 | |
| 174 : | \ Target compilation primitives 06oct92py | ||
| 175 : | \ included A! 16may93jaw | ||
| 176 : | |||
| 177 : | : here ( -- there ) there ; | ||
| 178 : | : allot ( n -- ) tdp +! ; | ||
| 179 : | : , ( w -- ) T here H cell T allot ! H ; | ||
| 180 : | : c, ( char -- ) T here 1 allot c! H ; | ||
| 181 : | : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; | ||
| 182 : | |||
| 183 : | : A! dup relon T ! H ; | ||
| 184 : | : A, ( w -- ) T here H relon T , H ; | ||
| 185 : | |||
| 186 : | >CROSS | ||
| 187 : | |||
| 188 : | \ threading modell 13dec92py | ||
| 189 : | |||
| 190 : | \ generic threading modell | ||
| 191 : | : docol, ( -- ) :docol T A, 0 , H ; | ||
| 192 : | |||
| 193 : | >TARGET | ||
| 194 : | : >body ( cfa -- pfa ) T cell+ cell+ H ; | ||
| 195 : | >CROSS | ||
| 196 : | |||
| 197 : | pazsan | 1.3 | : dodoes, ( -- ) T :doesjump A, 0 , H ; |
| 198 : | anton | 1.1 | |
| 199 : | \ Ghost Builder 06oct92py | ||
| 200 : | |||
| 201 : | \ <T T> new version with temp variable 10may93jaw | ||
| 202 : | |||
| 203 : | VARIABLE VocTemp | ||
| 204 : | |||
| 205 : | : <T get-current VocTemp ! also Ghosts definitions ; | ||
| 206 : | : T> previous VocTemp @ set-current ; | ||
| 207 : | |||
| 208 : | 4711 Constant <fwd> 4712 Constant <res> | ||
| 209 : | 4713 Constant <imm> | ||
| 210 : | |||
| 211 : | \ iForth makes only immediate directly after create | ||
| 212 : | \ make atonce trick! ? | ||
| 213 : | |||
| 214 : | Variable atonce atonce off | ||
| 215 : | |||
| 216 : | : NoExec true ABORT" CROSS: Don't execute ghost" ; | ||
| 217 : | |||
| 218 : | : GhostHeader <fwd> , 0 , ['] NoExec , ; | ||
| 219 : | |||
| 220 : | : >magic ; : >link cell+ ; : >exec cell+ cell+ ; | ||
| 221 : | : >end 3 cells + ; | ||
| 222 : | |||
| 223 : | pazsan | 1.11 | Variable last-ghost |
| 224 : | anton | 1.1 | : Make-Ghost ( "name" -- ghost ) |
| 225 : | >in @ GhostName swap >in ! | ||
| 226 : | <T Create atonce @ IF immediate atonce off THEN | ||
| 227 : | here tuck swap ! ghostheader T> | ||
| 228 : | pazsan | 1.11 | DOES> dup last-ghost ! >exec @ execute ; |
| 229 : | anton | 1.1 | |
| 230 : | \ ghost words 14oct92py | ||
| 231 : | \ changed: 10may93py/jaw | ||
| 232 : | |||
| 233 : | : gfind ( string -- ghost true/1 / string false ) | ||
| 234 : | \ searches for string in word-list ghosts | ||
| 235 : | \ !! wouldn't it be simpler to just use search-wordlist ? ae | ||
| 236 : | pazsan | 1.5 | dup count [ ' ghosts >body ] ALiteral search-wordlist |
| 237 : | pazsan | 1.13 | dup IF >r >body nip r> THEN ; |
| 238 : | anton | 1.1 | |
| 239 : | VARIABLE Already | ||
| 240 : | |||
| 241 : | : ghost ( "name" -- ghost ) | ||
| 242 : | Already off | ||
| 243 : | pazsan | 1.13 | >in @ bl word gfind IF Already on nip EXIT THEN |
| 244 : | anton | 1.1 | drop >in ! Make-Ghost ; |
| 245 : | |||
| 246 : | \ resolve 14oct92py | ||
| 247 : | |||
| 248 : | : resolve-loop ( ghost tcfa -- ghost tcfa ) | ||
| 249 : | >r dup >link @ | ||
| 250 : | BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; | ||
| 251 : | |||
| 252 : | \ exists 9may93jaw | ||
| 253 : | |||
| 254 : | : exists ( ghost tcfa -- ) | ||
| 255 : | over GhostNames | ||
| 256 : | BEGIN @ dup | ||
| 257 : | WHILE 2dup cell+ @ = | ||
| 258 : | UNTIL | ||
| 259 : | nip 2 cells + count cr ." CROSS: Exists: " type 4 spaces | ||
| 260 : | swap cell+ ! | ||
| 261 : | ELSE true ABORT" CROSS: Ghostnames inconsistent" | ||
| 262 : | THEN ; | ||
| 263 : | |||
| 264 : | : resolve ( ghost tcfa -- ) | ||
| 265 : | over >magic @ <fwd> <> IF exists EXIT THEN | ||
| 266 : | resolve-loop over >link ! <res> swap >magic ! ; | ||
| 267 : | |||
| 268 : | \ gexecute ghost, 01nov92py | ||
| 269 : | |||
| 270 : | : do-forward ( ghost -- ) | ||
| 271 : | >link dup @ there rot ! T A, H ; | ||
| 272 : | : do-resolve ( ghost -- ) | ||
| 273 : | >link @ T A, H ; | ||
| 274 : | |||
| 275 : | : gexecute ( ghost -- ) dup @ | ||
| 276 : | <fwd> = IF do-forward ELSE do-resolve THEN ; | ||
| 277 : | : ghost, ghost gexecute ; | ||
| 278 : | |||
| 279 : | \ .unresolved 11may93jaw | ||
| 280 : | |||
| 281 : | variable ResolveFlag | ||
| 282 : | |||
| 283 : | \ ?touched 11may93jaw | ||
| 284 : | |||
| 285 : | : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @ | ||
| 286 : | 0 <> and ; | ||
| 287 : | |||
| 288 : | : ?resolved ( ghostname -- ) | ||
| 289 : | dup cell+ @ ?touched | ||
| 290 : | IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ; | ||
| 291 : | |||
| 292 : | >MINIMAL | ||
| 293 : | : .unresolved ( -- ) | ||
| 294 : | ResolveFlag off cr ." Unresolved: " | ||
| 295 : | Ghostnames | ||
| 296 : | BEGIN @ dup | ||
| 297 : | WHILE dup ?resolved | ||
| 298 : | anton | 1.10 | REPEAT drop ResolveFlag @ |
| 299 : | IF | ||
| 300 : | pazsan | 1.11 | abort" Unresolved words!" |
| 301 : | anton | 1.10 | ELSE |
| 302 : | ." Nothing!" | ||
| 303 : | THEN | ||
| 304 : | cr ; | ||
| 305 : | anton | 1.1 | |
| 306 : | >CROSS | ||
| 307 : | \ Header states 12dec92py | ||
| 308 : | |||
| 309 : | : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; | ||
| 310 : | |||
| 311 : | VARIABLE ^imm | ||
| 312 : | |||
| 313 : | >TARGET | ||
| 314 : | : immediate 20 flag! | ||
| 315 : | ^imm @ @ dup <imm> = ?EXIT | ||
| 316 : | <res> <> ABORT" CROSS: Cannot immediate a unresolved word" | ||
| 317 : | <imm> ^imm @ ! ; | ||
| 318 : | pazsan | 1.8 | : restrict 40 flag! ; |
| 319 : | anton | 1.1 | >CROSS |
| 320 : | |||
| 321 : | \ ALIAS2 ansforth conform alias 9may93jaw | ||
| 322 : | |||
| 323 : | : ALIAS2 create here 0 , DOES> @ execute ; | ||
| 324 : | \ usage: | ||
| 325 : | \ ' alias2 bla ! | ||
| 326 : | |||
| 327 : | \ Target Header Creation 01nov92py | ||
| 328 : | |||
| 329 : | : string, ( addr count -- ) | ||
| 330 : | dup T c, H bounds DO I c@ T c, H LOOP ; | ||
| 331 : | pazsan | 1.13 | : name, ( "name" -- ) bl word count string, T align H ; |
| 332 : | anton | 1.1 | : view, ( -- ) ( dummy ) ; |
| 333 : | |||
| 334 : | VARIABLE CreateFlag CreateFlag off | ||
| 335 : | |||
| 336 : | : (Theader ( "name" -- ghost ) T align H view, | ||
| 337 : | tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! | ||
| 338 : | >in @ name, >in ! T here H tlastcfa ! | ||
| 339 : | CreateFlag @ IF | ||
| 340 : | >in @ alias2 swap >in ! \ create alias in target | ||
| 341 : | >in @ ghost swap >in ! | ||
| 342 : | swap also ghosts ' previous swap ! \ tick ghost and store in alias | ||
| 343 : | CreateFlag off | ||
| 344 : | ELSE ghost THEN | ||
| 345 : | dup >magic ^imm ! \ a pointer for immediate | ||
| 346 : | Already @ IF dup >end tdoes ! | ||
| 347 : | ELSE 0 tdoes ! THEN | ||
| 348 : | 80 flag! ; | ||
| 349 : | |||
| 350 : | VARIABLE ;Resolve 1 cells allot | ||
| 351 : | |||
| 352 : | pazsan | 1.11 | : Theader ( "name" -- ghost ) |
| 353 : | (THeader dup there resolve 0 ;Resolve ! ; | ||
| 354 : | anton | 1.1 | |
| 355 : | >TARGET | ||
| 356 : | : Alias ( cfa -- ) \ name | ||
| 357 : | (THeader over resolve T A, H 80 flag! ; | ||
| 358 : | >CROSS | ||
| 359 : | |||
| 360 : | \ Conditionals and Comments 11may93jaw | ||
| 361 : | |||
| 362 : | : ;Cond | ||
| 363 : | postpone ; | ||
| 364 : | swap ! ; immediate | ||
| 365 : | |||
| 366 : | : Cond: ( -- ) \ name {code } ; | ||
| 367 : | atonce on | ||
| 368 : | ghost | ||
| 369 : | >exec | ||
| 370 : | :NONAME ; | ||
| 371 : | |||
| 372 : | : restrict? ( -- ) | ||
| 373 : | \ aborts on interprete state - ae | ||
| 374 : | state @ 0= ABORT" CROSS: Restricted" ; | ||
| 375 : | |||
| 376 : | : Comment ( -- ) | ||
| 377 : | >in @ atonce on ghost swap >in ! ' swap >exec ! ; | ||
| 378 : | |||
| 379 : | Comment ( Comment \ | ||
| 380 : | |||
| 381 : | \ Predefined ghosts 12dec92py | ||
| 382 : | |||
| 383 : | ghost 0= drop | ||
| 384 : | ghost branch ghost ?branch 2drop | ||
| 385 : | ghost (do) ghost (?do) 2drop | ||
| 386 : | ghost (for) drop | ||
| 387 : | ghost (loop) ghost (+loop) 2drop | ||
| 388 : | ghost (next) drop | ||
| 389 : | pazsan | 1.2 | ghost unloop ghost ;S 2drop |
| 390 : | anton | 1.1 | ghost lit ghost (compile) ghost ! 2drop drop |
| 391 : | ghost (;code) ghost noop 2drop | ||
| 392 : | ghost (.") ghost (S") ghost (ABORT") 2drop drop | ||
| 393 : | pazsan | 1.9 | ghost ' |
| 394 : | anton | 1.1 | |
| 395 : | \ compile 10may93jaw | ||
| 396 : | |||
| 397 : | : compile ( -- ) \ name | ||
| 398 : | restrict? | ||
| 399 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile " |
| 400 : | anton | 1.1 | 0> ( immediate? ) |
| 401 : | IF >exec @ compile, | ||
| 402 : | ELSE postpone literal postpone gexecute THEN ; | ||
| 403 : | immediate | ||
| 404 : | |||
| 405 : | >TARGET | ||
| 406 : | pazsan | 1.13 | : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined " |
| 407 : | anton | 1.1 | dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ; |
| 408 : | |||
| 409 : | Cond: ['] compile lit ghost gexecute ;Cond | ||
| 410 : | anton | 1.14 | |
| 411 : | Cond: chars ;Cond | ||
| 412 : | anton | 1.1 | |
| 413 : | >CROSS | ||
| 414 : | \ tLiteral 12dec92py | ||
| 415 : | |||
| 416 : | : lit, ( n -- ) compile lit T , H ; | ||
| 417 : | : alit, ( n -- ) compile lit T A, H ; | ||
| 418 : | |||
| 419 : | >TARGET | ||
| 420 : | Cond: Literal ( n -- ) restrict? lit, ;Cond | ||
| 421 : | Cond: ALiteral ( n -- ) restrict? alit, ;Cond | ||
| 422 : | |||
| 423 : | : Char ( "<char>" -- ) bl word char+ c@ ; | ||
| 424 : | Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond | ||
| 425 : | |||
| 426 : | >CROSS | ||
| 427 : | \ Target compiling loop 12dec92py | ||
| 428 : | \ ">tib trick thrown out 10may93jaw | ||
| 429 : | \ number? defined at the top 11may93jaw | ||
| 430 : | |||
| 431 : | \ compiled word might leave items on stack! | ||
| 432 : | : tcom ( in name -- ) | ||
| 433 : | gfind ?dup IF 0> IF nip >exec @ execute | ||
| 434 : | ELSE nip gexecute THEN EXIT THEN | ||
| 435 : | number? dup IF 0> IF swap lit, THEN lit, drop | ||
| 436 : | ELSE 2drop >in ! | ||
| 437 : | ghost gexecute THEN ; | ||
| 438 : | |||
| 439 : | >TARGET | ||
| 440 : | \ : ; DOES> 13dec92py | ||
| 441 : | \ ] 9may93py/jaw | ||
| 442 : | |||
| 443 : | : ] state on | ||
| 444 : | BEGIN | ||
| 445 : | pazsan | 1.13 | BEGIN >in @ bl word |
| 446 : | anton | 1.1 | dup c@ 0= WHILE 2drop refill 0= |
| 447 : | ABORT" CROSS: End of file while target compiling" | ||
| 448 : | REPEAT | ||
| 449 : | tcom | ||
| 450 : | state @ | ||
| 451 : | 0= | ||
| 452 : | UNTIL ; | ||
| 453 : | |||
| 454 : | \ by the way: defining a second interpreter (a compiler-)loop | ||
| 455 : | \ is not allowed if a system should be ans conform | ||
| 456 : | |||
| 457 : | : : ( -- colon-sys ) \ Name | ||
| 458 : | (THeader ;Resolve ! there ;Resolve cell+ ! | ||
| 459 : | docol, depth T ] H ; | ||
| 460 : | |||
| 461 : | pazsan | 1.2 | Cond: EXIT ( -- ) restrict? compile ;S ;Cond |
| 462 : | anton | 1.6 | |
| 463 : | Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond | ||
| 464 : | pazsan | 1.2 | |
| 465 : | anton | 1.1 | Cond: ; ( -- ) restrict? |
| 466 : | depth ?dup IF 1- <> ABORT" CROSS: Stack changed" | ||
| 467 : | ELSE true ABORT" CROSS: Stack empty" THEN | ||
| 468 : | pazsan | 1.2 | compile ;S state off |
| 469 : | anton | 1.1 | ;Resolve @ |
| 470 : | IF ;Resolve @ ;Resolve cell+ @ resolve THEN | ||
| 471 : | ;Cond | ||
| 472 : | Cond: [ restrict? state off ;Cond | ||
| 473 : | |||
| 474 : | >CROSS | ||
| 475 : | : !does :dodoes tlastcfa @ tuck T ! cell+ ! H ; | ||
| 476 : | |||
| 477 : | >TARGET | ||
| 478 : | Cond: DOES> restrict? | ||
| 479 : | compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN | ||
| 480 : | ;Cond | ||
| 481 : | : DOES> dodoes, T here H !does depth T ] H ; | ||
| 482 : | |||
| 483 : | >CROSS | ||
| 484 : | \ Creation 01nov92py | ||
| 485 : | |||
| 486 : | \ Builder 11may93jaw | ||
| 487 : | |||
| 488 : | : Builder ( Create do: "name" -- ) | ||
| 489 : | >in @ alias2 swap dup >in ! >r >r | ||
| 490 : | Make-Ghost rot swap >exec ! , | ||
| 491 : | r> r> >in ! | ||
| 492 : | pazsan | 1.11 | also ghosts ' previous swap ! ; |
| 493 : | \ DOES> dup >exec @ execute ; | ||
| 494 : | anton | 1.1 | |
| 495 : | : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> | ||
| 496 : | IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN | ||
| 497 : | pazsan | 1.4 | :dodoes T A, H gexecute T here H cell - reloff ; |
| 498 : | anton | 1.1 | |
| 499 : | pazsan | 1.11 | : TCreate ( -- ) |
| 500 : | last-ghost @ | ||
| 501 : | anton | 1.1 | CreateFlag on |
| 502 : | pazsan | 1.11 | Theader >r dup gdoes, |
| 503 : | >end @ >exec @ r> >exec ! ; | ||
| 504 : | anton | 1.1 | |
| 505 : | : Build: ( -- [xt] [colon-sys] ) | ||
| 506 : | :noname postpone TCreate ; | ||
| 507 : | |||
| 508 : | : gdoes> ( ghost -- addr flag ) | ||
| 509 : | pazsan | 1.11 | last-ghost @ |
| 510 : | anton | 1.1 | state @ IF gexecute true EXIT THEN |
| 511 : | cell+ @ T >body H false ; | ||
| 512 : | |||
| 513 : | \ DO: ;DO 11may93jaw | ||
| 514 : | \ changed to ?EXIT 10may93jaw | ||
| 515 : | |||
| 516 : | : DO: ( -- addr [xt] [colon-sys] ) | ||
| 517 : | here ghostheader | ||
| 518 : | pazsan | 1.11 | :noname postpone gdoes> postpone ?EXIT ; |
| 519 : | anton | 1.1 | |
| 520 : | : ;DO ( addr [xt] [colon-sys] -- ) | ||
| 521 : | postpone ; ( S addr xt ) | ||
| 522 : | over >exec ! ; immediate | ||
| 523 : | |||
| 524 : | : by ( -- addr ) \ Name | ||
| 525 : | ghost >end @ ; | ||
| 526 : | |||
| 527 : | >TARGET | ||
| 528 : | \ Variables and Constants 05dec92py | ||
| 529 : | |||
| 530 : | Build: ; | ||
| 531 : | DO: ( ghost -- addr ) ;DO | ||
| 532 : | Builder Create | ||
| 533 : | by Create :dovar resolve | ||
| 534 : | |||
| 535 : | Build: T 0 , H ; | ||
| 536 : | by Create | ||
| 537 : | Builder Variable | ||
| 538 : | |||
| 539 : | Build: T 0 A, H ; | ||
| 540 : | by Create | ||
| 541 : | Builder AVariable | ||
| 542 : | |||
| 543 : | pazsan | 1.3 | \ User variables 04may94py |
| 544 : | |||
| 545 : | >CROSS | ||
| 546 : | Variable tup 0 tup ! | ||
| 547 : | Variable tudp 0 tudp ! | ||
| 548 : | : u, ( n -- udp ) | ||
| 549 : | tup @ tudp @ + T ! H | ||
| 550 : | tudp @ dup cell+ tudp ! ; | ||
| 551 : | : au, ( n -- udp ) | ||
| 552 : | tup @ tudp @ + T A! H | ||
| 553 : | tudp @ dup cell+ tudp ! ; | ||
| 554 : | >TARGET | ||
| 555 : | |||
| 556 : | Build: T 0 u, , H ; | ||
| 557 : | DO: ( ghost -- up-addr ) T @ H tup @ + ;DO | ||
| 558 : | anton | 1.1 | Builder User |
| 559 : | pazsan | 1.3 | by User :douser resolve |
| 560 : | anton | 1.1 | |
| 561 : | pazsan | 1.3 | Build: T 0 u, , 0 u, drop H ; |
| 562 : | by User | ||
| 563 : | anton | 1.1 | Builder 2User |
| 564 : | |||
| 565 : | pazsan | 1.3 | Build: T 0 au, , H ; |
| 566 : | by User | ||
| 567 : | anton | 1.1 | Builder AUser |
| 568 : | |||
| 569 : | Build: ( n -- ) T , H ; | ||
| 570 : | DO: ( ghost -- n ) T @ H ;DO | ||
| 571 : | Builder Constant | ||
| 572 : | by Constant :docon resolve | ||
| 573 : | |||
| 574 : | Build: ( n -- ) T A, H ; | ||
| 575 : | by Constant | ||
| 576 : | Builder AConstant | ||
| 577 : | |||
| 578 : | Build: T 0 , H ; | ||
| 579 : | by Constant | ||
| 580 : | Builder Value | ||
| 581 : | |||
| 582 : | Build: ( -- ) compile noop ; | ||
| 583 : | DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO | ||
| 584 : | Builder Defer | ||
| 585 : | anton | 1.10 | by Defer :dodefer resolve |
| 586 : | anton | 1.1 | |
| 587 : | \ structural conditionals 17dec92py | ||
| 588 : | |||
| 589 : | >CROSS | ||
| 590 : | : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; | ||
| 591 : | : sys? ( sys -- sys ) dup 0= ?struc ; | ||
| 592 : | : >mark ( -- sys ) T here 0 , H ; | ||
| 593 : | : >resolve ( sys -- ) T here over - swap ! H ; | ||
| 594 : | : <resolve ( sys -- ) T here - , H ; | ||
| 595 : | >TARGET | ||
| 596 : | |||
| 597 : | \ Structural Conditionals 12dec92py | ||
| 598 : | |||
| 599 : | Cond: BUT restrict? sys? swap ;Cond | ||
| 600 : | Cond: YET restrict? sys? dup ;Cond | ||
| 601 : | |||
| 602 : | >CROSS | ||
| 603 : | Variable tleavings | ||
| 604 : | >TARGET | ||
| 605 : | |||
| 606 : | Cond: DONE ( addr -- ) restrict? tleavings @ | ||
| 607 : | BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT | ||
| 608 : | tleavings ! drop ;Cond | ||
| 609 : | |||
| 610 : | >CROSS | ||
| 611 : | : (leave T here H tleavings @ T , H tleavings ! ; | ||
| 612 : | >TARGET | ||
| 613 : | |||
| 614 : | Cond: LEAVE restrict? compile branch (leave ;Cond | ||
| 615 : | Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond | ||
| 616 : | |||
| 617 : | \ Structural Conditionals 12dec92py | ||
| 618 : | |||
| 619 : | Cond: AHEAD restrict? compile branch >mark ;Cond | ||
| 620 : | Cond: IF restrict? compile ?branch >mark ;Cond | ||
| 621 : | Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond | ||
| 622 : | Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond | ||
| 623 : | |||
| 624 : | Cond: BEGIN restrict? T here H ;Cond | ||
| 625 : | Cond: WHILE restrict? sys? compile IF swap ;Cond | ||
| 626 : | Cond: AGAIN restrict? sys? compile branch <resolve ;Cond | ||
| 627 : | Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond | ||
| 628 : | Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond | ||
| 629 : | |||
| 630 : | \ Structural Conditionals 12dec92py | ||
| 631 : | |||
| 632 : | Cond: DO restrict? compile (do) T here H ;Cond | ||
| 633 : | Cond: ?DO restrict? compile (?do) (leave T here H ;Cond | ||
| 634 : | Cond: FOR restrict? compile (for) T here H ;Cond | ||
| 635 : | |||
| 636 : | >CROSS | ||
| 637 : | : loop] dup <resolve cell - compile DONE compile unloop ; | ||
| 638 : | >TARGET | ||
| 639 : | |||
| 640 : | Cond: LOOP restrict? sys? compile (loop) loop] ;Cond | ||
| 641 : | Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond | ||
| 642 : | Cond: NEXT restrict? sys? compile (next) loop] ;Cond | ||
| 643 : | |||
| 644 : | \ String words 23feb93py | ||
| 645 : | |||
| 646 : | : ," [char] " parse string, T align H ; | ||
| 647 : | |||
| 648 : | Cond: ." restrict? compile (.") T ," H ;Cond | ||
| 649 : | Cond: S" restrict? compile (S") T ," H ;Cond | ||
| 650 : | Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond | ||
| 651 : | |||
| 652 : | Cond: IS T ' >body H compile ALiteral compile ! ;Cond | ||
| 653 : | : IS T ' >body ! H ; | ||
| 654 : | pazsan | 1.9 | Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
| 655 : | : TO T ' >body ! H ; | ||
| 656 : | anton | 1.1 | |
| 657 : | \ LINKED ERR" ENV" 2ENV" 18may93jaw | ||
| 658 : | |||
| 659 : | \ linked list primitive | ||
| 660 : | : linked T here over @ A, swap ! H ; | ||
| 661 : | |||
| 662 : | : err" s" ErrLink linked" evaluate T , H | ||
| 663 : | [char] " parse string, T align H ; | ||
| 664 : | |||
| 665 : | : env" [char] " parse s" EnvLink linked" evaluate | ||
| 666 : | string, T align , H ; | ||
| 667 : | |||
| 668 : | : 2env" [char] " parse s" EnvLink linked" evaluate | ||
| 669 : | here >r string, T align , , H | ||
| 670 : | r> dup T c@ H 80 and swap T c! H ; | ||
| 671 : | |||
| 672 : | \ compile must be last 22feb93py | ||
| 673 : | |||
| 674 : | Cond: compile ( -- ) restrict? \ name | ||
| 675 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile" |
| 676 : | anton | 1.1 | 0> IF gexecute |
| 677 : | ELSE dup >magic @ <imm> = | ||
| 678 : | IF gexecute | ||
| 679 : | ELSE compile (compile) gexecute THEN THEN ;Cond | ||
| 680 : | |||
| 681 : | Cond: postpone ( -- ) restrict? \ name | ||
| 682 : | pazsan | 1.13 | bl word gfind dup 0= ABORT" CROSS: Can't compile" |
| 683 : | anton | 1.1 | 0> IF gexecute |
| 684 : | ELSE dup >magic @ <imm> = | ||
| 685 : | IF gexecute | ||
| 686 : | ELSE compile (compile) gexecute THEN THEN ;Cond | ||
| 687 : | |||
| 688 : | >MINIMAL | ||
| 689 : | also minimal | ||
| 690 : | \ Usefull words 13feb93py | ||
| 691 : | |||
| 692 : | : KB 400 * ; | ||
| 693 : | |||
| 694 : | \ define new [IFDEF] and [IFUNDEF] 20may93jaw | ||
| 695 : | |||
| 696 : | pazsan | 1.13 | : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ; |
| 697 : | anton | 1.1 | |
| 698 : | : [IFDEF] there? postpone [IF] ; | ||
| 699 : | : [IFUNDEF] there? 0= postpone [IF] ; | ||
| 700 : | |||
| 701 : | \ C: \- \+ Conditional Compiling 09jun93jaw | ||
| 702 : | |||
| 703 : | : C: >in @ there? 0= | ||
| 704 : | IF >in ! T : H | ||
| 705 : | ELSE drop | ||
| 706 : | BEGIN bl word dup c@ | ||
| 707 : | IF count comment? s" ;" compare 0= ?EXIT | ||
| 708 : | ELSE refill 0= ABORT" CROSS: Out of Input while C:" | ||
| 709 : | THEN | ||
| 710 : | AGAIN | ||
| 711 : | THEN ; | ||
| 712 : | |||
| 713 : | also minimal | ||
| 714 : | |||
| 715 : | : \- there? IF postpone \ THEN ; | ||
| 716 : | : \+ there? 0= IF postpone \ THEN ; | ||
| 717 : | |||
| 718 : | : [IF] postpone [IF] ; | ||
| 719 : | : [THEN] postpone [THEN] ; | ||
| 720 : | : [ELSE] postpone [ELSE] ; | ||
| 721 : | |||
| 722 : | Cond: [IF] [IF] ;Cond | ||
| 723 : | Cond: [IFDEF] [IFDEF] ;Cond | ||
| 724 : | Cond: [IFUNDEF] [IFUNDEF] ;Cond | ||
| 725 : | Cond: [THEN] [THEN] ;Cond | ||
| 726 : | Cond: [ELSE] [ELSE] ;Cond | ||
| 727 : | |||
| 728 : | \ save-cross 17mar93py | ||
| 729 : | |||
| 730 : | \ i'm not interested in bigforth features this time 10may93jaw | ||
| 731 : | \ [IFDEF] file | ||
| 732 : | \ also file | ||
| 733 : | \ [THEN] | ||
| 734 : | \ included throw after create-file 11may93jaw | ||
| 735 : | |||
| 736 : | anton | 1.12 | bigendian Constant bigendian |
| 737 : | anton | 1.1 | |
| 738 : | : save-cross ( "name" -- ) | ||
| 739 : | bl parse ." Saving to " 2dup type | ||
| 740 : | w/o bin create-file throw >r | ||
| 741 : | pazsan | 1.16 | s" gforth00" r@ write-file throw \ write magic |
| 742 : | image @ there r@ write-file throw \ write image | ||
| 743 : | bit$ @ there 1- cell>bit rshift 1+ | ||
| 744 : | r@ write-file throw \ write tags | ||
| 745 : | anton | 1.1 | r> close-file throw ; |
| 746 : | |||
| 747 : | \ words that should be in minimal | ||
| 748 : | |||
| 749 : | : + + ; : 1- 1- ; | ||
| 750 : | : - - ; : 2* 2* ; | ||
| 751 : | pazsan | 1.11 | : * * ; : / / ; |
| 752 : | anton | 1.1 | : dup dup ; : over over ; |
| 753 : | : swap swap ; : rot rot ; | ||
| 754 : | pazsan | 1.13 | : drop drop ; |
| 755 : | : lshift lshift ; : 2/ 2/ ; | ||
| 756 : | cell constant cell | ||
| 757 : | anton | 1.1 | |
| 758 : | \ include bug5.fs | ||
| 759 : | \ only forth also minimal definitions | ||
| 760 : | |||
| 761 : | : \ postpone \ ; | ||
| 762 : | : ( postpone ( ; | ||
| 763 : | : include bl word count included ; | ||
| 764 : | : .( [char] ) parse type ; | ||
| 765 : | : cr cr ; | ||
| 766 : | |||
| 767 : | : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation | ||
| 768 : | only forth also minimal definitions | ||
| 769 : | |||
| 770 : | \ cross-compiler words | ||
| 771 : | |||
| 772 : | : decimal decimal ; | ||
| 773 : | : hex hex ; | ||
| 774 : | |||
| 775 : | pazsan | 1.3 | : tudp T tudp H ; |
| 776 : | : tup T tup H ; minimal | ||
| 777 : | anton | 1.1 | |
| 778 : | \ for debugging... | ||
| 779 : | : order order ; | ||
| 780 : | : words words ; | ||
| 781 : | : .s .s ; | ||
| 782 : | |||
| 783 : | : bye bye ; | ||
| 784 : | |||
| 785 : | \ turnkey direction | ||
| 786 : | : H forth ; immediate | ||
| 787 : | : T minimal ; immediate | ||
| 788 : | : G ghosts ; immediate | ||
| 789 : | |||
| 790 : | : turnkey 0 set-order also Target definitions | ||
| 791 : | also Minimal also ; | ||
| 792 : | |||
| 793 : | \ these ones are pefered: | ||
| 794 : | |||
| 795 : | : lock turnkey ; | ||
| 796 : | : unlock forth also cross ; | ||
| 797 : | |||
| 798 : | unlock definitions also minimal | ||
| 799 : | : lock lock ; | ||
| 800 : | lock |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |