zOs/REXX.O08/TYP2
call typ2Test
exit
typ2Test: procedure expose m.
call typ2Ini
v = typ2Make('v', 'v')
say 'value' v
say 'meta@u' typ2Make('meta@u', typ2Make(,'u',,
, typ2Make(,'f', v, 'name') ,
typ2Make(,'s', v)))
say 'meta@f' typ2Make('meta@f', typ2Make(,'u',,
, typ2Make(,'f', v, 'name') ,
typ2Make(,'f', v, 'field')))
return
/* copy type begin *****************************************************
meta
u union stem
f field type field
v value type
r reference type
s stem type
***********************************************************************/
typ2Ini: procedure expose m.
m.typ2.0 = 0
return
endProcedure typ2Ini
typ2Make: procedure expose m.
parse arg nm, ma, ty, pl
if nm ^== '' then
if symbol('m.typ2.name.nm') == 'VAR' then
call err 'duplicate type' nm
nn = m.typ2.0 + 1
t = 'TYP2.'nn
m.t.name = nm
m.t.meta = ma
m.t.field = ''
m.t.type = ty
if ma = 'f' then
m.t.field = pl
if ma = 'u' then do
m.t.0 = words(pl)
do wx = 1 to m.t.0
m.t.wx = word(pl, wx)
end
end
if nm == '' then do
do tx=1 to m.typ2.0 until typ2eq(t, 'TYP2.'tx)
end
if tx = nn then
m.typ2.0 = nn
else
t = 'TYP2.'tx
end
else do
m.typ2.0 = nn
m.typ2.name.nm = t
end
say 'made' t m.t.name m.t.meta
return t
endProcedure typ2Make
typ2Eq: procedure expose m.
parse arg le, ri
if m.le.meta ^== m.ri.meta then
return 0
if m.le.name ^== m.ri.name | m.le.type ^== m.ri.type then
return 0
if m.le.meta == 'f' then
return m.le.field == m.ri.field
if m.le.meta == 'u' then do
if m.le.0 <> m.ri.0 then
return 0
do ix = 1 to m.le.0
if m.le.ix ^== m.ri.ix then
return 0
end
end
return 1
endProcedure typ2Eq
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 ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/