\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are \ opcodes or short runs of them, and the variables that are in-line addresses. \ \ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18). \ A word flagged inline is copied into a definition in place of a call; the \ ones that touch the return stack are compile-only as well. Rests on core.v4, \ compile.v4's loader constants, and quit.v4, which the division words leave \ through when the divisor is zero. (F) is seven cells of scratch for \ this file. \ ---- stack ---- header DUP inline : DUP dup ; header DROP inline : DROP drop ; header OVER inline : OVER over ; header SWAP inline : SWAP' SWAP ; header ROT inline : ROT' ROT ; header -ROT inline : -ROT SWAP push SWAP pop ; header ?DUP : ?DUP if Z dup ; Z: ; header 2DUP inline : 2DUP over over ; header 2DROP inline : 2DROP drop drop ; \ ---- the stack as a whole (D-16) ---- \ DEPTH reads the stack register. PICK and ROLL reach under the top of a \ stack that has no addresses: the values above the one wanted are set aside \ in (S), and put back. (F)+3 how many are still to set aside, (F)+4 where \ the next goes, (F)+5 the value wanted, (F)+6 how many are set aside. With n on top of a stack that is \ otherwise one short of full there is no room at all, so until a value has been set aside nothing here pushes \ anything while n is still there, and never more than one cell after. \ FORTH-79: how many values were on the stack before DEPTH header DEPTH : DEPTH DSTACK-DEPTH b! @b ; \ ( name -- ) "xxxx: Invalid index", and the line ends with ERROR : (INDEX) R-CLEAR (EMIT4) $6E49203A (EMIT4) $696C6176 (EMIT4) $6E692064 (EMIT4) $786564 (EMIT4) CR 2 jump (DONE) \ ( x1 .. xn-1 -- ) A: n, which is 2 or more. Set the n-1 values above \ the n-th aside. If there are not that many, the pop that finds the stack \ empty is a fault: "Stack underflow". The count is taken down only after a \ value has been set aside, when there is room to do the arithmetic. : (DIG) (F)+3 b! a !b (F)+4 b! (S) !b (F)+6 b! 0 !b L: (F)+4 b! @b a! !+ a (F)+4 b! !b (F)+6 b! @b 1 + !b (F)+3 b! @b -1 + dup !b -1 + if DONE drop jump L DONE: drop ; \ ( -- x1 .. xk ) put them back. The test that ends it pushes one cell: \ after the last value is back the stack may be one short of full. : (BURY) L: (F)+6 b! @b if DONE -1 + !b (F)+4 a! @ -1 + dup ! a! @ jump L DONE: drop ; \ ( n -- x ) FORTH-79: a copy of the n-th value, not counting n itself. \ 1 PICK is DUP, 2 PICK is OVER. n less than one is an error. header PICK : PICK -if POS jump BAD POS: if BAD a! a 2/ if ONE drop \ n is 1 when half of it is 0 (DIG) dup (F)+5 a! ! (BURY) (F)+5 a! @ ; ONE: drop dup ; BAD: drop $4B434950 jump (INDEX) \ ( n -- ) FORTH-79: the n-th value, not counting n itself, is taken out \ and put on top. 3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing. n \ less than one is an error. header ROLL : ROLL -if POS jump BAD POS: if BAD a! a 2/ if ONE drop (DIG) (F)+5 a! ! (BURY) (F)+5 a! @ ; ONE: drop ; BAD: drop $4C4C4F52 jump (INDEX) \ ---- return stack: in line, and only inside a definition ---- header >R inline compile-only : >R push ; header R> inline compile-only : R> pop ; header R@ inline compile-only : R@ pop dup push ; header I inline compile-only : I pop dup push ; header J inline compile-only : J pop pop pop dup push a! push push a ; header LEAVE inline compile-only : LEAVE pop pop drop dup push push ; header UNLOOP inline compile-only : UNLOOP pop drop pop drop ; \ ---- memory ---- header @ inline : FETCH a! @ ; header ! inline : STORE a! ! ; header +! inline : +! a! @ + ! ; header CELLS inline : CELLS ; \ an address unit is a cell (D-1) \ ---- arithmetic ---- header + inline : PLUS + ; header - inline : MINUS - ; \ The low cell of the product, by N steps of +* with nothing but the count on \ the return stack. UM* drop gives the same cell but needs two more return \ entries, which a word inside two DO loops does not have (D-2). The low \ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach \ the bit that moves into A, and the loop ends first. header * : STAR a! 0 N-1 FOR +* UNEXT drop drop a ; header NEGATE inline : NEGATE' NEGATE ; header 1+ inline : 1+ 1 + ; header 1- inline : 1- -1 + ; header 2+ inline : 2+ 2 + ; header 2- inline : 2- -2 + ; header 2* inline : TWO* 2* ; header 2/ inline : TWO/ 2/ ; \ ---- division (sections 4 and 5.6) ---- \ Division by zero is guarded (D-15): each word tests its divisor before it \ does anything else, and a zero divisor prints v3's message -- \ /: Division by zero \ -- and ends the line with ERROR, from however deep, as an address fault \ does. The word's operands are taken off the stack, as v3 takes them, and \ its caller is not returned to. \ ( name2 name1 -- ) the word's name: its first four characters, and the \ rest or 0 (EMIT4). The return stack is emptied before anything is called: \ the word may have been run with it full. : (DIV0) R-CLEAR (EMIT4) (EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b" $657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero" 2 jump (DONE) \ ( d n -- rem quot ) truncating toward zero: the quotient has the sign of \ d xor n, the remainder the sign of d. This is section 4's SM/REM with its \ UM/MOD -- restoring division, one step a bit, the divisor in A -- written \ into it, and the two signs kept in (F) where section 4 has them on the \ return stack. A word that divides is then four return entries deep, not \ eight, so division can be used inside words that other words call (D-2). \ The answer is the same. Exact when the quotient fits a cell; its callers \ have seen to it that n is not zero. : SM/REM over over xor (F) a! ! \ the quotient's sign, in its top bit over (F)+1 a! ! \ the remainder's -if L0 inv 1 + L0: a! \ A: |n| -if L1 DNEGATE L1: \ |d| N-1 FOR -if S0 2* over -if S1 drop 1 + jump S2 S1: drop S2: push 2* pop jump SUB S0: 2* over -if S3 drop 1 + jump S4 S3: drop S4: push 2* pop dup a xor -if S5 drop -if NOSUB jump SUB S5: drop dup inv a + inv -if S6 drop jump NOSUB S6: push drop pop jump SETBIT SUB: inv a + inv SETBIT: push 1 + pop NOSUB: NEXT over push push drop pop pop \ urem uquot (F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3: (F) a! @ -if L4 drop inv 1 + ; L4: drop ; header S>D : S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ; \ The product's sign waits in (F), not on the return stack, for the same \ reason as SM/REM's. header M* : M* ( n1 n2 -- d ) over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM* (F) a! @ -if P drop jump DNEGATE P: drop ; \ ( n1 n2 n3 -- rem quot ) n1 * n2 as a double, divided by n3, which is \ not zero. M* is written in, and n3 waits in (F)+2, so that the multiply \ is as few return entries down as it can be. : (*/MOD) (F)+2 a! ! over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM* (F) a! @ -if P drop DNEGATE jump Q P: drop Q: (F)+2 a! @ jump SM/REM header /MOD : /MOD ( n1 n2 -- rem quot ) if Z push S>D pop jump SM/REM Z: drop drop 0 $444F4D2F jump (DIV0) header / : / ( n1 n2 -- quot ) if Z push S>D pop SM/REM NIP ; Z: drop drop 0 $2F jump (DIV0) header MOD : MOD ( n1 n2 -- rem ) if Z push S>D pop SM/REM drop ; Z: drop drop 0 $444F4D jump (DIV0) header */MOD : */MOD ( n1 n2 n3 -- rem quot ) if Z jump (*/MOD) Z: drop drop drop $44 $4F4D2F2A jump (DIV0) header */ : */ ( n1 n2 n3 -- quot ) if Z (*/MOD) NIP ; Z: drop drop drop 0 $2F2A jump (DIV0) header M/MOD : M/MOD ( d n -- rem quot ) if Z jump SM/REM Z: drop drop drop $44 $4F4D2F4D jump (DIV0) \ ---- logic and comparison ---- header AND inline : AND and ; header XOR inline : XOR xor ; header OR inline : OR' OR ; header 0= : 0= if L1 drop 0 ; L1: drop -1 ; header 0< : 0< -if L1 drop -1 ; L1: drop 0 ; header NOT : NOT jump 0= header = : EQUALS xor jump 0= header < : LESS over over xor -if SAME drop drop jump 0< SAME: drop - jump 0< header > : GREATER SWAP jump LESS \ ---- in-line addresses and constants ---- header BL inline : BL' BL ; header TIB inline : TIB' TIB ; header >IN inline : >IN' >IN ; header SPAN inline : SPAN' SPAN ; header BASE inline : BASE' BASE ; header PAD inline : PAD' PAD ; header STATE inline : STATE' STATE ;