.title six_macros
;------------------------------------------------------------------------
; Macro to reset the length of a fake variable-length string.
;
; By my convention, the maximum length of a string is stored in the
; word preceeding the string descriptor quadword.
;
      .macro _RESLEN addr
         movw addr-4, addr
      .endm

;------------------------------------------------------------------------
; Macro to get a value-string from the command line,
; and optionally call an action-routine to use it.
;
; If there is a list of values, the action routine is called with each.
;
      .macro _GET_VALUE, entity, routine, desc=six_xstr, ?x, ?y
x:       _reslen desc			; Call get_value to get string
         pushaw desc
         pushaq  desc
         pushaq  entity
         calls   #3, g^cli$get_value
         .if not_blank <routine>
            blbc    r0, y		; Save get_value status
            movl    r0, -(sp)
            movaq  desc, r0
            jsb     routine		; Pass string to action routine
            movl    (sp)+, r1
            _if_err <<jsb six_err_number>>	; Test for error
            _if_eql r1, #cli$_comma, <<brb x>>	; Loop if get_value status
y:     					;    indicates there's another string
         .endc
      .endm

;-------------------------------------------------------------------------
; Macro to output a record to the open output file (if there is one).
;
; There are three formats:
;     _output [desc=]dx-adr   -- prints the string from a string descriptor
;     _output nam=nam-adr     -- prints the file name from a NAM block
;     _output rab=rab-adr     -- prints the buffer from an RAB block
; Optionally specify alternate output rab with "outrab=rab-adr".
;
      .macro _OUTPUT desc, nam, rab, outrab=six_out_rab, ?x
      _if_eql six_out_file, <<brb x>>, type=W
      .if not_blank <desc>
         movw   <desc>,          <outrab+rab$w_rsz>
         movl   <desc+4>,        <outrab+rab$l_rbf>
      .endc
      .if not_blank <nam>
         movzbw <nam+nam$b_rsl>, <outrab+rab$w_rsz>
         movl   <nam+nam$l_rsa>, <outrab+rab$l_rbf>
      .endc
      .if not_blank <rab>
         movw   <rab+rab$w_rsz>, <outrab+rab$w_rsz>
         movl   <rab+rab$l_rbf>, <outrab+rab$l_rbf>
      .endc
      $put       <outrab>
      _if_err    <<jsb six_err_output>>
x:
      .endm

;------------------------------------------------------------------------
; Macro to push address of a descriptor pointing to
;    1) a string described by a string-descriptor (_PUSH_STR desc   ), or
;    2) a filename extracted from a FAB/NAM block (_PUSH_STR FAB=nam), or
;    3) a text record extracted from a RAB block  (_PUSH_STR RAB=rab)
;
      .macro _PUSH_STR str, fab, rab, desc=six_xdx
      _get_str <str>, <fab>, <rab>, <desc>
      pushaq desc
      .endm

;--------------------------------------------------------------------------
; Macro to fill in a descriptor with:
;    1) a string described by a string-descriptor (_GET_STR desc   ), or
;    2) a filename extracted from a FAB/NAM block (_GET_STR FAB=nam), or
;    3) a text record extracted from a RAB block  (_GET_STR RAB=rab)
; This macro uses r1 to store the address of the FAB's NAM block.
; Also note that this destroys previous contents of the descriptor,
;   so use scratch quadword.
;
      .macro _GET_STR str, fab, rab, desc=six_xdx, ?x
      .if not_blank <str>				; if from a descriptor
         movq   str, desc
      .endc
      .if not_blank <rab>				; if from a RAB
         movzwl <rab+rab$w_rsz>, desc
         movl   <rab+rab$l_rbf>, desc+4
      .endc
      .if not_blank <fab>				; if from a FAB
         movl    fab+fab$l_nam, r1
         _if_neq nam$b_rsl(r1), type=b, -			; if searched
      		<<movzbw nam$b_rsl(r1), desc  >, -
                 <movl   nam$l_rsa(r1), desc+4>, -
                 <brb    x>>
         _if_neq nam$b_esl(r1), type=b, -			; if parsed
                <<movzbw nam$b_esl(r1), desc  >, -
                 <movl   nam$l_esa(r1), desc+4>, -
                 <brb    x>>
         movzbw <fab+fab$b_fns>, desc				; if not even
         movl   <fab+fab$l_fna>, desc+4				;    that
