zOs/REXX.O08/TYPE

call typeTest
exit
/* copy type begin ****************************************************/
typeGet:
parse arg name
    return mapGet(type, name)
endProcedure typeGet

typeNew: procedure expose m.
parse arg name, val, stem, flds, types
     call typeIni
     if pos(left(name, 1), '0123456789') > 0 | ^datatype(name, 'a') then
         call err 'bad type name' name
    ty = mapAdd(type, name)
    call mapPut type, name, ty
    m.ty.ass = '='
    return typeAtts(ty, val, stem, flds, types)
endProcedure typeNew

typeAtts: procedure expose m.
parse arg ty, val, st, flds, types
    m.ty.value = firstNS(val, m.typeSimple)
    if m.ty.value ^== m.typeSimple & left(m.ty.value, 1) ^= '*' then
            call err 'value type must be a reference not' val
    m.ty.stem = st
    m.ty.0 = words(flds)
    do y=1 to m.ty.0
        m.ty.y = word(flds, y)
        m.ty.y.cont = firstNS(word(types, y), m.typeSimple)
        end
    return ty
endProcedure typeAtts

firstNS: procedure
    do ax=1 to arg()
        if arg(ax) ^= '' then
            return arg(ax)
        end
    call err 'all space'
endProcedure firstNS

typeShow: procedure expose m.
parse arg ty, a, lv
    if lv='' then
        lv = 0
    pr = a
    if lv > 0 & lastPos('.', pr) > 0 then
        pr = left('', lv*2)substr(pr, lastPos('.', pr))
    do while left(ty, 1) = '*'
        say pr '-->' m.a '(to' ty')'
        return
        end
    if m.ty.value = m.typeSimple then
        say pr '=' m.a
    else
        say pr '==>' m.a '(to' m.ty.value')'
    do y=1 to m.ty.0
        call typeShow m.ty.y.cont, a'.'m.ty.y, lv+1
        end
    if m.ty.stem ^== '' then do
        do y=1 to m.a.0
            call typeShow m.ty.stem, a'.'y, lv+1
            end
        end
    return
endProcedure typeShow

typeClear: procedure expose m.
parse arg ty, a, val
    m.a = val
    do y=1 to m.ty.0
        call typeClear m.ty.type.y, a'.'m.ty.y
        end
    if m.ty.type ^== '' then
        m.a.0 = 0
    return
endProcedure typeClear

typeSay: procedure expose m.
parse arg t
    say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'fields' m.t.0
    return
endProcedure typeSay

typeCopy: procedure expose m.
parse arg ty, t, f
    m.t = m.f
    if left(ty, 1) = '*' then
        return
    do x = 1 to m.ty.0
        fld = m.ty.x
        call typeCopy m.ty.x.cont, t'.'fld, f'.'fld
        end
    if m.ty.stem ^== '' then do
        do y = 1 to m.f.0
            call typeCopy m.ty.stem, t'.'y, f'.'y
            end
        m.t.0 = m.f.0
        end
    return t
endProcedure typeCopy

typeIni: procedure expose m.
parse arg force
    if m.type.ini = 1 & force ^== 1 then
        return
    m.type.ini = 1
    call mIni
    call mapReset type, '='
    m.typeSimple = 'TYPE.1'
    siTy = typeNew('Simple')
    if m.typeSimple ^== siTy then
        call err 'm.typeSimple ^== siTy'
    stTy = typeNew('Stem', , siTy)
    tyTy = typeNew('Type')
    tyFi = typeNew('TypeField', , , 'CONT', '*'tyTy)
    tyTy = typeAtts(tyTy,     , tyFi, 'ASS VALUE   STEM',
                                    , siTy '*'tyTy '*'tyTy)
    ttTy = typeNew('StemType',, tyTy)
    return
endProcedure typeIni

typeTest: procedure
    call typeIni
    si = 'Simple'
    siTy = typeGet(si)
    say si '==>' siTy m.type.si m.typeSimple
    tyTy = typeGet('Type')
    ttTy = typeGet('StemType')
    say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
    call typeSay   siTy
    call typeShow tyTy, tyTy
    call typeCopy siTy, nnn, siTy'.'ass
    say 'm.nnn nach copy' m.nnn
    call typeCopy tyTy, mmm, siTy
    call typeSay   mmm
    call typeCopy tyTy, qqq, tyTy
    call typeSay   qqq
    call typeShow tyTy, qqq
    call typeShow ttTy, type
    return
endProcedure typeTest
/* copy type end   ****************************************************/