Category : Forth Source Code
Archive   : ZEN15A.ZIP
Filename : RUNTIME.SRC
;
; ZEN 1.15 Macros and internals
; C 1991 by Martin Tracy
;
TRUTH EQU 0FFFFh ; Boolean value for true
LINKED = 0 ; Initial link field value
CSDummy LABEL WORD ; used like: lods cs:CSDummy
NEXT MACRO
lods cs:CSDummy
jmp ax
ENDM
ISCOLON MACRO
call DoColon
ENDM
ISCONSTANT MACRO
jmp DoConstant
ENDM
ISVARIABLE MACRO
jmp DoVariable
ENDM
ISCREATE MACRO
jmp DoCreate
ENDM
ISVALUE MACRO
jmp NEAR PTR DoValue
jmp NEAR PTR DoValTo
ENDM
;
jmp Coldstart ; Must be 1st 3 bytes of code.
;
; Code fields
;
; Colon definition code field.
DoColon PROC
dec bp
dec bp
mov [bp],si
pop si
NEXT
DoColon ENDP
; DOES> code field.
DoDoes PROC
dec bp
dec bp
mov [bp],si
pop si
push bx
add ax,3
xchg ax,bx
mov bx,cs:[bx]
NEXT
DoDoes ENDP
; CONSTANT VARIABLE and CREATE code fields.
DoConstant PROC ; ( - w)
DoVariable:
DoCreate:
push bx
add ax,3
xchg ax,bx
mov bx,cs:[bx]
NEXT
DoConstant ENDP
; VALUE 1st code field
DoValue PROC ; ( - w)
push bx
add ax,6
xchg ax,bx
mov bx,cs:[bx]
mov bx,[bx]
NEXT
DoValue ENDP
; VALUE 2nd code field
DoValTo PROC ; ( w)
add ax,3
xchg ax,di
mov di,cs:[di]
mov [di],bx
pop bx
NEXT
DoValTo ENDP
;
; In-liners
;
; Push following in-line cell onto stack.
Lit: ; ( - w)
Tic: lods cs:CSDummy
push bx
mov bx,ax
NEXT
; String primitive
SLit: ; ( - addr u)
lods cs:CSDummy
push bx
mov bx,ax
inc ax
push ax
mov bl,[bx]
sub bh,bh
NEXT
END-ASSEMBLER
\ Branch if arguments unequal.
CODE OfBranch ( w w | w w2 - w)
mov ax,bx
pop bx
cmp bx,ax
jnz Branch
pop bx
add si,2
NEXT
END-CODE
\ Branch if false.
CODE ZBranch ( f)
or bx,bx
pop bx
jz Branch
add si,2
NEXT
END-CODE
\ Branch always.
CODE Branch
mov si,cs:[si]
NEXT
END-CODE
\ Begin ?DO ... ?LOOP
CODE QDo ( n n2)
pop ax
cmp ax,bx
jne QDo1
pop bx
jmp Branch
QDo1: push ax
add si,2
jmp RDo
END-CODE
\ Begin DO ... LOOP or DO ... +LOOP
CODE RDo ( n n2)
sub bp,4
pop ax
add ax,8000h
mov [bp+2],ax
sub bx,ax
mov [bp],bx
pop bx
NEXT
END-CODE
\ End DO ... LOOP
CODE RLoop
inc WORD PTR [bp]
jno Branch
Loop2: add si,2
_Undo: add bp,4
NEXT
END-CODE
\ End DO ... +LOOP
CODE PLoop ( n)
add [bp],bx
pop bx
jno Branch
jo Loop2
NEXT
END-CODE
\ Return to the calling definition.
CODE EXIT ( ) \ C, CORE
mov si,[bp]
inc bp
inc bp
NEXT
END-CODE
\ Undoes one level of loop nesting.
CODE UNLOOP ( ) \ C, CORE EXT
jmp _Undo
END-CODE
\ Execute execution token w
CODE EXECUTE ( w) \ CORE
xchg ax,bx
pop bx
jmp ax
END-CODE
\ Equivalent to @ EXECUTE
\ Does nothing if execution token is zero
CODE @EXECUTE ( a)
mov bx,[bx]
mov ax,bx
pop bx
jmp ax
NEXT
END-CODE
\ Duplicate top stack item.
CODE DUP ( w - w w) \ CORE
push bx
NEXT
END-CODE
\ Drop top stack item.
CODE DROP ( w) \ CORE
pop bx
NEXT
END-CODE
\ Swap top two stack items.
CODE SWAP ( w w2 - w2 w) \ CORE
mov di,sp
xchg bx,ss:[di]
NEXT
END-CODE
\ Copy second stack item to top of stack.
CODE OVER ( w w2 - w w2 w) \ CORE
mov di,sp
push bx
mov bx,ss:[di]
NEXT
END-CODE
\ Rotate third stack item into top position.
CODE ROT ( w w2 w3 - w2 w3 w) \ CORE
pop dx
pop ax
push dx
push bx
mov bx,ax
NEXT
END-CODE
\ Rotate top stack item into third position.
CODE -ROT ( w w2 w3 - w3 w w2)
pop dx
pop ax
push bx
push ax
mov bx,dx
NEXT
END-CODE
COMMENTS
\ Rotate top stack item into third position.
: -ROT ( w w2 w3 - w3 w w2)
ROT ROT ;
END-COMMENTS
\ Copy kth item to top of stack.
CODE PICK ( w[u]... w[0] u - w[u]... w[0] w[u]) \ CORE EXT
shl bx,1
add bx,sp
mov bx,ss:[bx]
NEXT
END-CODE
\ Rotates kth item to top of stack, k<64.
: ROLL ( nm .. nk .. n1 n0 k - nm .. n1 n0 nk) \ CORE EXT
DUP BEGIN ?DUP WHILE ROT >R 1- REPEAT
BEGIN ?DUP WHILE R> -ROT 1- REPEAT ;
\ Drop second stack item.
CODE NIP ( w w2 - w2) \ CORE EXT
pop ax
NEXT
END-CODE
\ Copy top stack item under second item.
CODE TUCK ( w w2 - w2 w w2) \ CORE EXT
pop ax
push bx
push ax
NEXT
END-CODE
\ Duplicate w if it is non-zero.
CODE ?DUP ( w - w w | 0 - 0) \ CORE
or bx,bx
jz Qd1
push bx
Qd1: NEXT
END-CODE
\ Move top stack item to return stack.
CODE >R ( w; R: - w) \ C, CORE
dec bp
dec bp
mov [bp],bx
pop bx
NEXT
END-CODE
\ Copy top return stack item to data stack.
CODE R@ ( - w; R: w - w) \ C, CORE
push bx
mov bx,[bp]
NEXT
END-CODE
\ Move top return stack item to data stack.
CODE R> ( - w; R: w) \ C, CORE
push bx
mov bx,[bp]
inc bp
inc bp
NEXT
END-CODE
\ Copy the current (innermost) loop index.
CODE I ( - n) \ C, CORE
push bx
mov bx,[bp]
add bx,[bp+2]
NEXT
END-CODE
\ Copy the next outermost loop index.
CODE J ( - n) \ C, CORE
push bx
mov bx,[bp+4]
add bx,[bp+6]
NEXT
END-CODE
\ Move top stack pair to return stack.
CODE 2>R ( w w2; R: - w w2) \ C, CORE EXT
sub bp,4
mov [bp],bx
pop [bp+2]
pop bx
NEXT
END-CODE
\ Move top return stack pair to data stack.
CODE 2R> ( - w w2; R: w w2) \ C, CORE EXT
push bx
push [bp+2]
mov bx,[bp]
add bp,4
NEXT
END-CODE
\ Copy top return stack pair to data stack.
CODE 2R@ ( - w w2) \ C, CORE EXT
push bx
push [bp+2]
mov bx,[bp]
NEXT
END-CODE
\ Duplicate top stack pair.
CODE 2DUP (w w2 - w w2 w w2) \ C, CORE
mov di,sp
push bx
push ss:[di]
NEXT
END-CODE
\ Drop top stack pair.
CODE 2DROP ( w w2) \ CORE
pop bx
pop bx
NEXT
END-CODE
\ Swap top two stack pairs.
CODE 2SWAP ( w w2 w3 w4 - w3 w4 w w2) \ CORE
pop ax
pop cx
pop dx
push ax
push bx
push dx
mov bx,cx
NEXT
END-CODE
\ Copy second stack pair to top of stack.
CODE 2OVER ( w w2 w3 w4 - w w2 w3 w4 w w2) \ CORE
mov di,sp
push bx
push ss:[di+4]
mov bx,ss:[di+2]
NEXT
END-CODE
COMMENTS
\ Copy second stack pair to top of stack.
: 2OVER ( w w2 w3 w4 - w w2 w3 w4 w w2) \ CORE
2>R 2DUP 2R> 2SWAP ;
END-COMMENTS
\ Rotate third stack pair into top position.
: 2ROT ( w w2 w3 w4 w5 w6 - w3 w4 w5 w6 w w2) \ DOUBLE EXT
2>R 2SWAP 2R> 2SWAP ;
\ Fetch value at addr.
CODE @ ( addr - w) \ CORE
mov bx,[bx]
NEXT
END-CODE
\ Store w at addr.
CODE ! ( w addr) \ CORE
pop [bx]
pop bx
NEXT
END-CODE
\ Fetch byte value at addr.
CODE C@ ( addr - b) \ CORE
mov bl,[bx]
sub bh,bh
NEXT
END-CODE
\ Store lower byte value at addr.
CODE C! ( w addr) \ CORE
pop ax
mov [bx],al
pop bx
NEXT
END-CODE
\ Fetch pair at addr.
\ w2 is stored at addr; w is stored in next cell.
CODE 2@ ( addr - w w2) \ CORE
TwoF1: push [bx+2]
mov bx,[bx]
NEXT
END-CODE
\ Store pair at addr.
\ w2 is stored at addr; w is stored in next cell.
CODE 2! ( w w2 addr) \ CORE
TwoS1: pop [bx]
pop [bx+2]
pop bx
NEXT
END-CODE
\ Fetch double number at addr.
CODE D@ ( addr d) \ DOUBLE EXT
jmp TwoF1
END-CODE
\ Store double number at addr.
CODE D! ( addr d) \ DOUBLE EXT
jmp TwoS1
END-CODE
0 CONSTANT 0 \ fast zero.
1 CONSTANT 1 \ fast one.
-1 CONSTANT TRUE \ fast Boolean true. CORE
0 CONSTANT FALSE \ faxt Boolean false. CORE EXT
\ Add n to n2
CODE + ( n n2 - n3) \ CORE
pop ax
add bx,ax
NEXT
END-CODE
\ Subtract n2 from n
CODE - ( n n2 - n3) \ CORE
pop ax
sub bx,ax
neg bx
NEXT
END-CODE
\ Change sign of n
CODE NEGATE ( n - n2) \ CORE
neg bx
NEXT
END-CODE
\ Absolute value of n
CODE ABS ( n - +n) \ CORE
or bx,bx
jns ABS2
neg bx
ABS2: NEXT
END-CODE
\ Add n to value at addr
CODE +! ( w addr) \ CORE
pop ax
add [bx],ax
pop bx
NEXT
END-CODE
\ Store 0 at address.
CODE OFF ( a )
mov WORD PTR [bx],0
pop bx
NEXT
END-CODE
\ Store -1 at address.
CODE ON ( a )
mov WORD PTR [bx],TRUTH
pop bx
NEXT
END-CODE
\ Multiply u by u2
CODE UM* ( u u2 - ud) \ CORE
pop ax
mul bx
push ax
mov bx,dx
NEXT
END-CODE
\ Divide ud by u giving quotient u3 remainder u2
CODE UM/MOD ( ud u - u2 u3) \ CORE
POP dx
SUB ax,ax
CMP dx,bx
jae UMO2
pop ax
div bx
push dx
UMO2: mov bx,ax
NEXT
END-CODE
COMMENTS
\ Signed mixed-precision multiply.
: M* ( n n2 - d) \ CORE
2DUP XOR >R ABS SWAP ABS UM* R> 0< IF NEGATE THEN ;
\ Signed symmetric mixed-precision divide.
: SM/MOD ( d n - rem quot) \ CORE
2DUP XOR >R OVER >R ABS >R DABS R> UM/MOD
SWAP R> 0< IF NEGATE THEN
SWAP R> 0< IF NEGATE THEN ;
\ Signed multiply.
: * ( n n2 - n3) \ CORE
UM* DROP ;
\ Add n to d.
: M+ ( d n - d2) \ DOUBLE
S>D D+ ;
\ Signed double by single multiply to triple result.
: T* ( d n - t)
2DUP XOR >R ABS >R DABS R>
2>R R@ UM* 0 2R> UM* D+ ( ie UT*)
R> 0< IF TNEGATE THEN ;
\ Signed triple by unsigned single symmetric divide to double result.
: TU/ ( t u - d)
OVER >R >R DUP 0< IF TNEGATE THEN
R@ UM/MOD -ROT R> UM/MOD -ROT DROP ( ie UT/)
R> 0< IF DNEGATE THEN ;
END-COMMENTS
\ Signed mixed-precision multiply.
CODE M* ( n n2 - d) \ DOUBLE
xchg ax,bx
pop dx
imul dx
push ax
mov bx,dx
NEXT
END-CODE
\ Signed symmetric mixed-precision divide.
CODE SM/MOD ( d n - rem quot) \ CORE
pop dx
pop ax
or bx,bx
jz sMM1
idiv bx
mov bx,ax
push dx
NEXT
sMM1: mov dx,ax ; divide by zero
mov bx,0
push dx
NEXT
END-CODE
\ Signed multiply.
CODE * ( n n2 - n3) \ CORE
pop ax
imul bx
mov bx,ax
NEXT
END-CODE
\ Signed symmetric divide leaving quotient and remainder.
: /MOD ( n n2 - rem quot) \ CORE
>R S>D R> SM/MOD ;
\ Signed symmetric divide
: / ( n n2 - quot) \ CORE
/MOD NIP ;
\ Signed symmetric remainder
: MOD ( n n2 - rem) \ CORE
/MOD DROP ;
\ Signed multiply n by n2 then signed divide by n3
\ Division leaves quotient and remainder.
\ Intermediate product is 32 bits.
: */MOD ( n n2 n3 - rem quot) \ CORE
>R M* R> SM/MOD ;
\ Signed multiply n by n2 then signed divide by n3
\ Intermediate product is 32 bits.
: */ ( n n2 n3 - quot) \ CORE
*/MOD NIP ;
\ Add n to d.
CODE M+ ( d n - d2) \ DOUBLE
xchg ax,bx
cwd
pop bx
pop cx
add cx,ax
push cx
adc bx,dx
NEXT
END-CODE
\ t2 is the negation of t.
: TNEGATE ( t - t2)
ROT INVERT 0 1 0 D+ >R ROT INVERT 0 R> 0 D+ >R
ROT INVERT R> + ;
\ Signed double by single multiply to triple result.
CODE T* ( d n - t)
mov cx,si
pop si
pop di
mov ax,di
mul bx
push ax
push cx
mov cx,dx
mov ax,si
mul bx
add cx,ax
adc ax,2
or si,si
jns Tstar1
sub dx,bx
Tstar1: or bx,bx
jns Tstar2
sub cx,di
sbb dx,si
Tstar2: pop si
push cx
mov bx,dx
NEXT
END-CODE
\ Signed triple by unsigned single floored divide to double result.
CODE TU/ ( t u - d)
pop dx
pop ax
pop cx
or bx,bx
pushf
jns Tslas1
neg bx
Tslas1: or dx,dx
jns Tslas2
add dx,bx
Tslas2: div bx
xchg ax,cx
div bx
popf
jns Tslas3
neg ax
adc ax,1
neg cx
Tslas3: push ax
mov bx,cx
NEXT
END-CODE
\ Multiply d by n to triple result; divide by +n2 to double result.
\ Whether division is floored or symmetric depends on TU/
: M*/ ( d n +n2 - d2) \ DOUBLE
>R T* R> TU/ ;
\ Add one to n
CODE 1+ ( n - n2) \ CORE
inc bx
NEXT
END-CODE
\ Subtract one from n
CODE 1- ( n - n2) \ CORE
dec bx
NEXT
END-CODE
\ Multiply n by two
CODE 2* ( n - n2) \ CORE
shl bx,1
NEXT
END-CODE
\ Divide n by two
CODE 2/ ( n - n2) \ CORE
sar bx,1
NEXT
END-CODE
\ Multiply d by two.
CODE D2* ( d - d2) \ DOUBLE
pop ax
sal ax,1
rol bx,1
push ax
NEXT
END-CODE
\ Divide d by two.
CODE D2/ ( d - d2) \ DOUBLE
pop ax
sar bx,1
ror ax,1
push ax
NEXT
END-CODE
\ Logically shift w n places.
\ Shift right if w negative, left if positive.
CODE SHIFT ( w n - w2) \ CORE
mov cx,bx
pop bx
or cx,cx
js Shift1
shl bx,cl
NEXT
Shift1: neg cx
shr bx,cl
NEXT
END-CODE
\ Reverse the bytes within a word.
CODE >< ( u - u2)
xchg bl,bh
NEXT
END-CODE
\ Add cell address units to address
CODE CELL+ ( a - a2) \ CORE
inc bx
inc bx
NEXT
END-CODE
\ Size in address units of n cells.
CODE CELLS ( n - n2) \ CORE
shl bx,1
NEXT
END-CODE
\ Add two double numbers.
CODE D+ ( d d2 - d3) \ DOUBLE
pop ax
pop dx
pop cx
add cx,ax
push cx
adc bx,dx
NEXT
END-CODE
\ Subtract d2 from d1
CODE D- ( d d2 - d3) \ DOUBLE
mov dx,bx
pop ax
pop bx
pop cx
sub cx,ax
push cx
sbb bx,dx
NEXT
END-CODE
\ Change sign of d
CODE DNEGATE ( d - d2) \ DOUBLE
pop ax
neg ax
push ax
adc bx,0
neg bx
NEXT
END-CODE
\ Extend n to d
CODE S>D ( n - d) \ CORE
xchg ax,bx
cwd
push ax
xchg bx,dx
NEXT
END-CODE
\ Truncate d to n
CODE D>S ( d - s) \ DOUBLE
pop bx
NEXT
END-CODE
\ Bitwise AND n and n2
CODE AND ( m m2 - m3) \ CORE
pop ax
and bx,ax
NEXT
END-CODE
\ Bitwise OR n and n2
CODE OR ( m m2 - m3) \ CORE
pop ax
or bx,ax
NEXT
END-CODE
\ Bitwise XOR n and n2
CODE XOR ( m m2 - m3) \ CORE
pop ax
xor bx,ax
NEXT
END-CODE
\ Bitwise inversion of n
CODE INVERT ( w - w2) \ CORE
not bx
NEXT
END-CODE
\ Logical inversion of flag.
CODE NOT ( w - f)
or bx,bx
mov bx,TRUTH
jz Not2
inc bx
Not2: NEXT
END-CODE
\ True if n equals zero
CODE 0= ( n - f) \ CORE
or bx,bx
mov bx,TRUTH
jz Ze2
inc bx
Ze2: NEXT
END-CODE
\ True if n is less than zero
CODE 0< ( n - f) \ CORE
or bx,bx
mov bx,TRUTH
js zl2
inc bx
zl2: NEXT
END-CODE
\ True if n is greater than zero.
: 0> ( n - f) \ CORE EXT
0 > ;
\ True if n is not zero.
: 0<> ( n - f) \ CORE EXT
0= NOT ;
\ True if n equals n2
CODE = ( n n2 - f) \ CORE
pop ax
cmp bx,ax
mov bx,TRUTH
je Eq2
inc bx
Eq2: NEXT
END-CODE
\ True if n unequal to n2
: <> ( n n2 - f) \ CORE EXT
= NOT ;
\ True if n is less than n2
CODE < ( n n2 - f) \ CORE
pop ax
sub ax,bx
mov bx,TRUTH
jl Lt2
inc bx
Lt2: NEXT
END-CODE
\ True if n is greater than n2
: > ( n n2 - f) \ CORE
SWAP < ;
\ True if u is less than u2 unsigned.
CODE U< ( u u2 - f) \ CORE
pop ax
sub ax,bx
mov bx,TRUTH
jb Ult2
inc bx
Ult2: NEXT
END-CODE
\ True if n is greater than n2 unsigned.
: U> ( u u2 - f) \ CORE EXT
SWAP U< ;
\ True if n <= u < n2 given circular comparison.
: WITHIN ( u n n2 - f) \ CORE EXT
OVER - >R - R> U< ;
\ Maximum of two numbers.
: MAX ( n n2 - n3) \ CORE
2DUP < IF SWAP THEN DROP ;
\ Minimum of two numbers.
: MIN ( n n2 - n3) \ CORE
2DUP < NOT IF SWAP THEN DROP ;
\ True if d is zero.
: D0= ( d - f) \ DOUBLE
OR 0= ;
\ True if d is negative.
: D0< ( d - f) \ DOUBLE
NIP 0< ;
\ True if d equals d2
: D= ( d d2 - f) \ DOUBLE
D- OR 0= ;
\ True if d is less than d2
: D< ( d d2 - f) \ DOUBLE
ROT 2DUP = IF 2DROP U< EXIT THEN
2SWAP 2DROP > ;
\ True if d is less than d2
: DU< ( d d2 - f) \ DOUBLE EXT
ROT 2DUP = IF 2DROP U< EXIT THEN
2SWAP 2DROP SWAP U< ;
\ Absolute value of d.
: DABS ( d - ud) \ DOUBLE
DUP 0< IF DNEGATE THEN ;
\ Maximum of two double numbers.
: DMAX ( d d2 - d3) \ DOUBLE
2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
\ Minimum of two double numbers.
: DMIN ( d d2 - d3) \ DOUBLE
2OVER 2OVER D< NOT IF 2SWAP THEN 2DROP ;
\ # items on stack before DEPTH is executed.
CODE DEPTH ( - n) \ CORE
push bx
mov bx,OFFSET DGROUP: SP0
sub bx,sp
sar bx,1
NEXT
END-CODE
\ Return current data stack pointer.
CODE sp@ ( - w)
push bx
mov bx,sp
NEXT
END-CODE
\ Return current return stack pointer.
CODE rp@ ( - w)
push bx
mov bx,bp
NEXT
END-CODE
\ Set data stack pointer.
CODE sp! ( w )
mov sp,bx
pop bx
NEXT
END-CODE
\ Set return stack pointer.
CODE rp! ( w )
mov bp,bx
pop bx
NEXT
END-CODE
\ Empty data stack pointer. Used like sp0 sp!
CODE sp0 ( - w)
push bx
mov bx,OFFSET DGROUP: sp0
NEXT
END-CODE
\ Empty return stack pointer. Used like rp0 rp!
CODE rp0 ( - w)
push bx
mov bx,OFFSET DGROUP: rp0
NEXT
END-CODE
VARIABLE hp \ Return stack pointer for CATCH and THROW
\ Push error frame and execute w; normally returns 0
\ THROW returns to code following CATCH with error n.
: CATCH ( i*w w - j*w 0 | i*w n) \ ERROR
sp@ hp @ 2>R rp@ hp ! EXECUTE
2R> hp ! DROP 0 ;
\ If true, return to code following CATCH with error n.
\ Data stack is reset to previous DEPTH.
: THROW ( k*w 0 - k*w | k*w n - i*w n) \ ERROR
?DUP IF hp @ rp! 2R> hp ! SWAP >R sp! DROP R> THEN ;
\ *** ABORT must be this last word defined in this file ***
\ Clear both stacks and execute application program.
: ABORT ( ?) \ CORE
TRUE THROW ;
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/