;The file GET-COMMAND-PROC.MAR contains a routine that will return
;the current (innermost) command procedure, or a zero length for
;interactive.  The file TEST-PROC.FOR is a sample program that
;calls this routine and writes out the procedure name.
;
;	$ Fortran TEST-PROC
;	$ Macro GET-COMMAND-PROC
;	$ Link /sysexe TEST-PROC,GET-COMMAND-PROC,SYS$LOADABLE_IMAGES:DCLDEF.STB
;
;to build (on Alpha).
;
;---------- File GET-COMMAND-PROC.MAR -----------------------------
;   Program to get the name of the current command procedure.
;       Tom Wade T.Wade@vms.eurokom.ie
;
;   Calling sequence   ret_code := GET_COMMAND_FILE_NAME (file, length)
;
;   file:       String to receive name of current command file (descriptor).
;   length:     Address of longword to receive length of file (reference).
;
;   e.g.   Integer *4     GET_COMMAND_FILE, length
;          Character *100 file                          (for FORTRAN)/
;
;   'file' will be blank padded.
;
;   Program requires CMEXEC privileges to get at the data.
;
;   Linking on Alpha requires
;
;  $ Link /sysexe <mainprog>,GET-COMMAND-PROC,SYS$LOADABLE_IMAGES:DCLDEF.STB

                .Title  GET_CURRENT_COMMAND_PROC

                $FABDEF
                $RABDEF
                .Link   "SYS$SYSTEM:DCLDEF.STB"/SELECTIVE_SEARCH
                .Link   "SYS$SYSTEM:SYS.STB"/SELECTIVE_SEARCH

                .Psect  DATA    noexe,wrt,noshr

Status:         .Long   0                       ; error code for truncation.
Arg_descriptor: .Long   0                       ; descriptor for input arg.
Address:        .Long   0                       ; pointer to string start.
Length:         .Long   0                       ; length of buffer.
Buflength = 512                                 ; size of buffer
Buffer:         .Blkb   buflength               ; temporary storage.

                .Psect  CODE    exe,nowrt,shr

                .Entry  GET_COMMAND_FILE_NAME ^M <R6, R7, R8>

                Movl    4(AP),  R6              ; get arg pointer
                Movl    (R6),   arg_descriptor  ; get filename
                Movl    4(R6), arg_descriptor+4 ;  I'd use a MOVQ but the
                                                ; AXP compiler whines about
                                                ; alignment :-(
                Movzwl  arg_descriptor,  R8     ; get length into longword.

                $CMEXEC_S       -               ; Nip upstairs and get the
                        routin=GET_INFO         ; information.
                Blbc    R0,     Exit            ; if error just indicate it.

                Pushl   R0                      ; save status returned.
                Movl    length, @8(AP)          ; return length in 2nd arg.
                Movc5   length, buffer, #^A" ",-        ; return string blank filled
                        R8, @address            ; in 1st arg.
                Popl    R0                      ; restore status value.
Exit:           Ret


                .Entry  Get_Info        ^M<R2, R3, R4, R5, R6>

                Movl    #Ctl$Ag_Clidata, R6     ; get address of CLI data.
                Movl    Ppd$L_Prc(R6),   R6     ; get DCL stuff.
                Tstw    Prc_W_proclevel(R6)     ; are we in a command proc ?
                Bneq    5$                      ; yes - carry on.
                Clrl    length                  ; return zero length string.
                Movl    #SS$_Normal,    R0      ; everything OK
                Ret                             ; and finished.

;;This code is for VMS prior to V8.* :
5$:             Movl    Prc_L_Inprab(R6),R6     ; get input RAB address
                Movl    Rab$L_Fab(R6),   R6     ; get FAB from RAB
                Movl    Fab$L_Nam(R6),   R6     ; get NAM block from FAB
                Movzbl  Nam$B_Rsl(R6),   length ; get length of filename
                Movl    Nam$L_Rsa(R6),   R6     ; get address of file name.

;;Turns out that newer DCLs (Itanium and Alpha V8.+) use 
;;NAML or NAM blocks.  To get a version that runs on Itanium (and probably
;;newer Alpha versions), replace the code above by
;;5$:
;;                Movl    Prc_L_IDFLNK(R6),R6     ; get IDF link
;;                Movl    IDF_L_FILENAME(R6),R6   ; addr of ASCIC/ASCIW filename
;;                Bbs     #IDF_V_RMS_NAM,IDF_W_FLAG(R6),8$
;;                Movzwl  (R6)+, length           ; get word length
;;                brb     9$
;;8$:            Movzbl  (R6)+, length           ; get byte length
;;9$:
                Movl    #SS$_Normal,    status  ; so far so good.

                Cmpl    length, #buflength      ; don't overflow the buffer
                Bleq    10$                     ; oops
                Movl    #buflength,     length  ; use shortened buffer
                Movl    #SS$_Bufferovf, status  ; indicate a problem.

10$:            Movc3   length, (R6), buffer    ; get stuff while in exec
                Movl    status,         R0      ; return the status to
                Ret                             ; calling routine.

                .End

;---------- File TEST-PROC.FOR ----------------------------------------
;
;        Program TEST
;        Implicit        None
;        Character *255  filename
;        Integer *4      length, ok, Get_Command_File_Name
;
;        ok = GET_COMMAND_FILE_NAME (filename, length)
;        If (.not. ok) call Sys$Exit (%Val (ok))
;
;        If (length .eq. 0) then
;                Call Lib$Put_Output ('(DCL)')
;        Else
;                call Lib$Put_Output (filename (1:length))
;        End If
;
;        End
;-------------------------------------------------------------------------
;
;---------------------------------------------------------
;Tom Wade                 | EMail: tee dot wade at eurokom dot ie
;EuroKom                  | Tel:   +353 (1) 296-9696
;A2, Nutgrove Office Park | Fax:   +353 (1) 296-9697
;Rathfarnham              | Disclaimer:  This is not a disclaimer            
;Dublin 14                | Tip:   "Friends don't let friends do Unix !"
;Ireland