From:	CSBVAX::MRGATE!@KL.SRI.Com,@wiscvm.wisc.edu,@YMIR.BITNET:KVC@ENGVAX.SCG.HAC.COM@SMTP 23-JUL-1987 23:21
To:	EVERHART
Subj:	FILESET utility, DCL archive (no tabs this time!)

Received: from wiscvm.wisc.edu by KL.SRI.COM with TCP; Thu 23 Jul 87 16:46:58-PDT
Received: from YMIR.BITNET by wiscvm.wisc.edu ; Thu, 23 Jul 87 18:45:04 CDT
Received: from ENGVAX.SCG.HAC.COM by YMIR.BITNET; Thu, 23 Jul 87 14:03 PDT
Date: Thu, 23 Jul 87 12:43 PDT
From: Kevin Carosso <@YMIR.BITNET:KVC@ENGVAX.SCG.HAC.COM>
Subject: FILESET utility, DCL archive (no tabs this time!)
To: info-vax@sri-kl.ARPA
X-VMS-To: INFO-VAX-SUBMIT

$ show default
$ check_sum = 1885746516
$ write sys$output "Creating FILESET.CLD"
$ create FILESET.CLD
$ DECK/DOLLARS="$*$*EOD*$*$"
Define type ATTRS
  Keyword TYPE, value, nonnegatable
  Keyword ORGANIZATION, value, nonnegatable
  Keyword CARRIAGE_CONTROL, value, nonnegatable
  Keyword SPANNED, nonnegatable
  Keyword NOSPANNED, nonnegatable
  Keyword EOF_BLOCK, value, nonnegatable
  Keyword EOF_BYTE, value, nonnegatable
  Keyword RECORD_SIZE, value, nonnegatable
  Keyword MAX_RECORD_SIZE, value, nonnegatable

Define verb FILESET
  Image PUB_ROOT:[SOURCE.FILESET]FILESET
  Parameter P1
    Label = FILESPEC
    Prompt = "File(s)"
    Value (Required, list, type = $FILE)
  Qualifier CREATION_DATE
    Nonnegatable
    Placement = positional
    Value (Required, type = $DATETIME)
  Qualifier REVISION_DATE
    Placement = positional
    Value (Required, type = $DATETIME)
  Qualifier EXPIRATION_DATE
    Placement = positional
    Value (Required, type = $DATETIME)
  Qualifier NOREVISION_DATE
    Nonnegatable
    Placement = positional
  Qualifier NOEXPIRATION_DATE
    Nonnegatable
    Placement = positional
  Qualifier ATTRIBUTES
    Nonnegatable
    Placement = positional
    Value (Required, list, type = ATTRS)

  Disallow ATTRIBUTES.SPANNED and ATTRIBUTES.NOSPANNED
$*$*EOD*$*$
$ checksum FILESET.CLD
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 1500609383
$ write sys$output "Creating FILESET.MAR"
$ create FILESET.MAR
$ DECK/DOLLARS="$*$*EOD*$*$"
        .Title  Fileset - Set some file attributes.

;++
;
; Written by Kevin Carosso, Hughes SCG|PWB, July 30, 1982.
;
; This program modifies file attributes. Command line
; qualifiers specify the attributes to be changed, parameter
; P1 is the file.
;
; Modified by Kevin Carosso, Hughes SCG|CTC, November 26, 1984.
; (For VMS V4.0)
;
; Removed /OWNER, since SET FILE has had that since V3.
; Added some more useful qualifiers:
;       /ATTRIBUTES = (TYPE = {FIXED, VARIABLE, VFC, UNDEFINED,
;                              STREAM, STREAMLF, STREAMCR},
;                      ORGANIZATION = {SEQUENTIAL, RELATIVE,
;                                      INDEXED, DIRECT}
;                      EOF_BLOCK = nnn, EOF_BYTE = mmm
;                      RECORD_SIZE = nnn
;                     )
;
;--

        $CLIDEF         ; CLI definitions.
        $DSCDEF         ; Data descriptor definitions.
        $FIBDEF         ; FID definitions.
        $ATRDEF         ; Attribute Control Block definitions.
        $TPADEF         ; TPARSE definitions.

        .Library        /SYS$LIBRARY:LIB/
        .Library        /MACLIB/                ; Some useful macros.

        $FATDEF

        .Sbttl  Data - Data definitions for Fileset

        .Psect  Fildata, wrt, rd, noexe, long

