SUBTTL Code-level extensions
PAGE


;This file contains extensions to the FORTH kernel.
;These extensions are in assembly language either for speed, or
;to access specific processor functions.
;These are NOT system-dependent functions!

;=C+  (XOF)	primitive compiled by CASE..OF		n1 n2 -- [n1]

;	Code added for Dr. Eaker's CASE construct
;	After John Cassady's 8080 code in FD 3:187 1982
;	(jes ver1.2C,1982)
;
		$CODE	85H,(XOF,)
		POP	BX		;BX := case tag
		POP	AX		;AX := search tag
		CMP	AX,BX		;This one ?
		JE	XOF1		;Yes...
		PUSH	AX		;No, save search tag,
		JMP	BRAN1		;   and check the next case.
XOF1:		INC	SI		;...skip the branch offset,
		INC	SI		;   and
		JMP	NEXT		;   don't save the search tag.

;********************************************************
;*							*
;*	long fetch/store operators:	L@, L!		*
;*					LC@, LC!	*
;*					MYSEG		*
;*							*
;********************************************************

;=C+  L@	intersegment fetch operator		seg off -- n

		$CODE	82H,L,@
		POP	BX		;Offset
		MOV	DX,DS		;Save current segment
		POP	DS		;Segment
		MOV	AX,[BX]		;Fetch word at DS:BX
		MOV	DS,DX		;Restore segment register
		JMP	APUSH		;Return

;=C+  L!	intersegment store operator		n seg off --

		$CODE	82H,L,!!!!
		MOV	DX,DS
		POP	BX		;Offset
		POP	DS		;Segment
		POP	AX		;Data
		MOV	[BX],AX
		MOV	DS,DX
		JMP	NEXT

;=C+  LC@	intersegment byte fetch			seg off -- b

		$CODE	83H,LC,@
		MOV	DX,DS		;put DS in a safe place
		POP	BX		;offset
		POP	DS		;segment
		MOV	AL,BYTE PTR [BX]	;get it
		XOR	AH,AH		;make sure AH is clear
		MOV	DS,DX		;restore data segment
		JMP	APUSH

;=C+  LC!	intersegment byte store			b seg off --

		$CODE	83H,LC,!!!!
		MOV	DX,DS		;save DS
		POP	BX		;offset
		POP	DS		;segment
		POP	AX		;data
		MOV	BYTE PTR [BX],AL	;move it
		MOV	DS,DX		;back to old data segment
		JMP	NEXT

;=C+  MYSEG	get FORTH's segment			-- seg

		$CODE	85H,MYSE,G
		MOV	AX,DS		;could just as well be CS or SS
		JMP	APUSH

;=C+  (ARRAY)	1d array addressing primitive		n1 addr1 -- addr2

;
;	Code added to support array references.
;	Used by ARRAY to calculate the address of the
;	nth element of the array.
;	(jes ver1.2c,1982)
;
		$CODE	87H,(ARRAY,)
		POP	BX		;BX -> SIZE
		POP	AX		;AX := n
		ADD	AX,AX		;AX := AX*2
		ADD	AX,BX		;AX -> ARRAY[n]
		ADD	AX,2		;Offset to ARRAY[0]
		JMP	APUSH

;=C+  (2ARR)	2d array addressing primitive		n1 n2 addr1 -- addr2

		$CODE	86H,(2ARR,)
		POP	BX		;BX -> rowsize
		POP	CX		;CX := column
		POP	AX		;AX := row
		MUL	[BX]		;AX := row*row dim.
		ADD	AX,CX		;AX := AX + col
		ADD	AX,AX		;2 bytes per element
		ADD	AX,BX		;AX := AX+PFA
		ADD	AX,4		;Offset to ARRAY[0]
		JMP	APUSH

;=C+  (CARR)	1d byte array addressing primitive	n addr1 -- addr2

		$CODE	86H,(CARR,)
		POP	BX
		POP	AX
		ADD	AX,BX
		ADD	AX,2
		JMP	APUSH

;=C+  (2CARR)	2d byte array addressing primitive	n1 n2 addr1 -- addr2

		$CODE	87H,(2CARR,)
		POP	BX
		POP	CX
		POP	AX
		MUL	[BX]
		ADD	AX,CX
		ADD	AX,BX
		ADD	AX,4
		JMP	APUSH

