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

	$REPORT	<CODE-level extensions>

DH=month
		MOV	AH,2B