;
; We need RMS data areas because we will use RMS to parse the file spec.
;

modFAB: $FAB    NAM = modNAM,-
                FNA = file_buff

modNAM: $NAM    ESS = NAM$c_maxrss,-
                ESA = expbuf

expbuf: .blkb   NAM$c_maxrss            ; Buffer for resultant string .

iosb:   .quad   0                       ; I/O status block.
;
; The FIB is used to communicate with the ACP.
;
FIB_desc:
        .long   FIB$c_extdata           ; FIB descriptor.
        .address        FIB

FIB:    .long   FIB$m_write !-          ; Allow write access for us,
                FIB$m_noread !-         ; deny read and write for others.
                FIB$m_nowrite

        .blkb   FIB$c_extdata - <.-FIB> ; Rest of the File Id Block (mbz).
;
; The Attribute Control Block determines what attributes to change.
;
ACB:    .blkl   <14 * 2> + 1            ; Maximum size of the block.

cre_date:       .quad   0               ; System format date and time.
rev_date:       .quad   0
exp_date:       .quad   0

attr_ACB:       .word   ATR$S_RECATTR   ; Used to get old record attributes
                .word   ATR$C_RECATTR
                .long   attr_block
                .long   0

attr_type:      .long   0               ; Holds attribute "TYPE" while parsing
attr_org:       .long   0               ; Holds attribute "ORG" while parsing
attr_cc:        .long   0               ; Record attributes (carriage-control)
attr_spn:       .long   0               ; Record attributes (span)
attr_eof_block: .long   0               ; End of file block
attr_eof_byte:  .long   0               ; End of file byte
attr_rsize:     .long   0               ; record size
attr_max_rsize: .long   0               ; maximum record size

attr_block:     .blkb   ATR$S_RECATTR   ; Record attr block itself

attr_change:    .long   0               ; Mask of attrs to change
                change_type = 0
                change_org = 1
                change_cc = 2
                change_spn = 3
                change_eof_block = 4
                change_eof_byte = 5
                change_rsize = 6
                change_max_rsize = 7
;
; We need to specify a channel and a device descriptor to talk to the ACP.
;
channl: .word   0                       ; Channel number

desc:   .quad   0                       ; Device name descriptor.
;
; Here are some definitions for the interface to the CLI.
;
cre_qual:
        .ascid  /CREATION_DATE/         ; /CREATION_DATE
cre_val:
        .ascid  /dd-mmm-yyyy hh:mm:ss.tt/

rev_qual:
        .ascid  /REVISION_DATE/         ; /REVISION_DATE
rev_val:
        .ascid  /dd-mmm-yyyy hh:mm:ss.tt/
norev_qual:
        .ascid  /NOREVISION_DATE/       ; /NOREVISION_DATE

exp_qual:
        .ascid  /EXPIRATION_DATE/       ; /EXPIRATION_DATE
exp_val:
        .ascid  /dd-mmm-yyyy hh:mm:ss.tt/
noexp_qual:
        .ascid  /NOEXPIRATION_DATE/     ; /NOEXPIRATION_DATE
;
; Data for parsing /ATTRIBUTES.   We do this by looping through
; each possible value.  The attr_table has the addresses of the
; information we need for each value on the attribute switch.
;
attr_table:     .address        attr_type_qual          ; qualifier
                .address        attr_type_state         ; TPARSE states
                .address        attr_type_key           ; TPARSE keys

                .address        attr_org_qual
                .address        attr_org_state
                .address        attr_org_key

                .address        attr_cc_qual
                .address        attr_cc_state
                .address        attr_cc_key

                .address        attr_eof_block_qual
                .address        attr_eof_block_state
                .address        attr_eof_block_key

                .address        attr_eof_byte_qual
                .address        attr_eof_byte_state
                .address        attr_eof_byte_key

                .address        attr_rsize_qual
                .address        attr_rsize_state
                .address        attr_rsize_key

                .address        attr_max_rsize_qual
                .address        attr_max_rsize_state
                .address        attr_max_rsize_key

                .long   0                               ; end of table