x:
      .endc
      .endm

;--------------------------------------------------------------------------
; Macros to allocate and initialize text strings.
; 
; _ASCII and _ASCID both produce a string.
; _ASCID preceeds it with a descriptor.
;
; macro parameters:
;    Len = The number of characters in the string.
;	   If blank, the length of the Str parameter is used.
;    Str = The initial value of the text string.  i.e. str=<INIT>.
;    Fil = The fill character used to pad out the allocated length.
;	   By default this is a blank (" ").
;    Jst = Either LEFT or RIGHT, specifying how the initialization
;          string should be positioned in the allocated space.
;   Addr = Label to be equated with the address of the beginning of the
;          text string.  If you want to equate a symbol with the address
;          of the descriptor, use the format "label: _ASCID p1,...".
;  Scope = Either GBL or LCL, declaring the string address label
;          to be either a global or a local symbol.  Default is LCL.
;
      .macro   _ASCID   len, str, fil=< >, jst=left, addr, scope=LCL
          .if blank <len>
              .iif blank <str>, .error
              .long %length( str )
              .address . + 4
              .if not_blank <addr>
                 .iif idn <scope>, <lcl>, addr:
                 .iif idn <scope>, <gbl>, addr::
              .endc
              .ascii `str`
          .if_false
              .long len
              .address . + 4
              .if not_blank <addr>
                 .iif idn <scope>, <lcl>, addr:
                 .iif idn <scope>, <gbl>, addr::
              .endc
              .if blank <str>
                  .byte ^a`fil` [len]
              .if_false
                  _strd.xlen = len - %length( str )
                  .iif le _strd.xlen, .error
                  .if identical jst left
                      .ascii `str`
                  .iff
                      .iif different jst right, .error
                  .endc
                  .byte ^a`fil` [_strd.xlen]
                  .iif identical jst right, .ascii `str`
              .endc
          .endc
      .endm

;---------------------------

      .macro   _ASCII   len, str, fil=< >, jst=left, addr, scope=LCL
          .if not_blank <addr>
             .iif idn <scope>, <lcl>, addr:
             .iif idn <scope>, <gbl>, addr::
          .endc
          .if blank <len>
              .iif blank <str>, .error
              .ascii `str`
          .if_false
              .if blank <str>
                  .byte ^a`fil` [len]
              .if_false
                  _strd.xlen = len - %length( str )
                  .iif le _strd.xlen, .error
                  .if identical jst left
                      .ascii `str`
                  .iff
                      .iif different jst right, .error
                  .endc
                  .byte ^a`fil` [_strd.xlen]
                  .iif identical jst right, .ascii `str`
              .endc
          .endc
      .endm

;----------------------------------------------------------------------------
; macros to implement conditionals.
;
; a series of macros that can take three different formats:
;	_IF_<cond>  dest
; will jump if the current state matches the test condition.
;	_IF_<cond>  var, dest
; will compare the variable to zero, then jump if the test condtion is met.
;	_IF_<cond>  var1, var2, dest
; will compare the two variables, then jump if the test condition is met.
;
; the suggested style for the block-if is as follows:
;       _IF_EQL var1, var2, < <statement1> -
;                            ,<statement2> -
;                            ,<statement3> -
;                           >
;----------------------------------------------------------------------------
; Macro to invert a branch condition.
;
      .macro _INV_BR cond, dst, ?y
x'y = .
      .iif idn <cond>, <gtr>,  bleq dst   
      .iif idn <cond>, <leq>,  bgtr dst
        .iif idn <cond>, <neq>,  beql dst
        .iif idn <cond>, <nequ>, beqlu dst
        .iif idn <cond>, <eql>,  bneq dst
        .iif idn <cond>, <eqlu>, bnequ dst
      .iif idn <cond>, <geq>,  blss dst   
      .iif idn <cond>, <lss>,  bgeq dst
        .iif idn <cond>, <gtru>, blequ dst   
        .iif idn <cond>, <lequ>, bgtru dst
      .iif idn <cond>, <vc>,  bvs dst   
      .iif idn <cond>, <vs>,  bvc dst   
        .iif idn <cond>, <gequ>, blssu dst
        .iif idn <cond>, <lssu>, bgequ dst
        .iif idn <cond>, <cc>,   bcs dst
        .iif idn <cond>, <cs>,   bcc dst
      .iif eq .-x'y, .error ; no valid test condition for _INV_BR
      .endm

