From:	SMTP%"RELAY-INFO-VAX@CRVAX.SRI.COM" 14-JUN-1994 16:34:02.34
To:	EVERHART
CC:	
Subj:	Re: Looking for routine to return name of CALLING routine

Date: Tue, 14 Jun 1994 19:13:33 +0100
From: Arne Vajhoej <ARNE@kopc.hhs.dk>
Subject: Re: Looking for routine to return name of CALLING routine
To: helge.v.larsen@RISOE.DK, INFO-VAX@SRI.COM
Message-id: <01HDJK4XE3SO8ZDVID@kopc.hhs.dk>
X-VMS-To: KOPC::IN%"helge.v.larsen@RISOE.DK"
X-VMS-Cc: IN::"INFO-VAX@SRI.COM"
MIME-version: 1.0
Content-type: TEXT/PLAIN; CHARSET=ISO-8859-1
Content-transfer-encoding: 8BIT

> When programming in Fortran (VAX/VMS), it would be very useful to have a
> routine that could give me the name of the calling routine.
> 
> Does anyone know such a routine ?

In general this is impossible to accomplish, because in an EXE-file
routines are represented by their addresses and not by their name.
So the name are not stored anywhere.

The best solution for your problem is to write a small program that scans
all your souce-code files and inserts a hardcoded name based on the
last SUBROUTINE/FUNCTION stattement encountered. This will work
unless there are some more advanced usage you want to use the routine
for.

Actually the routine name can/will be stored in either the GST or DST. If it
is linked with /DEBUG, then all the routine-names will be stored in the
EXE-file (because the debugger needs the same information to function).

The VMS_SHARE file attached below allow you to get the information you want,
if linked with /DEBUG. But I still recommend the first solution as the best.
(a good argument for that is the fact the my code only works on VAX not on
AXP !)

> Example :
> 
>   Program :
> 
>       program example
>       call sub
>       end
>       subroutine sub
>       character*8 str
>       call GIVE_NAME(str)
>       write(*,*) 'You are now in routine', str
>       return
>       end
> 
>   Output :
> 
>       You are now in routine SUB

      PROGRAM EXAMPLE
      CALL SUB
      END
C
      SUBROUTINE SUB
      INTEGER*4 L
      CHARACTER*32 STR
      CALL GIVE_NAME(STR,L)
      WRITE(*,*) 'You are now in routine ',STR(1:L)
      CALL SUB2
      RETURN
      END
C
      SUBROUTINE SUB2
      INTEGER*4 L
      CHARACTER*32 STR
      CALL GIVE_NAME(STR,L)
      WRITE(*,*) 'You are now in routine ',STR(1:L)
      RETURN
      END

$ FORTRAN EXAMPLE
$ LINK/DEB EXAMPLE+GIVE_NAME/LIBR
$ RUN/NODEB EXAMPLE
 You are now in routine SUB
 You are now in routine SUB2

OK ?

                                                          Arne

Arne Vajhøj                             local DECNET:  KO::ARNE
Computer Department                     PSI:           PSI%238310013040::ARNE
Business School of Southern Denmark     Internet:      ARNE@KO.HHS.DK

