ASMB,L,C
      HED -PNAME-  FETCH PROGRAM NAME 
* 
*     NAME:   PNAME 
*     SOURCE: 92068-18035 
*     RELOC:  PART OF 92067-16268 AND 92067-16035 
*     PGMR:   R.A.G.
* 
*  ***************************************************************
*  * (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.       *
*  ***************************************************************
* 
      NAM PNAME,7 92068-1X035 REV.2013 771121 
      ENT PNAME 
* 
      EXT .ENTR,$OPSY 
* 
A     EQU 0 
B     EQU 1 
XEQT  EQU 1717B     (RTE) 
EXPG  EQU 141B      (DOS) 
* 
*  PURPOSE: 
*     TO EXTRACT THE NAME OF THE CURRENT PROGRAM
*     FROM ITS ID SEGMENT, WHICH IS IN THE SYSTEM 
*     MAP IN RTE-IV.
* 
* 
*  CALLING SEQUENCE:
*     JSB PNAME 
*     DEF *+2 
*     DEF IARAY 
* 
* 
*IARAY BSS 3
* 
* 
* 
IARAY NOP 
PNAME NOP           ENTRY POINT 
      JSB .ENTR 
      DEF IARAY 
      LDB $OPSY 
      LDA XEQT
      ADA =D12      ADDRESS OF NAME FOR RTE 
      CPB =D-9
      JMP RTEIV     SPECIAL HANDLING FOR RTE-IV 
      SSB,RSS 
      LDA DEXPG     ADDRESS OF NAME FOR DOS 
      LDB A,I 
      STB IARAY,I   STORE FIRST 2 CHARS 
      INA 
      ISZ IARAY     BUMP POINTERS 
      LDB A,I 
      STB IARAY,I   STORE NEXT 2 CHARS
      INA 
      ISZ IARAY     BUMP
      LDA A,I 
      AND =B177400  MASK OFF SYSTEM FLAGS 
      IOR =B40      AND ADD SPACE 
      STA IARAY,I 
      JMP PNAME,I 
* 
* 
* 
RTEIV LDB IARAY     DESTINATION ADDRESS 
      RRL 1         CHANGE BOTH ADDRESSES TO BYTE ADDRESSES 
      LDX =D5 
      MBF           MOVE 5 CHARACTERS 
      LDA =B40
      SBT           ADD FINAL SPACE 
      JMP PNAME,I 
* 
* 
DEXPG DEF EXPG
* 
      END 
                                                                                                      