attr_qual:
        .ascid  /ATTRIBUTES/
attr_type_qual:
        .ascid  /ATTRIBUTES.TYPE/
attr_org_qual:
        .ascid  /ATTRIBUTES.ORGANIZATION/
attr_cc_qual:
        .ascid  /ATTRIBUTES.CARRIAGE_CONTROL/
attr_spn_qual:
        .ascid  /ATTRIBUTES.SPANNED/
attr_nospn_qual:
        .ascid  /ATTRIBUTES.NOSPANNED/
attr_eof_block_qual:
        .ascid  /ATTRIBUTES.EOF_BLOCK/
attr_eof_byte_qual:
        .ascid  /ATTRIBUTES.EOF_BYTE/
attr_rsize_qual:
        .ascid  /ATTRIBUTES.RECORD_SIZE/
attr_max_rsize_qual:
        .ascid  /ATTRIBUTES.MAX_RECORD_SIZE/

attr_val:                               ; Returned value of qualifier
        .word   100
        .byte   DSC$k_dtype_t
        .byte   DSC$k_class_s
        .address        . + 4
        .blkb   100

file_param:
        .ascid  /FILESPEC/              ; Filename
file_val:
        .word   255
        .byte   DSC$k_dtype_t
        .byte   DSC$k_class_s
        .address        file_buff
file_buff:
        .blkb   255