================================================================================

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_UNPACK_VERIFY"))'
$!
$! This archive created:
$!  Name : GIVE_NAME
$!  By   : arne
$!  Date : 14-JUN-1994 18:56:39.61
$!  Using: VMS_SHARE 8.4, (C) 1993 Andy Harper, Kings College London UK
$!
$! Credit is due to these people for their original ideas:
$!    James Gray, Michael Bednarek 
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. GET_BYT.FOR;1
$!       2. GIVE_NAME.FOR;1
$!       3. QS.FOR;1
$!       4. UTL.FOR;1
$!       5. SYS.MAR;1
$!       6. SYS2.MAR;1
$!       7. BUILD.COM;1
$!       8. USAGE.TXT;1
$!
$ set="set"
$ set symbol/scope=(nolocal,noglobal)
$ f=f$parse("SHARE_UNPACK_TEMP","SYS$SCRATCH:."+f$getjpi("","PID"))
$ e="write sys$error  ""%UNPACK"", "
$ w="write sys$output ""%UNPACK"", "
$ if .not. f$trnlnm("SHARE_UNPACK_LOG") then $ w = "!"
$ if f$getsyi("CPU") .gt. 127 then $ goto start
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto start
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$unpack: subroutine ! P1=filename, P2=checksum, P3=attributes,P4=size
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'"
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn' File skipped"
$ delete 'f'*
$ exit
$dirok:
$ x=f$search(P1)
$ if x .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped"
$ delete 'f'*
$ exit
$file_absent:
$ w "-I-UNPACK, Unpacking ", P5, " of ", P6, " - ", P1, " - ", P4, " Blocks"
$ n=P1
$ if P3 .nes. "" then $ n=f
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT/NOJOURNAL 'f'/OUT='n'
PROCEDURE GetHex(s,p)LOCAL x1,x2;x1:=INDEX(t,SUBSTR(s,p,1))-1;x2:=INDEX(t,
SUBSTR(s,p+1,1))-1;RETURN 16*x1+x2;ENDPROCEDURE;PROCEDURE SkipPartsep LOCAL m;
LOOP m:=MARK(NONE);EXITIF m=END_OF(b);DELETE(m);EXITIF INDEX(ERASE_LINE,
"-+-+-+-+-+-+-+-+")=1;ENDLOOP;ENDPROCEDURE;PROCEDURE ProcessLine LOCAL c,s,l,b,
n,p;c := ERASE_CHARACTER(1);s := ERASE_LINE;IF c = "X" THEN SPLIT_LINE; ENDIF;
MOVE_HORIZONTAL(-1);l := LENGTH(s);p := 1;LOOP EXITIF p > l;c := SUBSTR(s,p,1);
p := p+1;CASE c FROM ' ' TO '`' ['`']: COPY_TEXT(ASCII(GetHex(s,p))); p:=p+2;[
' ']: p:=p+1;[INRANGE,OUTRANGE]: COPY_TEXT(c);ENDCASE;ENDLOOP;ENDPROCEDURE;
PROCEDURE Decode LOCAL m;POSITION(BEGINNING_OF(b));LOOP m:=MARK(NONE);EXITIF m=
END_OF(b);DELETE(m);IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+-")=
1 THEN SkipPartSep;ELSE ProcessLine;MOVE_HORIZONTAL(1);ENDIF;ENDLOOP;
ENDPROCEDURE;SET(FACILITY_NAME,"UNPACK");SET(SUCCESS,OFF);SET(INFORMATIONAL,
OFF);t:="0123456789ABCDEF";f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);Decode;WRITE_FILE(b,GET_INFO(COMMAND_LINE,"output_file"));
QUIT;
$ if p3 .eqs. "" then $ goto dl
$ open/write fdl &f
$ write fdl "RECORD"
$ write fdl P3
$ close fdl
$ w "-I-CONVRFM, Converting record format to ", P3
$ convert/fdl=&f &f-1 &P1
$dl: delete 'f'*
$ checksum 'P1'
$ if checksum$checksum .nes. P2 then $ -
  e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ exit
