ASMB,Q,C
      HED <PGMAL> I.D. SEG. ADDRESS ROUTINE *(C) HEWLETT-PACKARD CO. 1980*
      NAM PGMAL,6 91750-1X146 REV.2013 800105 L 
      EXT $ID#,$IDA,$IDSZ,$XQT,IDGET
      ENT PGMAD 
      EXT .LBT,.MBT,.SBT,.ENTP,$LIBR,$LIBX
*    NAME:   PGMAL
*    SOURCE: 91750-18146
*    RELOC:  91750-1X146
*    PGMR:   C.C.H. [ 01/04/80 ]
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
*  PGMAL ACCEPTS A USER-SUPPLIED ADDRESS OF A 3-WORD ARRAY WHICH
*    CONTAINS THE ASCII CODE FOR THE NAME OF A PARTICULAR PROGRAM.
*    OPTIONALLY, IF THE FIRST WORD OF THE ARRAY IS A ZERO, THIS INDICATES 
*    A REQUEST TO RETURN THE ASCII NAME, ETC. FOR THE CALLING PROGRAM.
*  PGMAL RETURNS THE I.D. SEGMENT ADDRESS OF THE PROGRAM, THE STATUS, 
*    AN INDICATION OF THE TYPE OF I.D. SEGMENT (I.E.,LONG/SHORT), AND THE 
*    FATHER'S I.D. SEGMENT ADDRESS. 
*  A DORMANT PROGRAM, ALSO IN THE TIME LIST, HAS STATUS SET =100000B. 
*  >>CAUTION: SHORT ID ADDRESS REPORTED= +(ADDRESS-13B) [KEY WORD FORMAT].
* 
*  IF THE USER SUPPLIES A NEGATIVE I.D. SEGMENT ADDRESS VIA PARAMETER 
*    'IDAD', THEN PGMAD WILL RETURN RETURN 3 WORDS, CONTAINING THE
*    ASCII PROGRAM NAME, TO THE BUFFER DEFINED BY THE 'NAME' PARAMETER. 
*  >>CAUTION: SHORT ID ADDRESS MUST BE= -(ID ADDR.-13B) [KEY WORD FORMAT].
* 
*  PGMAD CALLING SEQUENCE:
* 
*     JSB PGMAD 
*     DEF *+2  [ OR *+2+N WHERE N= NUMBER OF OPTIONAL PARAMETERS ]
*     DEF NAME      ADDRESS OF 3-WORD ASCII PROGRAM NAME ARRAY. 
*    [DEF IDAD]     [OPT. IF PARAM NEG: ASCII RETURNED; ELSE,0/+(ID ADDR)]
*    [DEF ISTAT]    [OPTIONAL ADDRESS FOR RETURN OF PROGRAM STATUS] 
*    [DEF IDTYP]    [OPTIONAL ADDRESS FOR RETURN OF I.D.SEGMENT TYPE] 
*    [DEF FATHA]    [OPTIONAL ADDRESS FOR RETURN OF FATHER'S I.D. ADDRESS]
*  <NORMAL RETURN>  <A> = I.D. SEGMENT ADDRESS. 
*                   <B> = PROGRAM STATUS. [ DORMANT, IN TIME LIST =100000B] 
*                   <E> = 0: STANDARD I.D. SEGMENT. 
*                   <E> = 1: SHORT I.D. SEGMENT.
* 
*  FORTRAN CALLING SEQUENCE: CALL PGMAD(NAME [,IDAD [,ISTAT [,IDTYP]]]) 
* 
*  PGMAL ERROR DETECTION: 
* 
*    A. ADDRESS OF NAME-ARRAY NOT SUPPLIED. 
*    B. CHARACTER #5 OF USER-SUPPLIED PROGRAM NAME IS NULL. 
*    C. I.D. SEGMENT WITH EQUIVALENT PROGRAM NAME CANNOT BE FOUND.
* 
*    -- RETURN TO <NORMAL RETURN> WITH: 
*       1. <A> & <B> AND 'IDAD' & 'ISTAT' ALL SET = 0.
*       2. <E> AND 'IDTYP' ARE SET =1.
      SKP 
      SUP           [SUPPRESS EXTENDED LISTING] 
NAME  NOP           ASCII NAME ADDR. CONVERTED TO BYTE ADDR.
P1    DEF A         ADDRESS FOR RETURN OF PARAMETER #1. 
P2    DEF B         ADDRESS FOR RETURN OF PARAMETER #2. 
P3    DEF PTEM      ADDRESS FOR RETURN OF PARAMETER #3. 
P4    DEF PTEM+1    ADDRESS FOR RETURN OF PARAMETER #4. 
PGMAD NOP           ENTRY/EXIT
      JSB $LIBR     GAIN EXCLUSIVE USE
      NOP            OF THIS SUBROUTINE.
      JSB .ENTP     OBTAIN DIRECT ADDRESSES.
      DEF NAME      DEFINE PARAMETER STORAGE AREA.
      LDA NAME      GET THE ADDRESS OF THE ASCII ARRAY. 
      SZA,RSS       DID THE CALLER SUPPLY AN ADDRESS? 
      JMP ERREX       NO--ERROR!
* 
      STA SVNAM     SAVE ARRAY ADDRESS, TEMPORARILY.
      CLE,ELA       FORM A BYTE ADDRESS 
      STA NAME       FOR THE USER'S ASCII BUFFER. 
      SPC 1 
*    RESET POINTERS TO ALLOW USER TO CALL WITHOUT RETURN-DATA PARAMETERS. 
      SPC 1 
      DLD P1        GET PARAMETER ADDRESSES-IF ANY. 
      DST IDAD      SAVE FOR DATA RETURN. 
      DLD REGDF     GET INITIAL PARAMETER DEFINITION
      DST P1          AND RE-INITIALIZE FOR NO PARAMETERS.
      DLD P3        GET 'IDTYP' & 'FATHA' ADDRESSES--IF ANY.
      DST IDTYP     SAVE PARAMETER ADDRESSES. 
      DLD DPTEM     GET DEF'S TO DUMMY PARAMETER STORAGE. 
      DST P3        RE-SET FOR NO 'IDTYP' & 'FATHA' PARAMS. 
      INB           INITIALIZE I.D. POINTER 
      STB KEYPT      TO TEMPORARY STORAGE.
      CLA 
      LDA IDAD,I    GET THE ID ADDRESS--IF ANY. 
      CMA,SSA,INA   IF THE ADDRESS IS NOT NEGATIVE, 
      JMP ASCNM      THEN, USER IS SUPPLYING THE ASCII NAME.
      SPC 1 
*    DETERMINE ASCII PROGRAM NAME FROM USER'S I.D. SEGMENT ADDRESS. 
      SPC 1 
SEGAD STA IDSEG     SAVE I.D. SEGMENT ADDRESS.
      LDB $ID#      GET THE NUMBER OF I.D. SEGMENTS.
      CMB,INB       FORM A COUNTER. 
      LDA $IDA      GET THE I.D. SEGMENT ADDRESS. 
ADCHK CPA IDSEG     IF THE USER'S IS A VALID I.D. SEGMENT,
      JMP GETNM      THEN CONTINUE PROCESSING THE REQUEST.
      ADA $IDSZ     ADD OFFSET TO NEXT ID SEGMENT.
      INB,SZB       HAVE ALL ID. SEGMENTS BEEN CHECKED? 
      JMP ADCHK      NO, CONTINUE CHECKING. 
      JMP ERREX      YES, THE USER'S ADDRESS IS INVALID!
* 
GETNM ADA D12       POINT TO I.D. ASCII NAME WORDS. 
      CLE,ELA       FORM SOURCE BYTE ADDRESS. 
      LDB NAME      GET USER BUFFER BYTE ADDRESS. 
      JSB .MBT      MOVE THE FIVE 
      DEF D5         NAME CHARACTERS
      NOP             TO THE USER'S BUFFER. 
      LDA B40       PAD THE LAST WORD 
      JSB .SBT       WITH AN ASCII SPACE. 
      JMP ESTAT     COMPLETE THE PROCESSING.
      SPC 1 
*    DETERMINE I.D. SEGMENT ADDRESS FROM USER'S ASCII PROGRAM NAME. 
      SPC 1 
ASCNM LDA $XQT      GET CALLER'S I.D. SEGMENT ADDRESS.
      LDB SVNAM,I   IF THE CALLER SPECIFIED 
      SZB,RSS        ZERO AS THE FIRST ASCII NAME 
      JMP SEGAD       PARAMETER, THEN RETURN DATA ON CALLER.
* 
      JSB IDGET     GET I.D. SEGMENT ADDRESS
      DEF *+2         USING L'S ROUTINE,
      DEF SVNAM,I      AND USER-SPECIFIED NAME. 
      STA PTEM+2    SAVE I.D. SEGMENT ADDRESS.
      SZA,RSS       IF THE PROGRAM WAS NOT FOUND, 
      JMP ERREX      TAKE THE ERROR EXIT; ELSE, 
* 
ESTAT LDB KEYPT,I   GET THE I.D. SEGMENT ADDRESS, AGAIN.
      ADB D15       POINT TO I.D. SEGMENT WORD #16, 
      STB PSTAT      AND SAVE THE STATUS WORD ADDRESS.
      LDA B,I       GET STATUS WORD FROM I.D. SEGMENT.
      AND B77       ISOLATE THE STATUS CODE (BITS# 5-0).
      SZA           IF STATUS IS NON-DORMANT (#0) 
      JMP SVST       TIME LIST CHECKING IS NOT REQUIRED.
      ADB D2        POINT TO, AND RETRIEVE WORD #18 
      LDB B,I        OF THE I.D. SEGMENT (RES,T,MULTIPLE).
      BLF,SLB       POSITION THE 'T' BIT AND TEST IT. 
      LDA BIT15     PROGRAM IN TIME LIST: STATUS =100000B.
SVST  STA STWRD     SAVE THE MASKED STATUS CODE.
      SZA,RSS       IF STATUS =0, IT'S DORMANT, SO
      JMP FATH?       NO MAPPING IS REQUIRED. 
* 
      STA B         SAVE MASKED CODE FOR INDEXING.
      ADA M10B      TEST FOR LOW RANGE CODES: 0 TO 7B.
      SSA,RSS       LOW RANGE (<10B)? 
      JMP HIRNG      NO. GO TO TEST FOR HIGH RANGE. 
* 
      LDA LOTBA      YES. GET POINTER TO LOW RANGE TABLE, 
      JMP GMAPS            AND GO GET MAPPED STATUS CODE. 
* 
HIRNG ADA M37B      TEST FOR UNDEFINED RANGE: 10B TO 46B. 
      SSA           IF THE STATUS CODE IS <47B, 
      JMP ERREX       THEN SOMETHING'S WRONG--FLAG AN ERROR!
* 
      STA B         SAVE THE HIGH RANGE OFFSET VALUE. 
      ADA M13B      TEST FOR OUT-OF-RANGE CODES: >61B.
      SSA,RSS       IF THE STATUS CODE IS >61B, 
      JMP ERREX       THEN SOMETHING'S WRONG--FLAG AN ERROR!
* 
      LDA HITBA     GET THE POINTER TO THE HIGH RANGE TABLE.
GMAPS ADA B         INDEX TO THE MAPPED EQUIVALENT STATUS.
      LDB A,I       GET THE RTE-M/III/IV EQUIVALENT CODE. 
      CPB M1        IF THE MAPPED CODE = -1 (UNDEFINED),
      JMP ERREX       THEN SOMETHING'S WRONG--FLAG AN ERROR!
* 
      STB STWRD     SAVE THE MAPPED EQUIVALENT STATUS CODE, 
* 
FATH? CCB,CCE       COMPUTE A BYTE ADDRESS
      ADB PSTAT      FOR THE FATHER'S 
      ELB              ID SEGMENT NUMBER. 
      JSB .LBT      GET THE FATHER'S ID SEGMENT NO. 
      SZA,RSS       IF IT'S =0, NO FURTHER EFFORT NEEDED, 
      JMP STR0       SO SKIP TO RETURN 0 TO THE CALLER. 
      ADA M1        COMPUTE THE 
      MPY $IDSZ      FATHER'S ID SEGMENT
      ADA $IDA        ADDRESS, AND RETURN IT
STR0  STA FATHA,I      TO THE CALLER. 
* 
      LDA PSTAT     RECOVER THE STATUS ADDRESS. 
      LDA A,I       GET WORD WITH SEGMENT SIZE (SS) FLAG. 
      LSR 7         RTE-L'S 'SS' BIT IS WORD#16 BIT#7.
      CLE,ERA       SET <E> TO: 0-LONG/1-SHORT ID.SEG. TYPE.
      CLA,SEZ       IF STANDARD I.D. SEG.: <A>=0; ELSE, 
      INA             SET <A>=1 FOR SHORT I.D. SEGMENT. 
      STA IDTYP,I   RETURN THE I.D. SEGMENT TYPE. 
      LDA KEYPT,I   <A> = I.D. SEGMENT ADDRESS. 
      CLB,SEZ,RSS   <B> = 0, IF THIS IS SHORT ID. SEG.
      LDB STWRD     <B> = PROGRAM'S CURRENT STATUS. 
* 
EROUT STA IDAD,I    RETURN DATA TO
      STB ISTAT,I     USER'S PARAMETERS--IF ANY.
      JSB $LIBX     RETURN TO THE CALLER
      DEF PGMAD      VIA PRIVILEGED PROCESSOR.
* 
ERREX CLA,CCE,INA   SET 'IDTYP' & <E> 
      STA IDTYP,I     TO 1--FOR ERROR RETURN. 
      CLA           RETURN WITH <A> & <B> AND 'IDAD' &
      CLB             'ISTAT' ALL SET TO ZERO!
      JMP EROUT     GO TO RETURN THE BAD NEWS.
* 
      SKP 
* 
***** DO NOT CHANGE THE ORDER OF THE FOLLOWING STATEMENTS ***** 
* 
LOTBA DEF *+1       LOW RANGE MAP TABLE POINTER.
      OCT 0,-1,2,3,-1,-1,6,6       MAPPED CODES: 00B TO 07B.
* 
HITBA DEF *+1       HIGH RANGE MAP TABLE POINTER. 
      OCT 100000,3,3,3,3,3,3,2,1,1,4 MAP. CODES: 47B TO 61B.
* 
A     EQU 0 
B     EQU 1 
B40   OCT 40
B77   OCT 77
DPTEM DEF PTEM      DUMMY POINTER: PARAMETER #3.
      DEF PTEM+1    DUMMY POINTER: PARAMETER #4.
IDAD  NOP           ADDRESS FOR RETURN OF I.D. SEG. ADDRESS.
ISTAT NOP           ADDRESS FOR RETURN OF PROGRAM STATUS. 
IDTYP NOP           ADDRESS FOR RETURN OF I.D. SEGMENT TYPE.
FATHA NOP           ADDRESS FOR RETURN OF FATHER'S ID ADDRESS.
KEYPT NOP           POINTER TO CURRENT I.D. SEGMENT ADDRESS.
D2    DEC 2 
D5    DEC 5 
D12   DEC 12        OFFSET TO I.D. SEGMENT NAME-ENTRY.
D15   DEC 15        OFFSET TO I.D. SEGMENT STATUS WORD. 
BIT15 EQU HITBA 
M1    DEC -1
M10B  OCT -10 
M13B  OCT -13 
M37B  OCT -37 
PSTAT NOP           TEMPORARY STORAGE.
PTEM  BSS 3         TEMPORARY STORAGE.
IDSEG EQU PTEM+2
REGDF DEF A         DUMMY POINTER: PARAMETER #1.
      DEF B         DUMMY POINTER: PARAMETER #2.
STWRD NOP           MASKED STATUS WORD. 
SVNAM EQU PSTAT     TEMPORARY STORAGE FOR NAME ARRAY POINTER. 
      END