![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to 1275.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs / fcode|
Return to 1275.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs / fcode |
1.1 root 1: \ ***************************************************************************** 1.1.1.2 ! root 2: \ * Copyright (c) 2004, 2011 IBM Corporation 1.1 root 3: \ * All rights reserved. 4: \ * This program and the accompanying materials 5: \ * are made available under the terms of the BSD License 6: \ * which accompanies this distribution, and is available at 7: \ * http://www.opensource.org/licenses/bsd-license.php 8: \ * 9: \ * Contributors: 10: \ * IBM Corporation - initial implementation 11: \ ****************************************************************************/ 12: 13: 14: : fcode-revision ( -- n ) 15: 00030000 \ major * 65536 + minor 16: ; 17: 18: : b(lit) ( -- n ) 19: next-ip read-fcode-num32 20: ?compile-mode IF literal, THEN 21: ; 22: 23: : b(") 24: next-ip read-fcode-string 25: ?compile-mode IF fc-string, align postpone count THEN 26: ; 27: 28: : b(') 29: next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN 30: ; 31: 32: : ?jump-direction ( n -- ) 1.1.1.2 ! root 33: dup 8000 >= IF ! 34: 10000 - \ Create cell-sized negative value ! 35: THEN ! 36: fcode-offset - \ IP is already behind offset, so substract offset size ! 37: ; 1.1 root 38: 39: : ?negative 40: 8000 and 41: ; 42: 43: : dest-on-top 44: 0 >r BEGIN dup @ 0= WHILE >r REPEAT 1.1.1.2 ! root 45: BEGIN r> dup WHILE swap REPEAT 1.1 root 46: drop 47: ; 48: 1.1.1.2 ! root 49: : read-fcode-offset ! 50: next-ip ! 51: ?offset16 IF ! 52: read-fcode-num16 ! 53: ELSE ! 54: read-byte ! 55: dup 80 and IF FF00 or THEN \ Fake 16-bit signed offset ! 56: THEN ! 57: ; 1.1 root 58: 59: : b?branch ( flag -- ) 1.1.1.2 ! root 60: ?compile-mode IF ! 61: read-fcode-offset ?negative IF ! 62: dest-on-top postpone until ! 63: ELSE ! 64: postpone if ! 65: THEN ! 66: ELSE ! 67: ( flag ) IF ! 68: fcode-offset jump-n-ip \ Skip over offset value ! 69: ELSE ! 70: read-fcode-offset ! 71: ?jump-direction jump-n-ip ! 72: THEN ! 73: THEN ! 74: ; immediate 1.1 root 75: 76: : bbranch ( -- ) 1.1.1.2 ! root 77: ?compile-mode IF ! 78: read-fcode-offset ! 79: ?negative IF ! 80: dest-on-top postpone again ! 81: ELSE ! 82: postpone else ! 83: get-ip next-ip fcode@ B2 = IF ! 84: drop ! 85: ELSE ! 86: set-ip ! 87: THEN ! 88: THEN ! 89: ELSE ! 90: read-fcode-offset ?jump-direction jump-n-ip ! 91: THEN ! 92: ; immediate 1.1 root 93: 94: : b(<mark) ( -- ) 95: ?compile-mode IF postpone begin THEN 96: ; immediate 97: 98: : b(>resolve) ( -- ) 99: ?compile-mode IF postpone then THEN 100: ; immediate 101: 1.1.1.2 ! root 102: : b(;) ! 103: <semicolon> compile, reveal ! 104: postpone [ ! 105: ; immediate 1.1 root 106: 107: : b(:) ( -- ) 108: <colon> compile, ] 109: ; immediate 110: 111: : b(case) ( sel -- sel ) 112: postpone case 113: ; immediate 114: 115: : b(endcase) 116: postpone endcase 117: ; immediate 118: 119: : b(of) 120: postpone of 121: read-fcode-offset drop \ read and discard offset 122: ; immediate 123: 124: : b(endof) 125: postpone endof 1.1.1.2 ! root 126: read-fcode-offset drop 1.1 root 127: ; immediate 128: 129: : b(do) 130: postpone do 1.1.1.2 ! root 131: read-fcode-offset drop 1.1 root 132: ; immediate 133: 134: : b(?do) 135: postpone ?do 1.1.1.2 ! root 136: read-fcode-offset drop 1.1 root 137: ; immediate 138: 139: : b(loop) 140: postpone loop 1.1.1.2 ! root 141: read-fcode-offset drop 1.1 root 142: ; immediate 143: 144: : b(+loop) 145: postpone +loop 1.1.1.2 ! root 146: read-fcode-offset drop 1.1 root 147: ; immediate 148: 149: : b(leave) 150: postpone leave 151: ; immediate 152: 1.1.1.2 ! root 153: ! 154: 0 VALUE fc-instance? ! 155: : fc-instance ( -- ) \ Mark next defining word as instance-specific. ! 156: TRUE TO fc-instance? ! 157: ; ! 158: 1.1 root 159: : new-token \ unnamed local fcode function 160: align here next-ip read-fcode# 0 swap set-token 161: ; 162: 1.1.1.2 ! root 163: : external-token ( -- ) \ named local fcode function 1.1 root 164: next-ip read-fcode-string 1.1.1.2 ! root 165: \ fc-instance? IF cr ." ext instance token: " 2dup type ." in " pwd cr THEN 1.1 root 166: header ( str len -- ) \ create a header in the current dictionary entry 167: new-token 168: ; 169: 170: : new-token 1.1.1.2 ! root 171: eva-debug? IF ! 172: s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup ! 173: header ! 174: THEN ! 175: new-token 1.1 root 176: ; 177: 1.1.1.2 ! root 178: \ decide wether or not to give a new token an own name in the dictionary ! 179: : named-token ! 180: fcode-debug? IF ! 181: external-token ! 182: ELSE ! 183: next-ip read-fcode-string 2drop \ Forget about the name ! 184: new-token ! 185: THEN ! 186: ; 1.1 root 187: 1.1.1.2 ! root 188: : b(to) ( val -- ) ! 189: next-ip read-fcode# ! 190: get-token drop ( val xt ) ! 191: dup @ ( val xt @xt ) ! 192: dup <value> = over <defer> = OR IF ! 193: \ Destination is value or defer ! 194: drop ! 195: >body cell - ! 196: ( val addr ) ! 197: ?compile-mode IF ! 198: literal, postpone ! ! 199: ELSE ! 200: ! ! 201: THEN ! 202: ELSE ! 203: <create> <> IF ( val xt ) ! 204: TRUE ABORT" Invalid destination for FCODE b(to)" ! 205: THEN ! 206: dup cell+ @ ( val xt @xt+1cell ) ! 207: dup <instancevalue> <> swap <instancedefer> <> AND IF ! 208: TRUE ABORT" Invalid destination for FCODE b(to)" ! 209: THEN ! 210: \ Destination is instance-value or instance-defer ! 211: >body @ ( val instance-offset ) ! 212: ?compile-mode IF ! 213: literal, postpone >instance postpone ! ! 214: ELSE ! 215: >instance ! ! 216: THEN ! 217: ELSE ! 218: THEN ! 219: ; immediate 1.1 root 220: 221: : b(value) 1.1.1.2 ! root 222: fc-instance? IF ! 223: <create> , \ Needed for "(instance?)" for example ! 224: <instancevalue> , ! 225: (create-instance-var) ! 226: FALSE TO fc-instance? ! 227: ELSE ! 228: <value> , , ! 229: THEN ! 230: reveal ! 231: ; 1.1 root 232: 233: : b(variable) 1.1.1.2 ! root 234: fc-instance? IF ! 235: <create> , \ Needed for "(instance?)" ! 236: <instancevariable> , ! 237: 0 (create-instance-var) ! 238: FALSE TO fc-instance? ! 239: ELSE ! 240: <variable> , 0 , ! 241: THEN ! 242: reveal ! 243: ; 1.1 root 244: 245: : b(constant) 246: <constant> , , reveal 247: ; 248: 249: : undefined-defer 1.1.1.2 ! root 250: cr cr ." Uninitialized defer word has been executed!" cr cr 1.1 root 251: true fcode-end ! 252: ; 253: 254: : b(defer) 1.1.1.2 ! root 255: fc-instance? IF ! 256: <create> , \ Needed for "(instance?)" ! 257: <instancedefer> , ! 258: ['] undefined-defer (create-instance-var) ! 259: reveal ! 260: FALSE TO fc-instance? ! 261: ELSE ! 262: <defer> , reveal ! 263: postpone undefined-defer ! 264: THEN ! 265: ; 1.1 root 266: 267: : b(create) 1.1.1.2 ! root 268: <variable> , 1.1 root 269: postpone noop reveal 270: ; 271: 272: : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) 1.1.1.2 ! root 273: <colon> , over literal, ! 274: postpone + ! 275: <semicolon> compile, ! 276: reveal ! 277: + ! 278: ; 1.1 root 279: 280: : b(buffer:) ( E: -- a-addr) ( F: size -- ) 1.1.1.2 ! root 281: fc-instance? IF ! 282: <create> , \ Needed for "(instance?)" ! 283: <instancebuffer> , ! 284: (create-instance-buf) ! 285: FALSE TO fc-instance? ! 286: ELSE ! 287: <buffer:> , allot ! 288: THEN ! 289: reveal ! 290: ; 1.1 root 291: 292: : suspend-fcode ( -- ) 293: noop \ has to be implemented more efficiently ;-) 294: ; 295: 296: : offset16 ( -- ) 1.1.1.2 ! root 297: 2 to fcode-offset 1.1 root 298: ; 299: 300: : version1 ( -- ) 301: 1 to fcode-spread 1.1.1.2 ! root 302: 1 to fcode-offset 1.1 root 303: read-header 304: ; 305: 306: : start0 ( -- ) 307: 0 to fcode-spread 308: offset16 309: read-header 310: ; 1.1.1.2 ! root 311: 1.1 root 312: : start1 ( -- ) 313: 1 to fcode-spread 314: offset16 315: read-header 316: ; 1.1.1.2 ! root 317: 1.1 root 318: : start2 ( -- ) 319: 2 to fcode-spread 320: offset16 321: read-header 322: ; 323: 324: : start4 ( -- ) 325: 4 to fcode-spread 326: offset16 327: read-header 328: ; 329: 1.1.1.2 ! root 330: : end0 ( -- ) ! 331: true fcode-end ! 1.1 root 332: ; 333: 1.1.1.2 ! root 334: : end1 ( -- ) ! 335: end0 1.1 root 336: ; 337: 338: : ferror ( -- ) 339: clear end0 340: cr ." FCode# " fcode-num @ . ." not assigned!" 341: cr ." FCode evaluation aborted." cr 342: ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr 343: abort 344: ; 345: 346: : reset-local-fcodes 347: FFF 800 DO ['] ferror 0 i set-token LOOP 348: ; 349: 350: : byte-load ( addr xt -- ) 1.1.1.2 ! root 351: >r >r 1.1 root 352: save-evaluator-state 353: r> r> 354: reset-fcode-end 355: 1 to fcode-spread 356: dup 1 = IF drop ['] rb@ THEN to fcode-rb@ 357: set-ip 358: reset-local-fcodes 359: depth >r 360: evaluate-fcode 1.1.1.2 ! root 361: r> depth 1- <> IF ! 362: clear end0 ! 363: cr ." Ambiguous stack depth after byte-load!" ! 364: cr ." FCode evaluation aborted." cr cr 1.1 root 365: ELSE 1.1.1.2 ! root 366: restore-evaluator-state ! 367: THEN ! 368: ['] c@ to fcode-rb@ ! 369: ; ! 370: ! 371: \ Functions for accessing memory ... since some FCODE programs use the normal ! 372: \ memory access functions for accessing MMIO memory, too, we got to use a little ! 373: \ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the ! 374: \ FCODE is trying to access MMIO memory and use the register based access ! 375: \ functions instead! ! 376: : fc-c@ ( addr -- byte ) dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ; ! 377: : fc-w@ ( addr -- word ) dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ; ! 378: : fc-<w@ ( addr -- word ) fc-w@ dup 8000 >= IF 10000 - THEN ; ! 379: : fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ; ! 380: : fc-<l@ ( addr -- long ) fc-l@ signed ; ! 381: : fc-x@ ( addr -- dlong ) dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ; ! 382: : fc-c! ( byte addr -- ) dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ; ! 383: : fc-w! ( word addr -- ) dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ; ! 384: : fc-l! ( long addr -- ) dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ; ! 385: : fc-x! ( dlong addr -- ) dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ; ! 386: ! 387: : fc-fill ( add len byte -- ) 2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ; ! 388: : fc-move ( src dst len -- ) ! 389: 2 pick MIN-RAM-SIZE > \ Check src ! 390: 2 pick MIN-RAM-SIZE > \ Check dst ! 391: OR IF rmove ELSE move THEN ! 392: ; ! 393: ! 394: \ Destroy virtual mapping (should maybe also update "address" property here?) ! 395: : free-virtual ( virt size -- ) ! 396: s" map-out" $call-parent ! 397: ; ! 398: ! 399: \ Map the specified region, return virtual address ! 400: : map-low ( phys.lo ... size -- virt ) ! 401: my-space swap s" map-in" $call-parent ! 402: ; ! 403: ! 404: \ Get MAC address ! 405: : mac-address ( -- mac-str mac-len ) ! 406: s" local-mac-address" get-my-property IF ! 407: 0 0 ! 408: THEN ! 409: ; ! 410: ! 411: \ Output line and column number - not used yet ! 412: VARIABLE #line ! 413: 0 #line ! ! 414: VARIABLE #out ! 415: 0 #out ! ! 416: ! 417: \ Display device status ! 418: : display-status ( n -- ) ! 419: ." Device status: " . cr ! 420: ; ! 421: ! 422: \ Obsolete variables: ! 423: VARIABLE group-code ! 424: 0 group-code ! ! 425: ! 426: \ Obsolete: Allocate memory for DMA ! 427: : dma-alloc ( byte -- virtual ) ! 428: s" dma-alloc" $call-parent ! 429: ; ! 430: ! 431: \ Obsolete: Get params property ! 432: : my-params ( -- addr len ) ! 433: s" params" get-my-property IF ! 434: 0 0 ! 435: THEN ! 436: ; ! 437: ! 438: \ Obsolete: Convert SBus interrupt level to CPU interrupt level ! 439: : sbus-intr>cpu ( sbus-intr# -- cpu-intr# ) ! 440: ; ! 441: ! 442: \ Obsolete: Set "intr" property ! 443: : intr ( interrupt# vector -- ) ! 444: >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property ! 445: ; 1.1 root 446: 1.1.1.2 ! root 447: \ Obsolete: Create the "name" property ! 448: : driver ( addr len -- ) ! 449: encode-string s" name" property ! 450: ; ! 451: ! 452: \ Obsolete: Return type of CPU ! 453: : processor-type ( -- cpu-type ) ! 454: 0 ! 455: ; ! 456: ! 457: \ Obsolete: Return firmware version ! 458: : firmware-version ( -- n ) ! 459: 10000 \ Just a dummy value ! 460: ; ! 461: ! 462: \ Obsolete: Return fcode-version ! 463: : fcode-version ( -- n ) ! 464: fcode-revision ! 465: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.