;----------------------------------------------------------------------------

      .macro _IF cond, p1, p2, p3, type=l, ?label

          .if not_blank <p3>		; _IF cond, var1, var2, stmts
              cmp'type p1, p2
              _inv_br cond, label
              .irp stmt, <p3>
                 stmt
              .endr
label:    .mexit

          .endc

          .if not_blank <p2>		; _IF cond, var, stmts
              tst'type p1
              _inv_br cond, label
              .irp stmt, <p2>
                 stmt
              .endr
label:        .mexit
          .endc

          .if not_blank <p1>		; _IF cond, stmts
              _inv_br cond, label
              .irp stmt, <p1>
                 stmt
              .endr
label:        .mexit
          .endc

          .error ; too few arguments to _IF
      .endm

;---------------------------------------
;      .irp test, - 
;          <gtr,leq,neq,eql,nequ,eqlu,geq,lss,gtru,lequ,vc,vs,gequ,lssu,cc,cs>
;         .macro _IF_'test  p1, p2, p3, type=l
;            _IF <test>, <p1>, <p2>, <p3>, <type>
;         .endm
;      .endr
;

      .macro _IF_GTR, p1, p2, p3, type=l
        _IF gtr, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_LEQ, p1, p2, p3, type=l
        _IF leq, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_NEQ, p1, p2, p3, type=l
        _IF neq, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_NEQU, p1, p2, p3, type=l
        _IF nequ, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_EQL, p1, p2, p3, type=l
        _IF eql, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_EQLU, p1, p2, p3, type=l
        _IF eqlu, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_GEQ, p1, p2, p3, type=l
        _IF geq, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_LSS, p1, p2, p3, type=l
        _IF lss, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_GTRU, p1, p2, p3, type=l
        _IF gtru, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_LEQU, p1, p2, p3, type=l
        _IF lequ, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_VC, p1, p2, p3, type=l
        _IF vc, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_VS, p1, p2, p3, type=l
        _IF vs, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_GEQU, p1, p2, p3, type=l
        _IF gequ, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_LSSU, p1, p2, p3, type=l
        _IF lssu, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_CC, p1, p2, p3, type=l
        _IF cc, <p1>, <p2>, <p3>, <type>
      .endm
      .macro _IF_CS, p1, p2, p3, type=l
        _IF cs, <p1>, <p2>, <p3>, <type>
      .endm

;-------------------------------------------------------------------------
; Macro to handle multiple commands on an error status.
;
      .macro _IF_ERR stmts, ?x
      blbs  r0, x
      .irp stmt, <stmts>
         stmt
      .endr
x:
      .endm

;-------------------------------------------------------------------------
; Macro to handle multiple commands on a success status.
;
      .macro _IF_SUCC stmts, ?x
      blbc  r0, x
      .irp stmt, <stmts>
         stmt
      .endr
x:
      .endm

;------------------------------------------------------------------------
; Macro to exit the program, suppressing DCL status messages.
;
; Actually we just load r0 and jsb to SIX_ERR_FADE.
;
      .macro _FADE status
         .iif dif <status>, <r0>, movl status, r0
         jsb  six_err_fade ; and hopefully never return!
      .endm

;------------------------------------------------------------------------
; Macros for setting up psects
; author:
;	Gordon O. Davisson
; modifications:
;	Names changed to conform to SIX standards, GCL.
;
      .macro   _ESECT   name=_code      ; executable code psect
        .psect   name, pic, con, rel, lcl, shr, exe, rd, nowrt, long
      .endm    _ESECT
;
;
      .macro   _WESECT  name=_wcode     ; writable executable code psect
        .psect   name, pic, con, rel, lcl, shr, exe, rd, wrt, long
      .endm    _WESECT
;
;
      .macro   _CSECT   name=_blank     ; fortran common block psect
        .psect   name, pic, ovr, rel, gbl, shr, noexe, rd, wrt, long
      .endm    _CSECT
;
;
      .macro   _PSECT   name=_pdata     ; constant data psect
        .psect   name, pic, con, rel, lcl, shr, noexe, rd, nowrt, long
      .endm    _PSECT
;
;
      .macro   _LSECT   name=_local     ; local variables psect
        .psect   name, pic, con, rel, lcl, noshr, noexe, rd, wrt, long
      .endm    _LSECT
;
;---------------------------------------------------------------------------