;	Port fetch/store operators
;	FIG-listing, pp. 76,77

;=C   PC@	fetch byte from a port			port# --

		$CODE	83H,PC,@
		POP	DX
		IN	AL,DX
		SUB	AH,AH		;make sure high byte is zero
		JMP	APUSH

;=C   PC!	send byte to port			b port# --

		$CODE	83H,PC,!!!!
		POP	DX		;port
		POP	AX		;data
		OUT	DX,AL
		JMP	NEXT

;=C   P@	16-bit port fetch			port# -- n

		$CODE	82H,P,@
		POP	DX
		IN	AX,DX
		JMP	APUSH

;=C   P!	16-bit port output			n port# --

		$CODE	82H,P,!!!!
		POP	DX
		POP	AX
		OUT	DX,AX
		JMP	NEXT

;=C   MATCH	string search primtive			addr1 n addr2 n -- f addr3

		$CODE	85H,MATC,H
		MOV	DI,SI
		POP	CX
		POP	BX
		POP	DX
		POP	SI
		PUSH	SI
MATCH1:		LODSB
		CMP	AL,BYTE PTR [BX]
		JNZ	MATCH3
		PUSH	BX
		PUSH	CX
		PUSH	SI
MATCH2:		DEC	CX
		JZ	MATCHOK
		DEC	DX
		JZ	NOMATCH
		INC	BX
		LODSB
		CMP	AL,BYTE PTR [BX]
		JZ	MATCH2
		POP	SI
		POP	CX
		POP	BX
MATCH3:		DEC	DX
		JNZ	MATCH1
		JMP	SHORT MATCH4
MATCHOK:
NOMATCH: 	POP	CX
		POP	CX
		POP	CX
MATCH4:		MOV	AX,SI
		POP	SI
		SUB	AX,SI
		MOV	SI,DI
		JMP	DPUSH


;********************************************************
;*							*
;*		Video function calls for the IBM-PC	*
;*							*
;********************************************************

;=C+  MODE!	PC: set video mode to n			n --

		$CODE	85H,MODE,!!!!
		POP	AX			;MODE
		AND	AL,7			;MODE 0-7 only
		XOR	AH,AH			;Video function 0
		JMP	SHORT VIDEO

;=C+  CLS	PC: clear screen			--

		$CODE	83H,CL,S
		MOV	AH,15			;Video function 15
		INT	10H
		XOR	AH,AH			;Video function 0
		JMP	SHORT VIDEO

;=C+  LOCATE	PC: move cursor to page, row, column	p r c --

		$CODE	86H,LOCAT,E
		POP	DX			;DL=column
		POP	AX
		MOV	DH,AL			;DH=row
		POP	BX
		MOV	BH,BL			;BH=page
		AND	BH,7			;0-7 only
		MOV	AH,2			;Video function 2
		JMP	SHORT VIDEO

;=C+  COLOR!	PC: set the color		palette color --

		$CODE	86H,COLOR,!!!!
		POP	BX			;BL=color
		POP	AX
		MOV	BH,AL			;BH=palette
		AND	BH,7FH			;0-127 only
		MOV	AH,11			;Video function 11
		JMP	SHORT VIDEO

;=C+  PAGE!	PC: set active display page to n	n --

		$CODE	85H,PAGE,!!!!
		POP	AX
		AND	AL,7			;AL=page(0-7)
		MOV	AH,5			;Video function 5
		JMP	SHORT VIDEO

;=C+  DOT!	PC: plot a point at row, column		r c --

		$CODE	84H,DOT,!!!!
		POP	CX			;column
		POP	DX			;row
		POP	AX			;color
		MOV	AH,12			;Video function 12
VIDEO:
		INT	10H
		JMP	NEXT

;=C+  DOT@	PC: fetch the byte at row, column	r c -- b

		$CODE	84H,DOT,@
		POP	CX			;column
		POP	DX			;row
		MOV	AH,13			;Video function 13
		INT	10H
		XOR	AH,AH
		JMP	APUSH			;AL=value

	$REPORT	<CODE-level extensions>

  Function  to