Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/key.mac
There are 7 other files named key.mac in the archive. Click here to see a list.
; UPD ID= 218 on 1/21/82 at 5:32 PM by NIXON
TITLE KEY FOR COBOTS V13
SUBTTL CREATE A SORT KEY FROM A DISPLAY FIELD
SEARCH COPYRT
SALL
;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, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
;REVISION HISTORY:
;V10 *****
; 8-APR-75 /ACK ADD ABILITY TO HANDLE EBCDIC KEYS.
;*****
SALL
HISEG
.COPYRIGHT ;Put standard copyright statement in REL file
SEARCH LBLPRM
ENTRY KEY.
EXTERNAL KILL.,RET.1
;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.
;NOTE THIS CODE MAY RUN IN SECTION 1 IF SORT IS IN A NON-ZERO SECTION
;SO BE CAREFUL ABOUT INDEXING AND INDIRECTION
KEY.: MOVEI TA,2 ;GET ADDRESS OF
EXCH TA,(PP) ; PARAMETERS, AND
ADDM TA,(PP) ; RESET RETURN ADDRESS
DMOVE IP,0(TA) ;GET POINTER AND KEY ADDRESS
HLRZ FS,OP ;GET FIELD SIZE
TRZN FS,1B19 ;ALTERNATE COLLATING SEQUENCE?
JRST KEY.0 ;NO
MOVE CS,@(PP) ;YES, GET ADDRESS
HRLI CS,400000+TA ;SET TA AS INDEX SO INDIRECTION WORKS
; AND TURN INTO AN IFIW
AOSA (PP) ;RETURN BEYOND IT
KEY.0: SETZ CS, ;MAKE SURE ZERO
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
LDB TA,[POINT 6,IP,11]
TLO OP,@BYTKIK-6(TA)
HLRZ FL,OP ;STORE LHS OF BYTE POINTER
TRZE FS,DESC ;IS KEY DESCENDING?
HRLI FL,-1 ;YES, SET LHS NEGATIVE
JUMPE FS,RET.1 ;SIZE IS ZERO, GIVE UP
KEY.1: TLO OP,(1B0) ;MAKE IT A LOCAL ADDRESS
SETZM 0(OP) ;CLEAR NEXT WORD
HRL OP,FL ;REBUILD THE BYTE POINTER
KEY.2: ILDB TA,IP ;GET A BYTE
SKIPE CS ;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
JUMPGE FL,KEY.3 ;IF DESCENDING
TLO OP,(1B0) ;MAKE LOCAL
SETCMM (OP) ;COMPLEMENT
KEY.3: SOSLE FS ;ANY LEFT?
AOJA OP,KEY.1 ;YES, 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=1 ;TEMP
FL=11 ;LHS = DESCENDING FLAG, RHS = INITIAL BYTE RESIDUE
FS=13 ;FIELD SIZE
IP=14 ;INPUT POINTER
OP=15 ;OUTPUT POINTER
CS=16 ;ALTERNATE COLLATING SEQUENCE
PP=17 ;PUSH-DOWN POINTER
;FLAGS IN LHS OF WORD 2
DESC==(1B0) ;SEQUENCE IS DESCENDING
ACSF==(1B1) ;ALTERNATE COLLATING SEQUENCE
END