Google
 

Trailing-Edge - PDP-10 Archives - BB-H506D-SM_1983 - cobol/source/key.mac
There are 7 other files named key.mac in the archive. Click here to see a list.
; UPD ID= 771 on 2/3/78 at 4:24 PM
TITLE	KEY FOR LIBOL
SUBTTL	CREATE A SORT KEY FROM A DISPLAY FIELD		AL BLACKINGTON/CAM



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1981 BY DIGITAL EQUIPMENT CORPORATION


;REVISION HISTORY:

;V10 *****

;	8-APR-75	/ACK	ADD ABILITY TO HANDLE  EBCDIC KEYS.

;*****


SALL
HISEG

SEARCH	LBLPRM

ENTRY KEY.
EXTERNAL KILL.

;CALLING SEQUENCE:
;	PUSHJ	17,KEY.
;	<BYTE POINTER TO DISPLAY FIELD>
;	XWD <SIZE OF FIELD>,<FIRST LOCATION FOR KEY>
;	XWD		0,COLLATING SEQENCE ADDRESS

;IF THE KEY IS DESCENDING, THE SIGN BIT OF THE XWD WILL BE 1.
;IF THE COLLATING SEQUENCE IS NON-STANDARD BIT 1 = 1.
KEY.:	MOVEI	TA,2		;GET ADDRESS OF
	EXCH	TA,(PP)		;	PARAMETERS, AND
	ADDM	TA,(PP)		;	RESET RETURN ADDRESS

	MOVE	IP,0(TA)	;GET POINTER
	MOVE	OP,1(TA)	;GET KEY ADDRESS
	HLRZ	FS,OP		;GET FIELD SIZE

IFN ANS74,<
	TRZE	FS,1B19		;ALTERNATE COLLATING SEQUENCE?
	SKIPA	CS,@(PP)	;YES, GET ADDRESS
	TDZA	CS,CS		;NO, MAKE SURE RHS = 0
	AOS	(PP)		;RETURN BEYOND IT
	TLO	CS,TA		;SET TA AS INDEX SO INDIRECTION WORKS
	TRZE	FS,1B18		;DESCENDING?
	HRLI	CS,(1B0)	;YES, SET LHS NEGATIVE
>
IFN ANS68,<
	TRZN	FS,1B18		;IS KEY DESCENDING?
	TDCA	CS,CS		;NO--SET "CS" TO 0
	SETOI	CS,		;YES--SET "CS" TO ALL ONES
>

	LDB	TA,[POINT 6,IP,11] ;GET BYTE SIZE
	CAIG	TA,^D9
	CAIGE	TA,6
	JRST	BADBYT

	LSH	TA,6
	HRL	OP,TA		;BUILD OUTPUT BYTE POINTER
	AOJA	FS,KEY.3

KEY.1:	SETZM	0(OP)		;CLEAR NEXT WORD

KEY.2:	ILDB	TA,IP		;GET A BYTE
IFN ANS74,<
	TRNE	CS,-1		;ALTERNATE COLLATING SEQUENCE?
	MOVE	TA,@CS		;YES, GET REPLACEMENT CHAR.
>
	IDPB	TA,OP		;STASH IT
	TLNE	OP,770000	;ANY ROOM LEFT IN WORD FOR ANOTHER?
	SOJG	FS,KEY.2	;YES--LOOP

IFN ANS68,<
	XORM	CS,(OP)		;COMPLEMENT IF DESCENDING
>
IFN ANS74,<
	SKIPGE	CS		;IF DESCENDING
	SETCMM	(14)		;COMPLEMENT
>
	ADDI	OP,1
	TLZ	OP,77B23

KEY.3:	LDB	TA,[POINT 6,IP,11]
	TLO	OP,@BYTKIK-6(TA)

	SOJG	FS,KEY.1	;LOOP UNTIL DONE

	POPJ	PP,
;BAD BYTE SIZE

BADBYT:	OUTSTR	[ASCIZ "Bad sort-key byte pointer"]
	JRST	KILL.

;TABLE OF RESIDUES WITH WHICH EACH WORD IS STARTED

BYTKIK:	EXP	^D30B23	;6-BIT
	EXP	^D35B23	;7-BIT
	EXP	^D32B23	;8-BIT
	EXP	^D36B23	;9-BIT


TA=11	;TEMP
FS=13	;FIELD SIZE
OP=14	;OUTPUT POINTER
IP=15	;INPUT POINTER
CS=16	;NON-ZERO IF DESCENDING
PP=17	;PUSH-DOWN POINTER

END