Annotation of gforth/arch/4stack/prim-new.fs, revision 1.1
1.1 ! pazsan 1: \ 4stack primitives
! 2:
! 3: Label start ;;
! 4: nop ;; first opcode must be a nop!
! 5: $80000000 ## ;;
! 6: #, ;;
! 7: sr! jmpa $828 >IP ;;
! 8:
! 9: $800 .org
! 10: ip0: .int 0
! 11: .int 0
! 12: conpat: nop nop ip@ jmpa ;;
! 13: varpat: nop nop ip@ jmpa ;;
! 14: jmppat: nop ip@ nop jmpa ;;
! 15: colpat: nop nop ip@ jmpa ;;
! 16: ;; ds cfa fs rs
! 17: main: ;;
! 18: -$200 ## nop nop nop -12 # ld 1: ip ;;
! 19: #, nop nop nop set 0: R3 ;;
! 20: nop nop nop nop 0 # set 1: R1 ;;
! 21: nop nop nop nop 0 # ld 1: R1 N+ ;;
! 22: nop nop nop nop 0 # ld 1: R1 N+ ;;
! 23: nop ip! nop nop 0 # ld 1: R1 N+ ;;
! 24: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 25:
! 26: docol: .endif ;;
! 27: ;; nop nop ip@ jmp docol ;;
! 28: ;; ds ca cfa fs rs
! 29: nop 8 # drop -12 # get 0: R1 get 3: R1 ;;
! 30: drop add 0s0 nop add 0 # set 1: R1 ;;
! 31: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 32: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 33: nop ip! nop nop 0 # ld 1: R1 N+ ;;
! 34: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 35: dodoes: .endif ;;
! 36: ;; nop nop ip@ jmp doesjump
! 37: ;; nop ip@ nop jmp dodoes
! 38: ;; ds df ca cfa fs rs
! 39: 8 # nop drop -12 # get 0: R1 get 3: R1 ;;
! 40: add nop nop add 0 # set 1: R1 ;;
! 41: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 42: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 43: nop ip! nop nop 0 # ld 1: R1 N+ ;;
! 44: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 45: dovar: .endif ;;
! 46: ;; nop nop ip@ jmp dovar ;;
! 47: ;; ds cfa fs rs
! 48: 8 # swap ip! nop get 0: R1 ;;
! 49: add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 50:
! 51: docon: .endif ;;
! 52: ;; nop nop ip@ jmp dovar ;;
! 53: ;; ds cfa fs rs
! 54: nop swap ip! nop ld 0: R1 2 # ;;
! 55: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 56: end-code
! 57:
! 58: -3 Alias: :docon
! 59:
! 60: Code execute ( xt -- )
! 61: nop nop nop ip@ br .endif
! 62: ip! drop pick 0s0 nop set 2: R1 ;;
! 63: nop nop nop ip! -1 # ld 1: R1 ;;
! 64: end-code
! 65:
! 66: Code ?branch
! 67: nop nop nop ip@ br .endif
! 68: nop swap nop nop br 0 ?0<>
! 69: nop nop nop nop -12 # R1= R1 3: +s0 ;;
! 70: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 71: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 72: .endif
! 73: nop ip! nop drop 0 # ld 1: R1 N+ ;;
! 74: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 75: end-code
! 76:
! 77: Code +
! 78: add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 79: end-code
! 80:
! 81: Code and
! 82: and ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 83: end-code
! 84:
! 85: Code xor
! 86: xor ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 87: end-code
! 88:
! 89: Code sp@
! 90: sp@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 91: end-code
! 92:
! 93: Code sp!
! 94: sp! ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 95: end-code
! 96:
! 97: Code rp@
! 98: nop nop ip@ sp@ br .endif
! 99: pick 3s0 swap ip! drop ;;
! 100: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 101: end-code
! 102:
! 103: Code rp!
! 104: drop nop ip@ pick 0s0 br .endif
! 105: nop swap ip! sp! ;;
! 106: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 107: end-code
! 108:
! 109: Code ;s
! 110: nop nop nop nop br .endif
! 111: nop drop nop nop 0 # set 3: R1 ;;
! 112: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 113: nop nop nop nop 0 # ld 1: R1 N+ ;;
! 114: nop ip! nop nop 0 # ld 1: R1 N+ ;;
! 115: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 116: end-code
! 117:
! 118: Code @
! 119: nop nop ip@ nop br .endif
! 120: drop swap ip! nop ld 0: s0b 0 # ;;
! 121: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 122: end-code
! 123:
! 124: Code !
! 125: nop nop ip@ nop br .endif
! 126: drop swap ip! nop st 0: s0b 0 # ;;
! 127: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 128: end-code
! 129:
! 130: \ obligatory IO
! 131:
! 132: Code key?
! 133: nop nop ip@ nop br .endif
! 134: nop swap nop nop inb R3 3 # ;;
! 135: nop nop ip! nop ;;
! 136: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 137: end-code
! 138:
! 139: Code (key)
! 140: nop nop ip@ nop br .endif
! 141: .begin inb R3 3 # ;;
! 142: nop br 0 ?0= .until
! 143: inb R3 2 # ;;
! 144: nop swap ip! nop ;;
! 145: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 146: end-code
! 147:
! 148: Code (emit)
! 149: nop nop ip@ nop br .endif
! 150: ;; .begin inb R3 1 # ;;
! 151: ;; nop br 0 ?0= .until
! 152: outb 0: R3 0 # ;;
! 153: nop swap ip! nop ;;
! 154: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 155: end-code
! 156:
! 157: : (type)
! 158: bounds ?DO I c@ (emit) LOOP ;
! 159: \ BEGIN dup WHILE
! 160: \ >r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
! 161:
! 162: \ obligatory code address manipulations
! 163:
! 164: : >code-address ( xt -- addr ) cell+ @ -8 and ;
! 165: : >does-code ( xt -- addr )
! 166: cell+ @ -8 and \ dup 3 and 3 <> IF drop 0 EXIT THEN
! 167: 8 + dup cell - @ 3 and 0<> and ;
! 168: : code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ;
! 169: : does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ;
! 170: : does-handler! ( a_addr -- ) $818 2@ rot 2! ;
! 171:
! 172: \ this was obligatory, now some things to speed it up
! 173:
! 174: Code 2/
! 175: asr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 176: end-code
! 177:
! 178: Code branch
! 179: nop nop nop ip@ br .endif
! 180: nop nop nop nop -12 # R1= R1 3: +s0 ;;
! 181: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 182: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 183: nop ip! nop drop 0 # ld 1: R1 N+ ;;
! 184: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 185: end-code
! 186:
! 187: Code (loop)
! 188: pick 3s1 nop nop ip@ br .endif
! 189: dec nop nop nop ;;
! 190: sub 3s1 swap nop nop br 0 ?0=
! 191: nop nop nop nop -12 # R1= R1 3: +s0 ;;
! 192: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 193: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 194: .endif
! 195: nop ip! nop drop 0 # ld 1: R1 N+ ;;
! 196: nop ip! ip@ inc set 2: R1 ld 1: R1 N+ ;;
! 197: end-code
! 198:
! 199: Code (+loop)
! 200: pick 3s1 nop nop ip@ br .endif
! 201: subr 3s1 nop nop nop ;;
! 202: xor #min nop nop nop ;;
! 203: add s1 swap nop nop br 0 ?ov
! 204: nop nop nop nop -12 # R1= R1 3: +s0 ;;
! 205: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 206: nop drop nop nop 0 # ld 1: R1 N+ ;;
! 207: .endif
! 208: nop ip! nop drop 0 # ld 1: R1 N+ ;;
! 209: drop ip! ip@ add 0s0 set 2: R1 ld 1: R1 N+ ;;
! 210: end-code
! 211:
! 212: Code (do)
! 213: nop nop ip@ nop br .endif
! 214: nip swap ip! pick 0s1 ;;
! 215: drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
! 216: end-code
! 217:
! 218: Code -
! 219: subr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 220: end-code
! 221:
! 222: Code or
! 223: or ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 224: end-code
! 225:
! 226: Code 1+
! 227: inc ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 228: end-code
! 229:
! 230: Code 2*
! 231: asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 232: end-code
! 233:
! 234: Code cell+
! 235: add c2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 236: end-code
! 237:
! 238: Code cells
! 239: nop nop ip@ nop br .endif
! 240: asl swap ip! nop ;;
! 241: asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 242: end-code
! 243:
! 244: Code c@
! 245: nop nop ip@ nop br .endif
! 246: drop swap ip! nop ldb 0: s0b 0 # ;;
! 247: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 248: end-code
! 249:
! 250: Code c!
! 251: nop nop ip@ nop br .endif
! 252: drop swap ip! nop stb 0: s0b 0 # ;;
! 253: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 254: end-code
! 255:
! 256: Code um*
! 257: nop nop ip@ nop br .endif
! 258: umul swap ip! nop ;;
! 259: mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 260: end-code
! 261:
! 262: Code m*
! 263: nop nop ip@ nop br .endif
! 264: mul swap ip! nop ;;
! 265: mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 266: end-code
! 267:
! 268: Code d+
! 269: nop nop ip@ nop br .endif
! 270: pass swap ip! nop ;;
! 271: mul@+ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 272: end-code
! 273:
! 274: Code >r
! 275: drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
! 276: end-code
! 277:
! 278: Code r>
! 279: pick 3s0 ip! ip@ drop set 2: R1 ld 1: R1 N+ ;;
! 280: end-code
! 281:
! 282: Code drop
! 283: drop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 284: end-code
! 285:
! 286: Code swap
! 287: swap ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 288: end-code
! 289:
! 290: Code over
! 291: over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 292: end-code
! 293:
! 294: Code 2dup
! 295: nop nop ip@ nop br .endif
! 296: over swap ip! nop ;;
! 297: over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 298: end-code
! 299:
! 300: Code rot
! 301: rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 302: end-code
! 303:
! 304: Code -rot
! 305: nop nop ip@ nop br .endif
! 306: rot swap ip! nop ;;
! 307: rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 308: end-code
! 309:
! 310: Code i
! 311: pick 3s0 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 312: end-code
! 313:
! 314: Code i'
! 315: pick 3s1 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 316: end-code
! 317:
! 318: Code j
! 319: pick 3s2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 320: end-code
! 321:
! 322: Code lit
! 323: ip@ nop pick 1s0 nop br .endif ;;
! 324: nop nip ip! nop 0 # ld 1: R1 N+ ;;
! 325: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 326: end-code
! 327:
! 328: Code 0=
! 329: 0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 330: end-code
! 331:
! 332: Code 0<>
! 333: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 334: end-code
! 335:
! 336: Code u<
! 337: nop nop ip@ nop br .endif
! 338: subr swap ip! nop ;;
! 339: u< ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 340: end-code
! 341:
! 342: Code u>
! 343: nop nop ip@ nop br .endif
! 344: subr swap ip! nop ;;
! 345: u> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 346: end-code
! 347:
! 348: Code u>=
! 349: nop nop ip@ nop br .endif
! 350: subr swap ip! nop ;;
! 351: u>= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 352: end-code
! 353:
! 354: Code u<=
! 355: nop nop ip@ nop br .endif
! 356: subr swap ip! nop ;;
! 357: u<= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 358: end-code
! 359:
! 360: Code >=
! 361: nop nop ip@ nop br .endif
! 362: subr swap ip! nop ;;
! 363: >= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 364: end-code
! 365:
! 366: Code <=
! 367: nop nop ip@ nop br .endif
! 368: subr swap ip! nop ;;
! 369: <= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 370: end-code
! 371:
! 372: Code =
! 373: nop nop ip@ nop br .endif
! 374: subr swap ip! nop ;;
! 375: 0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 376: end-code
! 377:
! 378: Code <>
! 379: nop nop ip@ nop br .endif
! 380: subr swap ip! nop ;;
! 381: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 382: end-code
! 383:
! 384: \ : (find-samelen) ( u f83name1 -- u f83name2/0 )
! 385: \ BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
! 386: Code (find-samelen)
! 387: nop nop ip@ nop br .endif
! 388: nop 0 # 0 # nop ;;
! 389: nop nop pick 0s0 nop ;;
! 390: .begin
! 391: drop drop nop nop ldb 0: s0b 4 # ;;
! 392: nop $1F # nip nop ld 2: s0b 0 # ;;
! 393: drop and 0s0 nop nop ;;
! 394: pick 2s0 sub 0s0 nop nop br 1&2 :0<> .until ;;
! 395: pick 2s1 nop pass nop br 1 ?0= ;;
! 396: drop swap ip! nop ;;
! 397: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 398: .endif
! 399: nip swap ip! nop ;;
! 400: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
! 401: end-code
! 402:
! 403: \ division a/b
! 404: \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
! 405: \ result: x=a/b; y=1; r=1
! 406:
! 407: \ Label idiv-table
! 408: \ idiv-tab:
! 409: \ .macro .idiv-table [F]
! 410: \ $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
! 411: \ .end-macro
! 412: \ .idiv-table
! 413: \ end-code
! 414: \
! 415: \ Code um/mod1 ( u -- 1/u )
! 416: \ ;; b -- -- -- -- -- ;;
! 417: \ ff1 -$1F # nop nop br 0 :0= div0
! 418: \ bfu add 0s0 ip@ nop set 2: R2 ;;
! 419: \ ;; b' -- -- -- -- -- ;;
! 420: \ lob $0FF ## pick 0s0 pick 0s0 0 # -$108 ## ;;
! 421: \ 1 # #, sub #min 1 # ld 0: R2 +s0 #, ;;
! 422: \ cm! and nop cm! br 2 ?0= by2
! 423: \ ;; est -- -- b' -- -- ;;
! 424: \ umul 3s0 pick 0s0 nop umul 0s0 0 # 0 # ;;
! 425: \ mulr<@ nop nop -mulr@ ;;
! 426: \ drop umul 3s0 nop umul 0s0 ;;
! 427: \ mulr<@ cm! nop -mulr@ ;;
! 428: \ umul 3s0 drop pick 1s0 drop ;;
! 429: \ drop mulr<@ ip! nop 0 # ld 1: R1 N+ ;;
! 430: \ pick 1s0 drop nop nop ;;
! 431: \ by2:
! 432: \ div0:
! 433: \ -1 # ip! nop nop 0 # ld 1: R1 N+ ;;
! 434: \ nop nop nop nop ;;
! 435: \ end-code
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prim-new.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / 4stack