$ endsubroutine
$start:
$!
$ create 'f'
X`20`20`20`20`20`20SUBROUTINE`20GET_BYT(IO,STR,N)
X`20`20`20`20`20`20INTEGER*4`20IO,N
X`20`20`20`20`20`20CHARACTER*(*)`20STR
XC
X`20`20`20`20`20`20INTEGER*4`20R1,RN,I,IX,L,LL
X`20`20`20`20`20`20CHARACTER*512`20REC
XC
X`20`20`20`20`20`20L=0
X`20`20`20`20`20`20R1=(N-1)/512+1
X`20`20`20`20`20`20RN=(N+LEN(STR)-2)/512+1
X`20`20`20`20`20`20READ(UNIT=IO,REC=R1,FMT='(A512)')`20REC
X`20`20`20`20`20`20IX=N-(R1-1)*512
X`20`20`20`20`20`20LL=MIN(LEN(STR),512-IX+1)
X`20`20`20`20`20`20STR(L+1:L+LL)=REC(IX:IX+LL-1)
X`20`20`20`20`20`20L=L+LL
X`20`20`20`20`20`20DO`20100`20I=R1+1,RN-1
X`20`20`20`20`20`20`20`20READ(UNIT=IO,REC=I,FMT='(A512)')`20REC
X`20`20`20`20`20`20`20`20LL=512
X`20`20`20`20`20`20`20`20STR(L+1:L+LL)=REC(1:512)
X`20`20`20`20`20`20`20`20L=L+LL
X100`20`20`20CONTINUE
X`20`20`20`20`20`20IF(RN.GT.R1)`20THEN
X`20`20`20`20`20`20`20`20READ(UNIT=IO,REC=RN,FMT='(A512)')`20REC
X`20`20`20`20`20`20`20`20LL=LEN(STR)-L
X`20`20`20`20`20`20`20`20STR(L+1:L+LL)=REC(1:LL)
X`20`20`20`20`20`20`20`20L=L+LL
X`20`20`20`20`20`20ENDIF
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
$ call unpack GET_BYT.FOR;1 843869925 "" 2 1 8 
$!
$ create 'f'
X`20`20`20`20`20`20SUBROUTINE`20GIVE_NAME(NAME,LNAME)
X`20`20`20`20`20`20INTEGER*4`20LNAME
X`20`20`20`20`20`20CHARACTER*8`20NAME
XC
X`20`20`20`20`20`20INTEGER*4`20MAX_SYM
X`20`20`20`20`20`20PARAMETER`20(MAX_SYM=2500)
X`20`20`20`20`20`20INTEGER*4`20FNMLEN,I,
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20N,PC(50),
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20NSYM,LSYM(MAX_SYM),ADR(MAX_SYM),
VIX(MAX_SYM)
X`20`20`20`20`20`20LOGICAL*4`20FIRST
X`20`20`20`20`20`20CHARACTER*32`20SYM(MAX_SYM)
X`20`20`20`20`20`20CHARACTER*256`20FNM
XC
X`20`20`20`20`20`20DATA`20FIRST/.TRUE./
XC
X`20`20`20`20`20`20IF(FIRST)`20THEN
X`20`20`20`20`20`20`20`20CALL`20SYS_IMAGE(FNM,FNMLEN)
X`20`20`20`20`20`20`20`20NSYM=0
X`20`20`20`20`20`20`20`20CALL`20UTL_READ_SYMTAB(FNM(1:FNMLEN),NSYM,SYM,LSYM,ADR
V,0)
X`20`20`20`20`20`20`20`20CALL`20QS_INT_IX(ADR,NSYM,IX)
X`20`20`20`20`20`20`20`20FIRST=.FALSE.
X`20`20`20`20`20`20ENDIF
XC
X`20`20`20`20`20`20CALL`20SYS_TRACE(N,PC)
X
XC
X`20`20`20`20`20`20I=1
X300`20`20`20IF(I.EQ.NSYM.OR.(ADR(IX(I)).LE.PC(2).AND.
X`20`20`20`20`20+`20`20`20PC(2).LT.ADR(IX(I+1))))`20THEN
X`20`20`20`20`20`20`20`20LNAME=LSYM(IX(I))
X`20`20`20`20`20`20`20`20NAME(1:LNAME)=SYM(IX(I))(1:LNAME)
X`20`20`20`20`20`20ELSE
X`20`20`20`20`20`20`20`20I=I+1
X`20`20`20`20`20`20`20`20GOTO`20300
X`20`20`20`20`20`20ENDIF
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
$ call unpack GIVE_NAME.FOR;1 1953004844 "" 2 2 8 
$!
$ create 'f'
XC
XC`20`20Content`20:`20QS-routines
XC
XC`20`20Author`20`20:`20Arne`20Vajh`F8j`20(august`201989)
XC
XC*******************
X`20`20`20`20`20`20SUBROUTINE`20QS_INT_IX(IA,N,IX)
X`20`20`20`20`20`20INTEGER*4`20N,IA(*),IX(*)
XC
XC`20`20`20`20`20Global`20variables
X`20`20`20`20`20`20INTEGER*4`20QS_MAXDEP
X`20`20`20`20`20`20PARAMETER`20(QS_MAXDEP=32)
X`20`20`20`20`20`20INTEGER*4`20L(QS_MAXDEP),R(QS_MAXDEP),
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20FIRST(QS_MAXDEP),LAST(QS_MAXDEP)
V,
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20LBL(QS_MAXDEP)
X`20`20`20`20`20`20COMMON/QS_VAR/L,R,FIRST,LAST,LBL
XC
XC`20`20`20`20`20Local`20variables
X`20`20`20`20`20`20INTEGER*4`20IPIVOT,TMP,K,LK,RK,JUMP
XC
XC`20`20`20`20`20Initialise`20index
X`20`20`20`20`20`20DO`2050`20K=1,N
X`20`20`20`20`20`20`20`20IX(K)=K
X50`20`20`20`20CONTINUE
XC
XC`20`20`20`20`20Sort
X`20`20`20`20`20`20FIRST(1)=1
X`20`20`20`20`20`20LAST(1)=N
X`20`20`20`20`20`20K=1
X100`20`20`20LK=FIRST(K)`20`20`20`20`20
X`20`20`20`20`20`20RK=LAST(K)
X`20`20`20`20`20`20IPIVOT=IA(IX((LK+RK)/2))
X200`20`20`20IF(IA(IX(RK)).LE.IPIVOT)`20GOTO`20300
X`20`20`20`20`20`20RK=RK-1
X`20`20`20`20`20`20GOTO`20200
X300`20`20`20IF(IA(IX(LK)).GE.IPIVOT)`20GOTO`20400
X`20`20`20`20`20`20LK=LK+1
X`20`20`20`20`20`20GOTO`20300
X400`20`20`20IF(LK.LE.RK)`20THEN
X`20`20`20`20`20`20`20`20TMP=IX(LK)
X`20`20`20`20`20`20`20`20IX(LK)=IX(RK)
X`20`20`20`20`20`20`20`20IX(RK)=TMP
X`20`20`20`20`20`20`20`20LK=LK+1
X`20`20`20`20`20`20`20`20RK=RK-1
X`20`20`20`20`20`20`20`20IF(LK.LE.RK)`20GOTO`20200
X`20`20`20`20`20`20ENDIF
X`20`20`20`20`20`20L(K)=LK
X`20`20`20`20`20`20R(K)=RK
X`20`20`20`20`20`20IF(R(K).GT.FIRST(K))`20THEN
X`20`20`20`20`20`20`20`20FIRST(K+1)=FIRST(K)
X`20`20`20`20`20`20`20`20LAST(K+1)=R(K)
X`20`20`20`20`20`20`20`20K=K+1
X`20`20`20`20`20`20`20`20ASSIGN`20500`20TO`20JUMP
X`20`20`20`20`20`20`20`20LBL(K)=JUMP
X`20`20`20`20`20`20`20`20GOTO`20100
X`20`20`20`20`20`20ENDIF
X500`20`20`20IF(L(K).LT.LAST(K))`20THEN
X`20`20`20`20`20`20`20`20FIRST(K+1)=L(K)
X`20`20`20`20`20`20`20`20LAST(K+1)=LAST(K)
X`20`20`20`20`20`20`20`20K=K+1
X`20`20`20`20`20`20`20`20ASSIGN`20600`20TO`20JUMP
X`20`20`20`20`20`20`20`20LBL(K)=JUMP
X`20`20`20`20`20`20`20`20GOTO`20100
X`20`20`20`20`20`20ENDIF
X600`20`20`20IF(K.GT.1)`20THEN
X`20`20`20`20`20`20`20`20JUMP=LBL(K)
X`20`20`20`20`20`20`20`20K=K-1
X`20`20`20`20`20`20`20`20GOTO`20JUMP
X`20`20`20`20`20`20ENDIF
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
$ call unpack QS.FOR;1 1743469727 "" 3 3 8 
$!
$ create 'f'
XC
XC`20`20Content`20:`20UTL-routines
XC
XC`20`20Author`20`20:`20Arne`20Vajh`F8j`20(august`201989)
XC
XC*****************
X`20`20`20`20`20`20SUBROUTINE`20UTL_READ_SYMTAB(IMGNAM,NSYM,SYM,LSYM,ADR,IMGBAS
V)
X`20`20`20`20`20`20INTEGER*4`20NSYM,LSYM(*),ADR(*),IMGBAS
X`20`20`20`20`20`20CHARACTER*(*)`20IMGNAM
X`20`20`20`20`20`20CHARACTER*(*)`20SYM(*)
XC
XC`20`20`20`20`20Local`20variables
X`20`20`20`20`20`20INTEGER*4`20IO
XC
XC`20`20`20`20`20Open`20file
X`20`20`20`20`20`20IO=99
X`20`20`20`20`20`20OPEN(UNIT=IO,FILE=IMGNAM,STATUS='OLD',ACCESS='DIRECT',
X`20`20`20`20`20+`20`20`20`20`20FORM='FORMATTED',RECORDTYPE='FIXED',RECORDSIZE=
V512,
X`20`20`20`20`20+`20`20`20`20`20READONLY)
XC
XC`20`20`20`20`20Read`20debug-symbol-table
X`20`20`20`20`20`20CALL`20UTL_READ_SYMTAB1(IO,NSYM,SYM,LSYM,ADR,IMGBAS)
XC
XC`20`20`20`20`20Read`20global-symbol-table
X`20`20`20`20`20`20CALL`20UTL_READ_SYMTAB2(IO,NSYM,SYM,LSYM,ADR,IMGBAS)
XC
XC`20`20`20`20`20Close`20file
X`20`20`20`20`20`20CLOSE(UNIT=IO)
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
XC********************
X`20`20`20`20`20`20SUBROUTINE`20UTL_READ_SYMTAB1(IO,NSYM,SYM,LSYM,ADR,IMGBAS)
X`20`20`20`20`20`20INTEGER*4`20IO,NSYM,LSYM(*),ADR(*),IMGBAS
X`20`20`20`20`20`20CHARACTER*(*)`20SYM(*)
XC
XC`20`20`20`20`20Local`20variables
X`20`20`20`20`20`20INTEGER*4`20BLKADR,BLKLEN,BASE,OFFS,BUFLEN,DUMINT
X`20`20`20`20`20`20LOGICAL*4`20OK
X`20`20`20`20`20`20CHARACTER*4`20DUMSTR
X`20`20`20`20`20`20CHARACTER*512`20BUF
X`20`20`20`20`20`20EQUIVALENCE`20(DUMINT,DUMSTR)
XC
XC`20`20`20`20`20Read`20image-header
X`20`20`20`20`20`20CALL`20GET_BYT(IO,BUF(1:512),1)
X`20`20`20`20`20`20CALL`20SYS2_FNDDBGTAB(BUF,BLKADR,BLKLEN)
X`20`20`20`20`20`20BASE=(BLKADR-1)*512+1
X`20`20`20`20`20`20OFFS=0
X100`20`20`20IF(OFFS.LT.BLKLEN*512)`20THEN
X`20`20`20`20`20`20`20`20DUMINT=0
X`20`20`20`20`20`20`20`20CALL`20GET_BYT(IO,DUMSTR(1:1),BASE+OFFS)
X`20`20`20`20`20`20`20`20BUFLEN=DUMINT
X`20`20`20`20`20`20`20`20OFFS=OFFS+1
X`20`20`20`20`20`20`20`20CALL`20GET_BYT(IO,BUF(1:BUFLEN),BASE+OFFS)
X`20`20`20`20`20`20`20`20CALL`20SYS2_FNDSYM1(BUF(1:BUFLEN),SYM(NSYM+1),
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20LS
VYM(NSYM+1),ADR(NSYM+1),OK)
X`20`20`20`20`20`20`20`20ADR(NSYM+1)=ADR(NSYM+1)+IMGBAS
X`20`20`20`20`20`20`20`20IF(OK)`20NSYM=NSYM+1
X`20`20`20`20`20`20`20`20OFFS=OFFS+BUFLEN
X`20`20`20`20`20`20`20`20GOTO`20100
X`20`20`20`20`20`20ENDIF
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
XC********************
X`20`20`20`20`20`20SUBROUTINE`20UTL_READ_SYMTAB2(IO,NSYM,SYM,LSYM,ADR,IMGBAS)
X`20`20`20`20`20`20INTEGER*4`20IO,NSYM,LSYM(*),ADR(*),IMGBAS
X`20`20`20`20`20`20CHARACTER*(*)`20SYM(*)
XC
XC`20`20`20`20`20Local`20variables
X`20`20`20`20`20`20INTEGER*4`20BLKADR,BLKLEN,BASE,OFFS,BUFLEN,I,J,DUMINT,IX,NSY
VM2
X`20`20`20`20`20`20LOGICAL*4`20OK
X`20`20`20`20`20`20CHARACTER*4`20DUMSTR
X`20`20`20`20`20`20CHARACTER*5120`20BUF
X`20`20`20`20`20`20EQUIVALENCE`20(DUMINT,DUMSTR)
XC
XC`20`20`20`20`20Read`20image-header
X`20`20`20`20`20`20CALL`20GET_BYT(IO,BUF(1:512),1)
X`20`20`20`20`20`20CALL`20SYS2_FNDGLBTAB(BUF,BLKADR,BLKLEN)
X`20`20`20`20`20`20BASE=(BLKADR-1)*512+1
X`20`20`20`20`20`20OFFS=0
X`20`20`20`20`20`20NSYM2=NSYM
X`20`20`20`20`20`20DO`20100`20I=1,BLKLEN
X`20`20`20`20`20`20`20`20DUMINT=0
X`20`20`20`20`20`20`20`20CALL`20GET_BYT(IO,DUMSTR(1:2),BASE+OFFS)
X`20`20`20`20`20`20`20`20BUFLEN=DUMINT
X`20`20`20`20`20`20`20`20OFFS=OFFS+2
X`20`20`20`20`20`20`20`20CALL`20GET_BYT(IO,BUF(1:BUFLEN),BASE+OFFS)
X`20`20`20`20`20`20`20`20CALL`20SYS2_FNDSYM2(BUF(1:BUFLEN),OK)
X`20`20`20`20`20`20`20`20IF`20(OK)`20THEN
X`20`20`20`20`20`20`20`20`20`20IX=1
X50`20`20`20`20`20`20`20`20CALL`20SYS2_FNDSYM3(BUF(IX+1:BUFLEN),SYM(NSYM+1),
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20LSYM(NSYM+1),ADR(NSYM+1),IX,OK)
X`20`20`20`20`20`20`20`20`20`20ADR(NSYM+1)=ADR(NSYM+1)+IMGBAS
X`20`20`20`20`20`20`20`20`20`20DO`2075`20J=1,NSYM2
X`20`20`20`20`20`20`20`20`20`20`20`20IF(SYM(NSYM+1)(1:LSYM(NSYM+1)).EQ.SYM(J)(1
V:LSYM(J)))
X`20`20`20`20`20+`20`20`20`20`20`20`20`20`20OK=.FALSE.
X75`20`20`20`20`20`20`20`20CONTINUE
X`20`20`20`20`20`20`20`20`20`20IF(OK)`20NSYM=NSYM+1
X`20`20`20`20`20`20`20`20`20`20IF(IX.LT.BUFLEN)`20GOTO`2050
X`20`20`20`20`20`20`20`20ENDIF
X`20`20`20`20`20`20`20`20OFFS=OFFS+BUFLEN+(BUFLEN.AND.1)
X100`20`20`20CONTINUE
XC
X`20`20`20`20`20`20RETURN
X`20`20`20`20`20`20END
$ call unpack UTL.FOR;1 1018712060 "" 6 4 8 
$!
$ create 'f'
X`20`20`20`20`20`20`20`20.title`20`20sys
X;
X;`20content`20:`20SYS-routines
X;
X;`20author`20`20:`20Arne`20Vajh`F8j`20(june`201989)
X;
X;-
X`20`20`20`20`20`20`20`20$SFDEF
X;
X;`20readonly`20data`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$PDATA`20quad,pic,con,lcl,shr,noexe,nowrt
V
Xargl_getjpi:`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20;`20argumentlist`20SYS$GETJPIW
X`20`20`20`20`20`20`20`20.long`20`20`207
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20efn
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20pid-address
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20process-name
X`20`20`20`20`20`20`20`20.address`20jobinf`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20;`20item-list
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20iosb
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20ast-address
X`20`20`20`20`20`20`20`20.long`20`20`200`20`20`20`20`20`20`20`20`20`20`20`20`20
V`20`20`20`20`20`20`20`20`20`20;`20ast-parameter
X;
X;`20writeread`20data`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$LOCAL`20quad,pic,con,lcl,noshr,noexe,wrt
V
Xjobinf:`20.blkw`20`20`201
X`20`20`20`20`20`20`20`20.blkw`20`20`201
X`20`20`20`20`20`20`20`20.blkl`20`20`201
X`20`20`20`20`20`20`20`20.blkl`20`20`201
X`20`20`20`20`20`20`20`20.long`20`20`200
X;
X;`20code`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$CODE`20quad,pic,con,lcl,shr,exe,nowrt
X;********************
X;
X;`20`20SYS_IMAGE`20(`20IMAGENAM`20,`20ACTLEN`20)
X;
X;`20`20get`20imagename
X;
X;********************
X`20`20`20`20`20`20`20`20.entry`20`20sys_image,`5Em<>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movw`20`20`20`20(r1),jobinf
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),jobinf+4
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E8(ap),jobinf+8
X`20`20`20`20`20`20`20`20movw`20`20`20`20#JPI$_IMAGNAME,jobinf+2
X`20`20`20`20`20`20`20`20callg`20`20`20argl_getjpi,G`5ESYS$GETJPIW;`20get`20ima
Vgename
X`20`20`20`20`20`20`20`20ret
X;********************
X;
X;`20`20SYS_TRACE`20(`20N`20,`20PC`20)
X;
X;`20`20perform`20traceback
X;
X;********************
X`20`20`20`20`20`20`20`20.entry`20`20sys_trace,`5Em<>
X`20`20`20`20`20`20`20`20clrl`20`20`20`20@B`5E4(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E8(ap),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20fp,r0
X100$:`20`20`20cmpl`20`20`20`20B`5ESF$L_SAVE_PC(r0),#`5Ex3FFFFFFF`20;`20test`20
Vif`20dcl-level
X`20`20`20`20`20`20`20`20bgtr`20`20`20`20400$
X`20`20`20`20`20`20`20`20cmpl`20`20`20`20B`5ESF$L_SAVE_PC(r0),#0`20`20`20;`20te
Vst`20if`20dcl-level
X`20`20`20`20`20`20`20`20blss`20`20`20`20200$
X`20`20`20`20`20`20`20`20cmpl`20`20`20`20B`5ESF$L_SAVE_PC(r0),#512`20;`20test
V`20if`20dcl-level
X`20`20`20`20`20`20`20`20blss`20`20`20`20400$
X`20`20`20`20`20`20`20`20brb`20`20`20`20`20300$
X200$:`20`20`20cmpl`20`20`20`20B`5ESF$L_SAVE_PC(r0),#SYS$CALL_HANDL+4`20;`20tes
Vt`20if`20exception-handler
X`20`20`20`20`20`20`20`20bneq`20`20`20`20400$
X300$:`20`20`20incl`20`20`20`20@B`5E4(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5ESF$L_SAVE_PC(r0),(r1)
X`20`20`20`20`20`20`20`20addl2`20`20`20#4,r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5ESF$L_SAVE_FP(r0),r0
X`20`20`20`20`20`20`20`20brb`20`20`20`20`20100$
X400$:`20`20`20ret
X`20`20`20`20`20`20`20`20.end
$ call unpack SYS.MAR;1 726728557 "" 4 5 8 
$!
$ create 'f'
X`20`20`20`20`20`20`20`20.title`20`20sys2
X;
X;`20content`20:`20SYS2-routines
X;
X;`20author`20`20:`20Arne`20Vajh`F8j`20(november`201989)
X;
X;-
X`20`20`20`20`20`20`20`20.library`20"SYS$LIBRARY:LIB"
X`20`20`20`20`20`20`20`20$IACDEF
X`20`20`20`20`20`20`20`20$IHADEF
X`20`20`20`20`20`20`20`20$IHDDEF
X`20`20`20`20`20`20`20`20$OBJDEF
XTRUE=-1
XFALSE=0
XEXE$C_MODULE=`5Ex000000BC
XEXE$C_ENTRYPOINT=`5Ex000000BE
XEXE$C_MACRO=0
XEXE$C_FORTRAN=1
XEXE$C_PASCAL=6
XEXE$C_C=7
X;
X;`20readonly`20data`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$PDATA`20quad,pic,con,lcl,shr,noexe,nowrt
V
X;
X;`20writeread`20data`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$LOCAL`20quad,pic,con,lcl,noshr,noexe,wrt
V
X;
X;`20code`20section
X;
X`20`20`20`20`20`20`20`20.psect`20`20$CODE`20quad,pic,con,lcl,shr,exe,nowrt
X;***************************************
X;
X;`20`20SYS2_FNDDBGTAB`20(`20HEADER`20,`20DBGTABADR`20,`20DBGTABLEN`20)
X;
X;`20`20find`20debug-symbol-table
X;
X;***************************************
X`20`20`20`20`20`20`20`20.entry`20`20sys2_fnddbgtab,`5Em<iv,r2>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),r1
X`20`20`20`20`20`20`20`20movzwl`20`20W`5EIHD$W_SYMDBGOFF(r1),r2
X`20`20`20`20`20`20`20`20addl2`20`20`20r2,r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20(r1),@B`5E8(ap)
X`20`20`20`20`20`20`20`20movzwl`20`20B`5E8(r1),@B`5E12(ap)
X`20`20`20`20`20`20`20`20ret
X;***************************************
X;
X;`20`20SYS2_FNDGLBTAB`20(`20HEADER`20,`20GLBTABADR`20,`20GLBTABLEN`20)
X;
X;`20`20find`20global-symbol-table
X;
X;***************************************
X`20`20`20`20`20`20`20`20.entry`20`20sys2_fndglbtab,`5Em<iv,r2>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),r1
X`20`20`20`20`20`20`20`20movzwl`20`20W`5EIHD$W_SYMDBGOFF(r1),r2
X`20`20`20`20`20`20`20`20addl2`20`20`20r2,r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),@B`5E8(ap)
X`20`20`20`20`20`20`20`20movzwl`20`20B`5E10(r1),@B`5E12(ap)
X`20`20`20`20`20`20`20`20ret
X;***************************************
X;
X;`20`20SYS2_FNDSYM1`20(`20RECORD`20,`20SYMBOL`20,`20SYMBOLLEN`20,`20ADDRESS`20
V,`20OK`20)
X;
X;`20`20find`20symbol`20in`20record
X;
X;***************************************
X`20`20`20`20`20`20`20`20.entry`20`20sys2_fndsym1,`5Em<iv,r2,r3,r4,r5>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E8(ap),r2
X`20`20`20`20`20`20`20`20cmpb`20`20`20`20(r1),#EXE$C_MODULE
X`20`20`20`20`20`20`20`20bneq`20`20`20`20100$
X;`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E2(r1),language
X;`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5E6(r1),modulelen
X;`20`20`20`20`20`20`20`20movc3`20`20`20modulelen,B`5E7(r1),module
X`20`20`20`20`20`20`20`20movl`20`20`20`20#FALSE,@B`5E20(ap)
X`20`20`20`20`20`20`20`20ret
X100$:`20`20`20cmpb`20`20`20`20(r1),#EXE$C_ENTRYPOINT
X`20`20`20`20`20`20`20`20bneq`20`20`20`20200$
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E2(r1),@B`5E16(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5E6(r1),@B`5E12(ap)
X`20`20`20`20`20`20`20`20movc3`20`20`20@B`5E12(ap),B`5E7(r1),@B`5E4(r2)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#TRUE,@B`5E20(ap)
X`20`20`20`20`20`20`20`20ret
X200$:`20`20`20movl`20`20`20`20#FALSE,@B`5E20(ap)
X`20`20`20`20`20`20`20`20ret
X;***************************************
X;
X;`20`20SYS2_FNDSYM2`20(`20RECORD`20,`20OK`20)
X;
X;`20`20find`20symbol`20in`20record
X;
X;***************************************
X`20`20`20`20`20`20`20`20.entry`20`20sys2_fndsym2,`5Em<iv>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),r1
X`20`20`20`20`20`20`20`20cmpb`20`20`20`20(r1),#OBJ$C_GSD
X`20`20`20`20`20`20`20`20bneq`20`20`20`20100$
X`20`20`20`20`20`20`20`20movl`20`20`20`20#TRUE,@B`5E8(ap)
X`20`20`20`20`20`20`20`20ret
X100$:`20`20`20movl`20`20`20`20#FALSE,@B`5E8(ap)
X`20`20`20`20`20`20`20`20ret
X;***************************************
X;
X;`20`20SYS2_FNDSYM3`20(`20RECORD`20,`20SYMBOL`20,`20SYMBOLLEN`20,`20ADDRESS`20
V,`20RECL`20,`20OK`20)
X;
X;`20`20find`20symbol`20in`20record
X;
X;***************************************
X`20`20`20`20`20`20`20`20.entry`20`20sys2_fndsym3,`5Em<iv,r2,r3,r4,r5>
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(ap),r1
X`20`20`20`20`20`20`20`20movzwl`20`20(r1),r0
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E4(r1),r1
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5E8(ap),r2
X`20`20`20`20`20`20`20`20cmpb`20`20`20`20B`5EGPS$B_GSDTYP(r1),#GSD$C_PSC
X`20`20`20`20`20`20`20`20bneq`20`20`20`20100$
X`20`20`20`20`20`20`20`20addl2`20`20`20#GPS$T_NAME,@B`5E20(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EGPS$B_NAMLNG(r1),r0
X`20`20`20`20`20`20`20`20addl2`20`20`20r0,@B`5E20(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#FALSE,@B`5E24(ap)
X`20`20`20`20`20`20`20`20ret
X100$:`20`20`20cmpb`20`20`20`20B`5ESDF$B_GSDTYP(r1),#GSD$C_SYM
X`20`20`20`20`20`20`20`20bneq`20`20`20`20200$
X`20`20`20`20`20`20`20`20addl2`20`20`20#SDF$T_NAME,@B`5E20(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5ESDF$B_NAMLNG(r1),r0
X`20`20`20`20`20`20`20`20addl2`20`20`20r0,@B`5E20(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#FALSE,@B`5E24(ap)
X`20`20`20`20`20`20`20`20ret
X200$:`20`20`20cmpb`20`20`20`20B`5EEPM$B_GSDTYP(r1),#GSD$C_EPM
X`20`20`20`20`20`20`20`20bneq`20`20`20`20300$
X`20`20`20`20`20`20`20`20addl2`20`20`20#EPM$T_NAME,@B`5E20(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EEPM$B_NAMLNG(r1),r0
X`20`20`20`20`20`20`20`20addl2`20`20`20r0,@B`5E20(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20B`5EEPM$L_ADDRS(r1),@B`5E16(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EEPM$B_NAMLNG(r1),@B`5E12(ap)
X`20`20`20`20`20`20`20`20movc3`20`20`20@B`5E12(ap),B`5E12(r1),@B`5E4(r2)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#TRUE,@B`5E24(ap)
X`20`20`20`20`20`20`20`20ret
X300$:`20`20`20cmpb`20`20`20`20B`5EPRO$B_GSDTYP(r1),#GSD$C_PRO
X`20`20`20`20`20`20`20`20bneq`20`20`20`20400$
X`20`20`20`20`20`20`20`20addl2`20`20`20#PRO$T_NAME,@B`5E20(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EPRO$B_NAMLNG(r1),r0
X`20`20`20`20`20`20`20`20addl2`20`20`20r0,@B`5E20(ap)
X`20`20`20`20`20`20`20`20addl2`20`20`20r1,r0
X`20`20`20`20`20`20`20`20addl2`20`20`20#PRO$T_NAME,r0
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EFML$B_MAXARGS(r0),r3
X`20`20`20`20`20`20`20`20addl2`20`20`20#2,@B`5E20(ap)
X`20`20`20`20`20`20`20`20addl2`20`20`20#2,r0
X310$:`20`20`20tstl`20`20`20`20r3
X`20`20`20`20`20`20`20`20bleq`20`20`20`20320$
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EARG$B_BYTECNT(r0),r4
X`20`20`20`20`20`20`20`20addl2`20`20`20#2,@B`5E20(ap)
X`20`20`20`20`20`20`20`20addl2`20`20`20#2,r0
X`20`20`20`20`20`20`20`20addl2`20`20`20r4,@B`5E20(ap)
X`20`20`20`20`20`20`20`20addl2`20`20`20r4,r0
X`20`20`20`20`20`20`20`20decl`20`20`20`20r3
X`20`20`20`20`20`20`20`20brb`20`20`20`20`20310$
X320$:`20`20`20movl`20`20`20`20B`5EPRO$L_ADDRS(r1),@B`5E16(ap)
X`20`20`20`20`20`20`20`20cvtbl`20`20`20B`5EPRO$B_NAMLNG(r1),@B`5E12(ap)
X`20`20`20`20`20`20`20`20movc3`20`20`20@B`5EPRO$T_NAME(ap),B`5E12(r1),@B`5E4(r2
V)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#TRUE,@B`5E24(ap)
X`20`20`20`20`20`20`20`20ret
X400$:`20`20`20addl2`20`20`20r0,@B`5E20(ap)
X`20`20`20`20`20`20`20`20movl`20`20`20`20#FALSE,@B`5E24(ap)
X`20`20`20`20`20`20`20`20ret
X`20`20`20`20`20`20`20`20.end
$ call unpack SYS2.MAR;1 320677519 "" 9 6 8 
$!
$ create 'f'
X$`20fortran/g_f/warn=decl`20give_name
X$`20fortran/g_f/warn=decl`20utl
X$`20fortran/g_f/warn=decl`20qs
X$`20macro`20sys
X$`20macro`20sys2
X$`20fortran/g_f/warn=decl`20get_byt
X$`20libr/obj/create`20give_name`20give_name,utl,qs,sys,sys2,get_byt
X$`20exit
$ call unpack BUILD.COM;1 942881074 "" 1 7 8 
$!
$ create 'f'
XExample`20(with`20FORTRAN`20program`20TEST):
X
X`20`20$`20FORTRAN`20TEST
X`20`20$`20LINK/DEBUG`20TEST+GIVE_NAME/LIBR
X`20`20$`20RUN/NODEB`20TEST
X
$ call unpack USAGE.TXT;1 1125598523 "" 1 8 8 
$ v=f$verify(v)
$ exit

