![[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: \ ***************************************************************************** ! 2: \ * Copyright (c) 2004, 2008 IBM Corporation ! 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: 0 value function-type ' function-type @ constant <value> ! 14: variable function-type ' function-type @ constant <variable> ! 15: 0 constant function-type ' function-type @ constant <constant> ! 16: : function-type ; ' function-type @ constant <colon> ! 17: create function-type ' function-type @ constant <create> ! 18: defer function-type ' function-type @ constant <defer> ! 19: ! 20: \ variable tmp-buf-current ! 21: \ variable orig-here ! 22: \ create tmp-buf 10000 allot ! 23: ! 24: ( ---------------------------------------------------- ) ! 25: ! 26: : fcode-revision ( -- n ) ! 27: 00030000 \ major * 65536 + minor ! 28: ; ! 29: ! 30: : b(lit) ( -- n ) ! 31: next-ip read-fcode-num32 ! 32: ?compile-mode IF literal, THEN ! 33: ; ! 34: ! 35: : b(") ! 36: next-ip read-fcode-string ! 37: ?compile-mode IF fc-string, align postpone count THEN ! 38: ; ! 39: ! 40: : b(') ! 41: next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN ! 42: ; ! 43: ! 44: : ?jump-direction ( n -- ) ! 45: dup 8000 >= IF FFFF swap - negate 2- THEN ! 46: ; ! 47: ! 48: : ?negative ! 49: 8000 and ! 50: ; ! 51: ! 52: : dest-on-top ! 53: 0 >r BEGIN dup @ 0= WHILE >r REPEAT ! 54: BEGIN r> dup WHILE swap REPEAT ! 55: drop ! 56: ; ! 57: ! 58: : ?branch ! 59: true = ! 60: ; ! 61: ! 62: : read-fcode-offset \ ELSE needs to be fixed! ! 63: ?offset16 IF next-ip read-fcode-num16 ELSE THEN ! 64: ; ! 65: ! 66: : b?branch ( flag -- ) ! 67: ?compile-mode IF ! 68: read-fcode-offset ?negative IF dest-on-top postpone until ! 69: ELSE postpone if ! 70: THEN ! 71: ELSE ! 72: ?branch IF 2 jump-n-ip ! 73: ELSE read-fcode-offset ! 74: ?jump-direction 2- jump-n-ip ! 75: THEN ! 76: THEN ! 77: ; immediate ! 78: ! 79: : bbranch ( -- ) ! 80: ?compile-mode IF ! 81: read-fcode-offset ! 82: ?negative IF dest-on-top postpone again ! 83: ELSE postpone else ! 84: get-ip next-ip fcode@ B2 = IF drop ELSE set-ip THEN ! 85: THEN ! 86: ELSE ! 87: read-fcode-offset ?jump-direction 2- jump-n-ip ! 88: THEN ! 89: ; immediate ! 90: ! 91: : b(<mark) ( -- ) ! 92: ?compile-mode IF postpone begin THEN ! 93: ; immediate ! 94: ! 95: : b(>resolve) ( -- ) ! 96: ?compile-mode IF postpone then THEN ! 97: ; immediate ! 98: ! 99: : ffwto; ( -- ) ! 100: BEGIN fcode@ dup c2 <> WHILE ! 101: ." ffwto: skipping " dup . ." @ " get-ip . cr ! 102: CASE 10 OF ( lit ) read-fcode-num32 drop ENDOF ! 103: 11 OF ( ' ) read-fcode# drop ENDOF ! 104: 12 OF ( " ) read-fcode-string 2drop ENDOF ! 105: 13 OF ( bbranch ) read-fcode-offset drop ENDOF ! 106: 14 OF ( b?branch ) read-fcode-offset drop ENDOF ! 107: 15 OF ( loop ) read-fcode-offset drop ENDOF ! 108: 16 OF ( +loop ) read-fcode-offset drop ENDOF ! 109: 17 OF ( do ) read-fcode-offset drop ENDOF ! 110: 18 OF ( ?do ) read-fcode-offset drop ENDOF ! 111: 1C OF ( of ) read-fcode-offset drop ENDOF ! 112: C6 OF ( endof ) read-fcode-offset drop ENDOF ! 113: C3 OF ( to ) read-fcode# drop ENDOF ! 114: dup OF next-ip ENDOF ! 115: ENDCASE ! 116: REPEAT next-ip ! 117: ; ! 118: ! 119: : rpush ( rparm -- ) \ push the rparm to be on top of return stack after exit ! 120: r> swap >r >r ! 121: ; ! 122: ! 123: : rpop ( -- rparm ) \ pop the rparm that was on top of return stack before this ! 124: r> r> swap >r ! 125: ; ! 126: ! 127: : b1(;) ( -- ) ! 128: ." b1(;)" cr ! 129: rpop set-ip ! 130: ; ! 131: ! 132: \ : b1(:) ( -- ) ! 133: \ ." b1(:)" cr ! 134: \ <colon> compile, get-ip 1+ literal ] get-ip rpush set-ip [ ! 135: \ ffwto; ! 136: \ ; immediate ! 137: ! 138: : b(;) ( -- ) ! 139: postpone exit reveal postpone [ ! 140: ; immediate ! 141: ! 142: : b(:) ( -- ) ! 143: <colon> compile, ] ! 144: ; immediate ! 145: ! 146: : b(case) ( sel -- sel ) ! 147: postpone case ! 148: ; immediate ! 149: ! 150: : b(endcase) ! 151: postpone endcase ! 152: ; immediate ! 153: ! 154: : b(of) ! 155: postpone of ! 156: read-fcode-offset drop \ read and discard offset ! 157: ; immediate ! 158: ! 159: : b(endof) ! 160: postpone endof ! 161: read-fcode-offset drop ! 162: ; immediate ! 163: ! 164: : b(do) ! 165: postpone do ! 166: read-fcode-offset drop ! 167: ; immediate ! 168: ! 169: : b(?do) ! 170: postpone ?do ! 171: read-fcode-offset drop ! 172: ; immediate ! 173: ! 174: : b(loop) ! 175: postpone loop ! 176: read-fcode-offset drop ! 177: ; immediate ! 178: ! 179: : b(+loop) ! 180: postpone +loop ! 181: read-fcode-offset drop ! 182: ; immediate ! 183: ! 184: : b(leave) ! 185: postpone leave ! 186: ; immediate ! 187: ! 188: : new-token \ unnamed local fcode function ! 189: align here next-ip read-fcode# 0 swap set-token ! 190: ; ! 191: ! 192: : external-token ( -- ) \ named local fcode function ! 193: next-ip read-fcode-string ! 194: header ( str len -- ) \ create a header in the current dictionary entry ! 195: new-token ! 196: ; ! 197: ! 198: : new-token ! 199: eva-debug? IF ! 200: s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup ! 201: header ! 202: THEN new-token ! 203: ; ! 204: ! 205: : named-token \ decide wether or not to give a new token an own name in the dictionary ! 206: fcode-debug? IF new-token ELSE external-token THEN ! 207: ; ! 208: ! 209: : b(to) ( x -- ) ! 210: next-ip read-fcode# ! 211: get-token drop ! 212: >body cell - ! 213: ?compile-mode IF literal, postpone ! ELSE ! THEN ! 214: ; immediate ! 215: ! 216: : b(value) ! 217: <value> , , reveal ! 218: ; ! 219: ! 220: : b(variable) ! 221: <variable> , 0 , reveal ! 222: ; ! 223: ! 224: : b(constant) ! 225: <constant> , , reveal ! 226: ; ! 227: ! 228: : undefined-defer ! 229: cr cr ." Unititialized defer word has been executed!" cr cr ! 230: true fcode-end ! ! 231: ; ! 232: ! 233: : b(defer) ! 234: <defer> , reveal ! 235: postpone undefined-defer ! 236: ; ! 237: ! 238: : b(create) ! 239: <variable> , ! 240: postpone noop reveal ! 241: ; ! 242: ! 243: : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) ! 244: <colon> , over literal, ! 245: postpone + postpone exit ! 246: + ! 247: ; ! 248: ! 249: : b(buffer:) ( E: -- a-addr) ( F: size -- ) ! 250: <variable> , allot ! 251: ; ! 252: ! 253: : suspend-fcode ( -- ) ! 254: noop \ has to be implemented more efficiently ;-) ! 255: ; ! 256: ! 257: : offset16 ( -- ) ! 258: 16 to fcode-offset ! 259: ; ! 260: ! 261: : version1 ( -- ) ! 262: 1 to fcode-spread ! 263: 8 to fcode-offset ! 264: read-header ! 265: ; ! 266: ! 267: : start0 ( -- ) ! 268: 0 to fcode-spread ! 269: offset16 ! 270: read-header ! 271: ; ! 272: ! 273: : start1 ( -- ) ! 274: 1 to fcode-spread ! 275: offset16 ! 276: read-header ! 277: ; ! 278: ! 279: : start2 ( -- ) ! 280: 2 to fcode-spread ! 281: offset16 ! 282: read-header ! 283: ; ! 284: ! 285: : start4 ( -- ) ! 286: 4 to fcode-spread ! 287: offset16 ! 288: read-header ! 289: ; ! 290: ! 291: : end0 ( -- ) ! 292: true fcode-end ! ! 293: ; ! 294: ! 295: : end1 ( -- ) ! 296: end0 ! 297: ; ! 298: ! 299: : ferror ( -- ) ! 300: clear end0 ! 301: cr ." FCode# " fcode-num @ . ." not assigned!" ! 302: cr ." FCode evaluation aborted." cr ! 303: ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr ! 304: abort ! 305: ; ! 306: ! 307: : reset-local-fcodes ! 308: FFF 800 DO ['] ferror 0 i set-token LOOP ! 309: ; ! 310: ! 311: : byte-load ( addr xt -- ) ! 312: >r >r ! 313: save-evaluator-state ! 314: r> r> ! 315: reset-fcode-end ! 316: 1 to fcode-spread ! 317: dup 1 = IF drop ['] rb@ THEN to fcode-rb@ ! 318: set-ip ! 319: reset-local-fcodes ! 320: depth >r ! 321: evaluate-fcode ! 322: r> depth 1- <> IF clear end0 ! 323: cr ." Ambiguous stack depth after byte-load!" ! 324: cr ." FCode evaluation aborted." cr cr ! 325: ELSE restore-evaluator-state ! 326: THEN ! 327: ['] c@ to fcode-rb@ ! 328: ; ! 329: ! 330: create byte-load-test-fcode ! 331: f1 c, 08 c, 18 c, 69 c, 00 c, 00 c, 00 c, 68 c, ! 332: 12 c, 16 c, 62 c, 79 c, 74 c, 65 c, 2d c, 6c c, ! 333: 6f c, 61 c, 64 c, 2d c, 74 c, 65 c, 73 c, 74 c, ! 334: 2d c, 66 c, 63 c, 6f c, 64 c, 65 c, 21 c, 21 c, ! 335: 90 c, 92 c, ( a6 c, a7 c, 2e c, ) 00 c, ! 336: ! 337: : byte-load-test ! 338: byte-load-test-fcode ['] w@ ! 339: ; immediate ! 340: ! 341: : fcode-ms ! 342: s" ms" $find IF 0= IF compile, ELSE execute THEN THEN ; immediate ! 343: ! 344: : fcode-$find ! 345: $find ! 346: IF ! 347: drop true ! 348: ELSE ! 349: false ! 350: THEN ! 351: ; ! 352: ! 353: ( ---------------------------------------------------- )
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.