zOs/REXX.O08/O
/* copy o begin ********************************************************
object layer has three freatures
* an object may have a class which has methods
* an object may have a parmeterized type
* a class may contain field descriptions
***********************************************************************/
oClaMethod: procedure expose m.
parse arg cl, me
if symbol('m.o.cla.cl.met.me') = 'VAR' then
return m.o.cla.cl.met.me
else
call err 'no method' me 'in class' cl
endProcedure oClaMethod
oHasMethod: procedure expose m.
parse arg obj, me
cla = oGetClass(obj)
return symbol('m.o.cla.cl.met.me') = 'VAR'
endProcedure oHasMethod
oGetClass: procedure expose m.
parse arg Obj
if symbol('m.o.obj2cla.Obj') = 'VAR' then
return m.o.obj2cla.Obj
call err 'no class found for object' obj
endProcedure oGetClass
oObjMethod: procedure expose m.
parse arg obj, me
if symbol('m.o.obj2cla.obj') = 'VAR' then
return oClaMethod(m.o.obj2cla.obj, me)
if abbrev(obj, 'oCast:') then do
cx = pos(':', obj, 7)
return 'M="'substr(obj, cx+1)'";' ,
oClaMethod(substr(obj, 7,cx-7), me)
end
call err 'no class found for object' obj
endProcedure oObjMethod
oCast: procedure
parse arg obj, cl
if abbrev(obj, 'oCast:') then
obj = substr(obj, 1 + pos(':', obj, 7))
return 'oCast:'cl':'obj
endProcedure oCast
oNewClass: procedure expose m.
parse arg name, super
/* call oIni */
name = oFldNew(name)
neMe = 'O.CLA.'name'.MET'
neFi = 'O.CLA.'name'.FLD'
do sx=1 to words(super)
sup = word(super, sx)
if symbol('m.o.cla.sup') ^== 'VAR' then
call err 'superclass' sup 'is not defined'
if m.o.cla.sup.val ^== '' then
m.o.cla.name.val = m.o.cla.sup.val
if m.o.cla.sup.stem ^== '' then
m.o.cla.name.stem = m.o.cla.sup.stem
st = 'O.CLA.'sup'.MET'
do x=1 to m.st.0
olMe = m.st.x
call oPut neMe, olMe, m.st.olMe
end
st = 'O.CLA.'sup'.FLD'
do x=1 to m.st.0
olFi = m.st.x
call oPut neFi, olFi, m.st.olFi
end
end
call oMutate 'O.CLA.'name, 'Class'
return name
endProcedure oNewClass
oValStemFldsWKOLD: procedure expose m.
parse arg cl, m.o.cla.cl.val, m.o.cla.cl.stem, flds
st = 'O.CLA.'cl'.FLD'
do wx=1 by 2 to words(flds)
call oPut st, word(flds, wx), word(flds, wx+1)
end
return cl
endProcedure oValStemFlds
oNewTypeWKOLD: procedure expose m.
parse arg cl, va, st, flds
return oValStemFlds(oNewClass(cl), va, st, flds)
/*--- a field type has only fields of type '='
finds or creates a field Type with the fields of types tps
and the field list aFl.
if dup = 'e' duplicate field names are resolved ------------*/
oFiTypeWKOLD: procedure expose m.
parse arg tps, aFl, dup
if symbol('m.o.cla.fiType.tps.aFl.dup') = 'VAR' then
return m.o.cla.fiType.tps.aFl.dup
fs = ''
do wx=1 to words(tps)
t1 = oFlds(word(tps, wx))
do fx=1 to m.t1.0
fs = fs m.t1.fx
end
end
fs = fs aFl
fd = ''
do wx=1 to words(fs)
f1 = word(fs, wx)
if wordPos(f1, fd) < 1 then do
fd = fd f1
end
else if dup == 'e' then do
do dx=2 by 1 while wordPos(f1 || dx, fn fs) > 0
end
fd = fd f1 || dx
end
end
fd = space(fd aFl)
if symbol('m.o.cla.fiType.fd') = 'VAR' then do
res = m.o.cla.fiType.fd
end
else do
res = oNewClass("FiType*")
m.o.cla.fiType.fd = res
st = 'O.CLA.'res'.FLD'
do wx=1 to words(fd)
call oPut st, word(fd, wx), '='
end
end
m.o.cla.fiType.tps.aFl = res
return res
endProcedure oFiType
oDecMethods: procedure expose m.
parse arg cla
st = 'O.CLA.'cla'.MET'
do ax=2 to arg()
call oPut st, word(arg(ax), 1), subWord(arg(ax), 2)
end
return
endProcedure oDecMethods
oNew: procedure expose m.
parse arg cla
st = 'O.CLA.'cla
if symbol('M.st') ^== 'VAR' then
call err 'class' cla 'is not initialized'
nn = m.st.inst + 1
m.st.inst = nn
nn = 'O.C' || m.st || 'I' || nn
if symbol('m.o.obj2cla.nn') == 'VAR' then
call err 'oNew already defined:' nn
m.o.obj2cla.nn = cla
return nn
endProcedure oNew
oMutate: procedure expose m.
parse arg obj, class
if obj == 'O.C13I12' then do
end
if symbol('M.O.CLA.class') ^== 'VAR' then
call err 'class' class 'is not initialized'
m.o.obj2cla.obj = class
return obj
endProcedure oMutate
oSay: procedure expose m.
parse arg type, a, aPr, mPr
ty = 'O.CLA.'type
msg = mPr || substr(a, length(aPr)+1)
redir = 0
do forever
if type == '=' then do
say msg '=' m.a
return
end
else if abbrev(type, '=') then do
a = m.a
msg = msg '==>' a
redir = 1
type = substr(type, 2)
end
else if left(type, 2) = '<>' then do
k = m.a
a = left(a, lastPos('.', a))k
msg = msg '=<>' k
redir = 1
type = substr(type, 3)
end
else if left(type, 1) = '.' then do
if ^ datatype(m.a.0, 'n') then
call err 'type' type 'not stem but m.'a'.0 is' m.a.0
type = substr(type, 2)
if redir then do
say msg 'stem 1..'m.a.0':' type
end
else do
do y=1 to m.a.0
call oSay type, a'.'y, a'.', mPr' '
end
end
return
end
else if redir then do
say msg':' type
return
end
else do
leave
end
end
if m.ty.val = '=' then
say msg '=' m.a
else
say msg '=' m.a':' m.ty.val
/* call oSay m.ty.val, a,==>' m.a '(to' m.ty.val')' */
do y=1 to m.ty.fld.0
f = m.ty.fld.y
call oSay m.ty.fld.f , a'.'f, a'.', mPr' '
end
if m.ty.stem ^== '' then
call oSay '.'m.ty.stem, a, a, mPr
return
endProcedure oSay
oClear: procedure expose m.
parse arg type, a, val
if abbrev(type, '.') then do
m.a.0 = 0
end
else if abbrev(type, '<>') then do
m.a = val
call oClear substr(type, 3), left(a, lastPos('.', a))val, val
end
else if abbrev(type, '=') then do
m.a = ''
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.a = val
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oClear m.ty.fld.k, a'.'k, val
end
if m.ty.stem ^== '' then
call m.a.0 = 0
end
return a
endProcedure oClear
oCopy: procedure expose m.
parse arg t, f
if symbol('m.o.obj2cla.f') ^== 'VAR' then
call err f 'has no class'
cl = m.o.obj2cla.f
m.o.obj2cla.t = m.o.obj2cla.f
return oTyCopy(cl, t, f)
endProcedure oCopy
oTyCopy: procedure expose m.
parse arg type, t, f
if abbrev(type, '.') then do
do y=1 to m.f.0
call oTyCopy substr(type, 2), t'.'y, f'.'y
end
m.t.0 = m.f.0
end
else if abbrev(type, '<>') then do
k = m.f
m.t = k
call oTyCopy substr(type, 3), left(t, lastPos('.', t))k,
, left(f, lastPos('.', f))k
end
else if abbrev(type, '=') then do
m.t = m.f
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.t = m.f
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oTyCopy m.ty.fld.k, t'.'k, f'.'k
end
if m.ty.stem ^== '' then
call oTyCopy '.'m.ty.stem, t, f
end
return t
endProcedure oTyCopy
/*--- Run ------------------------------------------------------------*/
oRunner: procedure expose m.
parse arg code
return oRunnerReset(oNew('ORunner'), code)
oRunnerReset: procedure expose m.
parse arg m, pCode
m.m.code = pCode
return m
endProcedure oRunnerReset
oRun: procedure expose m.
parse arg m
interpret m.m.code
return
endProcedure oRun
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call oFldIni
call mapIni
m.o.paTy.0 = 0
call oFldNew '=', '='
call oDecMethods oNewClass('ORunner'), 'oRun call oRun m'
return
endProcedure oIni
/* copy o end *********************************************************/