zOs/REXX.O08/OFLD

/* copy oFld begin *****************************************************
     defines classes with field names
          is the base for the oo layer in copy o
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
oFldIni: procedure expose m.
    if m.oFld.ini = 1 then
        return
    m.oFld.ini = 1
    call mapIni
    m.o.fldOnly = mapNew()             /* map fields -> class  */
    m.o.cla.0 = 0                      /* the stem for classes */
    call oFldNew 'Class', '=', , ,     /* MetaClass definieren */
              'INST = MET .<>= FLD .<>=Class STEM =Class'
    return
endProcedure oFldIni

/*--- create a new class
          name: name of new class, a star will be replaced by a number
          va:   type of value
          st:   type of stem
          flds: pairs of field names and types
          dup:  duplicate resolver -----------------------------------*/
oFldNew: procedure expose m.
parse arg name, va, st, flds, dup
     if pos('*', name) > 0 then
         name = oPut('O.CLA', name, , '*')
     else
         call oPut 'O.CLA', name, , 'n'
     m.o.cla.name.inst = 0
     m.o.cla.name.val  = va
     m.o.cla.name.stem = st
     m.o.cla.name.FLD.0 = 0
     m.o.cla.name.MET.0 = 0
     return oFldAdd(name, flds, dup)
endProcedure oFldNew

/*--- create or find a class with only simple fields fs --------------*/
oFldOnly: procedure expose m.
parse arg fs, dup
    kk = space(fs '?'dup, 1)
    if mapHasKey(m.o.fldOnly, kk) then
        return mapGet(m.o.fldOnly, kk)
    if dup ^== 'e' then do
        ll = space(fs, 1)
        end
    else do
        ll = ''
        do wx=1 to words(fs)
            w = word(fs, wx)
            v = w
            do x=2 while wordPos(v, ff) > 0
                v = w || x
                end
            ll = space(ll v, 1)
            end
        end
    if mapHasKey(m.o.fldOnly, ll) then do
        nn = mapGet(m.o.fldOnly, ll)
        end
    else do
        nn = oFldNew('FldType*')
        st = 'O.CLA.'nn'.FLD'
        do lx=1 to words(ll)
            call oPut st, word(ll, lx), '=', dup
        end
        call mapPut m.o.fldOnly, ll, nn
        end
    call mapPut m.o.fldOnly, kk, nn
    return nn
endProcedure oFldOnly

/*--- return the stem of flds of class type --------------------------*/
oFlds: procedure expose m.
parse arg type
    return 'O.CLA.'type'.FLD'

/*--- return the concatenation of the fields of type ty in stem st
           formated by fmt -------------------------------------------*/
oFldCat: procedure expose m.
parse arg ty, st, fmt
    flds = oFlds(ty)
    res = ''
    do ix=1 to m.flds.0
        f = m.flds.ix
        if fmt == '' then
            res = res m.st.f
        else
            res = res fmt(m.st.f, m.fmt.ix)
        end
    return substr(res, 2)
endProcedure oFldCat

/*--- add fields to class cl given as name type pairs in fs ----------*/
oFldAdd: procedure expose m.
parse arg cla, fs, dup
    st = 'O.CLA.'cla'.FLD'
    do ix=1 by 2 to words(fs)
         call oPut st, word(fs, ix), word(fs, ix+1), dup
         end
    return cla
endProcedure oFldAdd

/*--- add/put key k with value v to stem st
      duplicate handling dup:
          * replace * in k by a number until it is new
          e add a number in it is not new
          o replace old value at existing key
          = add a new key, fail if key exists and value is different
          ------------------------------------------------------------*/
oPut: procedure expose m.
parse arg st, k, v, dup
    if dup = '*' then do
        cx = pos('*', k)
        if cx < 1 then
            call err 'no * in key' k
        k = oPutDupResolve(st, left(k, cx-1), 1)
        end
    else if symbol('m.st.k') = 'VAR' then do
        if dup = '' | dup = 'o' then do
            m.st.k = v
            return k
            end
        if dup = '=' then do
            if v <> m.st.k | ^ (v = '' & datatype(m.st.k, 'n')) then
                call err 'not =: m.'st'.'k '=>' m.st.k '<>' v
            return k
            end
        if dup = 'e' then
            k = oPutDupResolve(st, k, 2)
        else
            call err 'key' k 'exists in' st 'but dup' dup
        end
    else if dup = 'o' then
        call err 'old key' k 'does not exist in' st
    if datatype(k, 'n') | words(k) <> 1 | pos('.', k) > 0 then
        call err 'illegal name' k
    x = m.st.0 + 1
    m.st.0 = x
    m.st.x = k
    if v == '' then
        m.st.k = x
    else
        m.st.k = v
    return k
endProcedure oPut

oPutDupResolve: procedure expose m.
parse arg st, k, b
     do ix=b
         a = k || ix
         if symbol('m.st.a') <> 'VAR' then
             return a
         end
endProcedure oPutDupResolve

/*--- parameterized types --------------------------------------------*/
oGetTypePara: procedure expose m.
parse arg m
    if symbol('m.o.tyPa.m') == 'VAR' then
        return m.o.tyPa.m
    else
        return '='
endProcedure oGetTypePara

oSetTypePara: procedure expose m.
parse arg m, type, noCall
    if type = '' then
        type = '='
    if oGetTypePara(m) == type then
        return
    if noCall ^== 'noCall' then
        interpret oObjMethod(m, 'oSetTypePara')
    m.o.tyPa.m = type
    return
endProcedure oSetTypePara
/* copy oFld  end   ***************************************************/