;
;Table for lower to upper case translation:
;
lcuc:   .byte   00,01,02,03,04,05,06,07,08,09,10,11,12,13,14,15,-
                16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31
        .ascii  \ !"#$%&'()*+,-./0123456789:;<=>?@\
        .ascii  /ABCDEFGHIJKLMNOPQRSTUVWXYZ/
        .ascii  /[\]^_`/
        .ascii  /ABCDEFGHIJKLMNOPQRSTUVWXYZ/
        .ascii  /{|}~/
        .byte   127


        .Sbttl  Tparse definitions.

;
;                       Use TPARSE to match keywords.
;
; First the TYPE:
;
        $INIT_STATE     attr_type_state, attr_type_key

        $STATE
        $TRAN   'FIXED',,, FAT$C_FIXED, attr_type
        $TRAN   'VARIABLE',,, FAT$C_VARIABLE, attr_type
        $TRAN   'VFC',,, FAT$C_VFC, attr_type
        $TRAN   'UNDEFINED',,, FAT$C_UNDEFINED, attr_type
        $TRAN   'STREAM',,, FAT$C_STREAM, attr_type
        $TRAN   'STREAMLF',,, FAT$C_STREAMLF, attr_type
        $TRAN   'STREAMCR',,, FAT$C_STREAMCR, attr_type

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_type>, attr_change

        $END_STATE
;
; Now the ORGANIZATION:
;
        $INIT_STATE     attr_org_state, attr_org_key

        $STATE
        $TRAN   'SEQUENTIAL',,, FAT$C_SEQUENTIAL, attr_org
        $TRAN   'RELATIVE',,, FAT$C_RELATIVE, attr_org
        $TRAN   'INDEXED',,, FAT$C_INDEXED, attr_org
        $TRAN   'DIRECT',,, FAT$C_DIRECT, attr_org

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_org>, attr_change

        $END_STATE
;
; Now the CARRIAGE_CONTROL:
;
        $INIT_STATE     attr_cc_state, attr_cc_key

        $STATE
        $TRAN   'NONE',,,,
        $TRAN   'FORTRAN',,, FAT$M_FORTRANCC, attr_cc
        $TRAN   'IMPLIED',,, FAT$M_IMPLIEDCC, attr_cc
        $TRAN   'CR',,, FAT$M_IMPLIEDCC, attr_cc        ; Synonym for IMPLIED
        $TRAN   'PRINT',,, FAT$M_PRINTCC, attr_cc

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_cc>, attr_change

        $END_STATE
;
; The EOF block
;
        $INIT_STATE     attr_eof_block_state, attr_eof_block_key

        $STATE
        $TRAN   TPA$_DECIMAL,,,, attr_eof_block

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_eof_block>, attr_change

        $END_STATE
;
; The EOF byte
;
        $INIT_STATE     attr_eof_byte_state, attr_eof_byte_key

        $STATE
        $TRAN   TPA$_DECIMAL,,,, attr_eof_byte

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_eof_byte>, attr_change

        $END_STATE
;
; The RECORD_SIZE block
;
        $INIT_STATE     attr_rsize_state, attr_rsize_key

        $STATE
        $TRAN   TPA$_DECIMAL,,,, attr_rsize

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_rsize>, attr_change

        $END_STATE
;
; The MAX_RECORD_SIZE block
;
        $INIT_STATE     attr_max_rsize_state, attr_max_rsize_key

        $STATE
        $TRAN   TPA$_DECIMAL,,,, attr_max_rsize

        $STATE
        $TRAN   TPA$_LAMBDA, TPA$_EXIT,, <1@change_max_rsize>, attr_change

        $END_STATE

;
; TPARSE parameter block.
;
TPARSE_block:
        .long   TPA$K_count0            ; Block length.
        .long   TPA$M_abbrev            ; Allow abbreviations.
        .blkl   TPA$K_length0 - 8       ; Room for the rest of the block.

        .Sbttl  Fileset - Program proper.

        .Psect  Code, exe, rd, nowrt, long

        .Entry  Start, 0
;
; First find out what qualifiers were specified.
;
getfil: pushal  file_val                ; Get the file name
        pushal  file_param
        calls   #2, G^CLI$get_value
        blbs    r0, parse               ; Skip on if we got it.
        cmpl    r0, #CLI$_absent        ; If was just absent,
        bneq    egress                  ; then exit normally.
done:   movzwl  #SS$_normal, r0
egress: ret

parse:  movb    file_val,-              ; Set filename size.
                modFAB + FAB$b_fns
        moval   ACB, r6                 ; Get pointer to ACB

credat: pushal  cre_val
        pushal  cre_qual                ; See if we have /CREATION_DATE
        calls   #2, G^CLI$get_value
        cmpl    r0, #CLI$_absent        ; If not present, then
         beql   revdat                  ; go on.
        check   ERR = egress            ; Any other failure we die.

        movtc   cre_val, @cre_val + 4,-
                #^A/ /, lcuc,-
                cre_val, @cre_val + 4   ;Convert to uppercase.

        $BINTIM_S TIMBUF = cre_val,-    ; Convert to system date and time.
                  TIMADR = cre_date
        check   ERR = egress

        movw    #ATR$s_credate,-
                ATR$w_size(r6)          ; Set size field in ACB,
        movw    #ATR$c_credate,-
                ATR$w_type(r6)          ; type code,
        moval   cre_date,-
                ATR$l_addr(r6)          ; and pointer to new value.
        addl2   #8, r6                  ; Index to next entry in block.

revdat: pushal  norev_qual              ; See if we have /NOREVISION_DATE
        calls   #1, G^CLI$present
        blbc    r0, 10$                 ; Go on if not.
        clrq    rev_date                ; If so, then clear revision date.
        brb     20$

10$:    pushal  rev_val
        pushal  rev_qual                ; See if we have /REVISION_DATE
        calls   #2, G^CLI$get_value
        cmpl    r0, #CLI$_absent        ; If not present, then
         beql   expdat                  ; go on.
        check   ERR = egress            ; Any other failure we die.

        movtc   rev_val, @rev_val + 4,-
                #^A/ /, lcuc,-
                rev_val, @rev_val + 4   ;Convert to uppercase.

        $BINTIM_S TIMBUF = rev_val,-    ; Convert to system date and time.
                  TIMADR = rev_date
        check   ERR = egress

20$:    movw    #ATR$s_revdate,-
                ATR$w_size(r6)          ; Set size field in ACB,
        movw    #ATR$c_revdate,-
                ATR$w_type(r6)          ; type code,
        moval   rev_date,-
                ATR$l_addr(r6)          ; and pointer to new value.
        addl2   #8, r6                  ; Index to next entry in block.

expdat: pushal  noexp_qual              ; See if we have /NOEXPIRATION_DATE
        calls   #1, G^CLI$present
        blbc    r0, 1$                  ; Go on if not.
        clrq    exp_date                ; If so, then clear revision date.
        brb     2$

1$:     pushal  exp_val
        pushal  exp_qual                ; See if we have /EXPIRATION_DATE
        calls   #2, G^CLI$get_value
        cmpl    r0, #CLI$_absent        ; If not present, then
         beql   attr                    ; go on.
        check   ERR = egress            ; Any other failure we die.

        movtc   exp_val, @exp_val + 4,-
                #^A/ /, lcuc,-
                exp_val, @exp_val + 4   ;Convert to uppercase.

        $BINTIM_S TIMBUF = exp_val,-    ; Convert to system date and time.
                  TIMADR = exp_date
        check   ERR = egress

2$:     movw    #ATR$s_expdate,-
                ATR$w_size(r6)          ; Set size field in ACB,
        movw    #ATR$c_expdate,-
                ATR$w_type(r6)          ; type code,
        moval   exp_date,-
                ATR$l_addr(r6)          ; and pointer to new value.
        addl2   #8, r6                  ; Index to next entry in block.
;
; See if he wants to do anything to the record attributes.
;
attr:   pushal  attr_qual               ; See if we have any /ATTRIBUTEs
        calls   #2, G^CLI$PRESENT
        cmpl    r0, #CLI$_ABSENT        ; If not present, then
         bneq   10$
         brw    endACB                  ; go on.
10$:    check   ERR = egress            ; Any other failure we die.
;
; Initialize things
;
        movw    #ATR$S_RECATTR, -       ; Set size field in the ACB,
                ATR$W_SIZE(r6)
        movw    #ATR$C_RECATTR, -       ; and type,
                ATR$W_TYPE(r6)
        moval   attr_block, -           ; and pointer to record attr block.
                ATR$L_ADDR(r6)
        addl2   #8, r6                  ; Index to next entry in block.

        clrl    attr_change             ; Clear which ones to change
;
; First check keywords without values
;
        pushal  attr_spn_qual           ; See if we have SPANNED
        calls   #1, G^CLI$present
         blbc   r0, 20$                 ; Go on if not.
        clrl    attr_spn                ; Clear indicator of NOSPANNED
        brb     30$

20$:    pushal  attr_nospn_qual         ; See if we have NOSPANNED
        calls   #1, G^CLI$present
         blbc   r0, 40$                 ; Go on if not.
        movl    #1, attr_spn            ; Set indicator of NOSPANNED

30$:    bisl2   #<1@change_spn>, -      ; Say we have to diddle SPAN bit
                attr_change

40$:
;
; Loop over all keywords with values... R7 points into their table.
;
        moval   attr_table, r7          ; Table for value information
get_attr:
        tstl    (r7)                    ; End of table?
         beql   endACB                  ; if so, finish up the ACB

        pushal  attr_val
        pushl   (r7)                    ; Qualifier value
        calls   #2, G^CLI$get_value
        cmpl    r0, #CLI$_absent        ; If present, then
         bneq   10$                     ; process it.
        addl2   #12, r7                 ; else bump table index
        brb     get_attr                ; try another one
10$:    check   ERR = egress            ; Any other failure we die.
;
; Use TPARSE to find the record attribute he wanted.
;
        movq    attr_val,-
                TPARSE_block + TPA$L_stringcnt
        pushl   8(r7)                   ; Address of keywords
        pushl   4(r7)                   ; Address of states
        pushal  TPARSE_block
        calls   #3, G^LIB$TPARSE        ; Go parse it.
        check   ERR = egress

        addl2   #12, r7                 ; Bump table index
        brb     get_attr                ; and try another one
;
; Finish up by terminating ACB with a 0.
;
endACB: moval   ACB, r4                 ; Get top of ACB
        cmpl    r6, r4                  ; Make sure at least something was
         bneq   20$                     ; to be modified.
        brw     getfil                  ; otherwise try another file.
20$:    clrl    (r6)                    ; End with a 0
;
; First set up file and channel to the ACP.
;
        $PARSE  FAB = modFAB            ; Use RMS to parse it.
        check   ERR = egress

lookup: $SEARCH FAB = modFAB            ; Look up the file.
        cmpl    r0, #RMS$_nmf           ; See if just no more files
         bneq   10$
        brw     getfil

10$:    check   ERR = egress

        movzbl  modNAM + NAM$b_esl,-    ; Make descriptor to resultant
                desc                    ; filename string.
        movl    modNAM + NAM$l_esa,-
                desc + 4
        $ASSIGN_S       DEVNAM = desc,- ; Assign channel to ACP.
                        CHAN = channl
        check   ERR = egress
;
; Set the FID in the FIB
;
        movw    modNAM + NAM$w_fid_num,-
                FIB + FIB$w_fid_num
        movw    modNAM + NAM$w_fid_seq,-
                FIB + FIB$w_fid_seq
        movw    modNAM + NAM$w_fid_rvn,-
                FIB + FIB$w_fid_rvn
;
; If he specified something having to do with a record attribute, then
; we have to get old RECATTR settings first.
;
        tstl    attr_change
         bneq   old_attr
        brw     modify

old_attr:
        $QIOW_S CHAN = channl, -        ; Access to read old attributes
                FUNC = #<IO$_ACCESS!IO$M_ACCESS>, -
                IOSB = iosb, -
                P1 = FIB_desc, -
                P5 = #attr_ACB
        check   ERR = egress
        check   iosb, ERR = egress

        bbc     #change_type, attr_change, 10$  ; Change the TYPE field?
        insv    attr_type, #FAT$V_RTYPE, -      ; Change old field
                #FAT$S_RTYPE, -
                attr_block + FAT$B_RTYPE

10$:    bbc     #change_org, attr_change, 20$   ; Change the ORG field?
        insv    attr_org, #FAT$V_FILEORG, -     ; Change old field
                #FAT$S_FILEORG, -
                attr_block + FAT$B_RTYPE

20$:    bbc     #change_cc, attr_change, 30$    ; Change the CC field?
        bicb2   #<FAT$M_FORTRANCC! -            ; Clear any old CC
                  FAT$M_IMPLIEDCC! -
                  FAT$M_PRINTCC>,  -
                attr_block + FAT$B_RATTRIB
        bisb2   attr_cc, -                      ; and set the new.
                attr_block + FAT$B_RATTRIB

30$:    bbc     #change_spn, attr_change, 40$   ; Change the SPN bit?
        tstl    attr_spn                        ; Set or clear it?
         beql   31$
        bisb2   #FAT$M_NOSPAN, -                ; set it => NOSPAN
                attr_block + FAT$B_RATTRIB
        brb     40$
31$:    bicb2   #FAT$M_NOSPAN, -                ; clear it => SPAN
                attr_block + FAT$B_RATTRIB

40$:    bbc     #change_eof_block, attr_change, 50$     ; Change EOF block #?
        movw    attr_eof_block, -
                attr_block + FAT$W_EFBLKL               ; Set low order
        movw    attr_eof_block + 2, -
                attr_block + FAT$W_EFBLKH               ; Set high order

50$:    bbc     #change_eof_byte, attr_change, 60$      ; Change EOF byte #?
        movw    attr_eof_byte, -
                attr_block + FAT$W_FFBYTE               ; Set it

60$:    bbc     #change_rsize, attr_change, 70$         ; Change RSIZE?
        movw    attr_rsize, -
                attr_block + FAT$W_RSIZE                ; Set it

70$:    bbc     #change_max_rsize, attr_change, 80$     ; Change max RSIZE?
        movw    attr_max_rsize, -
                attr_block + FAT$W_MAXREC               ; Set it

80$:
;
; Now modify the file attributes.
;
modify: $QIOW_S CHAN = channl,-         ; Issue QIO request.
                FUNC = #IO$_modify,-
                IOSB = iosb,-
                P1 = FIB_desc,-
                P5 = #ACB
        check   ERR = egress
        check   iosb, ERR = egress
;
; Deassign the channel and loop back for more files.
;
        $DASSGN_S       CHAN = channl   ; Deassign ACP.

        brw     lookup                  ; Go on to next file.

        .End    Start
$*$*EOD*$*$
$ checksum FILESET.MAR
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 745828140
$ write sys$output "Creating MACLIB.MAR"
$ create MACLIB.MAR
$ DECK/DOLLARS="$*$*EOD*$*$"
        .Title  Maclib - Useful macros.



;++
;
; Written by Kevin Carosso @ Hughes S&CG PWB/ENG
;
; These macros are all placed in the macro library MATH$TOOLS:MACLIB.
;
;--

;------------------------------------------------------------------------------
;  Check is used to test status returns from procedure calls
;  and branch to the specified address on an error.  As a side
;  effect, R0 is loaded with the status if it was in fact an
;  error code.
;
;       CHECK  ARG = r0, ERR
;
;               ARG   - Argument containing the status we are to check.
;                       If ommitted, this will default to R0.
;               ERR   - Address to branch to on an error status.
;
        .Macro  check   ARG = r0, ERR, ?L

                blbs    ARG, L
        .if different ARG,r0
                movzwl  ARG, r0
        .endc
                brw     ERR
        L:
        .Endm

;------------------------------------------------------------------------------
;
; This is a simple set of macros to allow local variables to be defined
; on the frame for VAX-11 procedures. This mimics local variables
; in some VAX/VMS languages such as Pascal.
;
; Usage:
;
;       _VARBEG                         - To initialize the declaration.
;       _VAR    SYM, TYP, SIZ           - Declares the variable SYM,
;                                         of type TYP, and length SIZ.
;                                         SIZ defaults to 1.
;                                         Type must be one of: BYTE, WORD,
;                                         LONG, QUAD, or OCTA
;       _VAREND                         - To realign the stack and clean up.
;
;--

;
; _VARBEG  - initializes the environment.
;
        .Macro  _VARBEG

                offset... = 0

        .Endm   _VARBEG
;
; _VAR - Declares SYM, with type TYP and length SIZ.
;
        .Macro  _VAR, sym, typ, siz=1

                .If BLANK, sym
                        .Error ;Symbol required in _VAR declaration.
                        .Mexit
                .Endc

                .If BLANK, typ
                        .Error ;Type required in _VAR declaration.
                        .Mexit
                .Endc

                typelen... = 0

                .Iif IDENTICAL, typ,BYTE, typelen... = 1
                .Iif IDENTICAL, typ,WORD, typelen... = 2
                .Iif IDENTICAL, typ,LONG, typelen... = 4
                .Iif IDENTICAL, typ,QUAD, typelen... = 8
                .Iif IDENTICAL, typ,OCTA, typelen... = 16

                .If EQUAL, typelen...
                        .Error ;Invalid type in _VAR declaration.
                        .Mexit
                .Endc

                offset... = offset... - <typelen... * siz>
                sym = offset...

        .Endm   _VAR
;
; _VAREND - Knocks the stack down to make room on the frame.
;
        .Macro  _VAREND

                subl2   #<-offset...>, sp

        .Endm   _VAREND
$*$*EOD*$*$
$ checksum MACLIB.MAR
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ exit
