zOs/REXX.O08/O3
call errReset 'h'
call o3Ini
call typ3New 'n Eins u f FEINS v,f FZWEI v',
, 'm','eins say "met eins"', 'zwei say "met zwei"'
say 'eins' o3ClaMet('Eins', 'eins')
o = o3New('Eins')
say 'o = new eins = ' o
say 'o.zwei' o3ObjMet(o, 'zwei')
call typ3New 'n Elf u Eins', 'm', 'zwei say "met Elf.zwei"',
, 'drei say "met Elf.drei"'
say 'Elf.zwei' o3ClaMet('Elf', 'zwei')
o11 = o3New('Elf')
say 'o11 = new eins = ' o11
say 'o11.eins' o3ObjMet(o11, 'eins')
say 'o11.zwei' o3ObjMet(o11, 'zwei')
say 'o11.drei' o3ObjMet(o11, 'drei')
say 'cast(o11).zwei' o3ObjMet(o3Cast(o11, 'Eins'), 'zwei')
say 'cast(o11).zwei' o3ObjMet(o3Cast(o3Cast(o11, 'Elf'),'Eins'), 'zwei')
say 'o3Copy(a, b)' o3Copy(a,b) 'm.b' m.b
say 'o3Copy('o', p)' o3Copy(o, p) m.p.fEins m.p.fZwei
c = o3CopyNew(a)
say 'o3CopyNew(a) m.'c m.c
exit
/* 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
***********************************************************************/
o3Ini: procedure expose m.
if m.o3.ini = 1 then
return
call typ3RegisterAdd 'call o3Register m'
return
o3Register: procedure expose m.
parse arg t
m.o3.o.t.0 = 0
if m.t = 'n' then do
call o3AddMethod 'O3.MET.'t, t
co = o3GenCopy(t)
say 'o3GenCopy('t')' co
p = 'O3.MET.'t'.o3Copy'
if symbol('m.p') ^== VAR then
m.p = co
end
return
o3AddMethod: procedure expose m.
parse arg md, t
if pos(m.t, 'rv') > 0 then
return
if m.t = 'm' then do
nm = m.t.name
m.md.nm = m.t.met
say 'add method' md'->'nm '=' m.md.nm
return
end
if m.t.type ^== '' then
call o3AddMethod md, m.t.type
if m.t.0 ^== '' then
do x=1 to m.t.0
call o3AddMethod md, m.t.x
end
return
endProcedure o3AddMethod
o3GenCopy: procedure expose m. done.
parse arg t, nm
if pos(m.t, 'rv') > 0 then do
if done.nm == 1 then
return ''
done.nm = 1
if translate(nm) == nm & pos('.M.', nm'.') < 1 & 0 ,
& pos('.f.', nm'.') < 1 & pos('.F.', nm'.') < 1 then
return 'm.t'nm '= m.m'nm';'
else
return 'f =' quote(substr(nm, 2))';m.t.f = m.m.f;'
end
if m.t = 'f' then
return o3GenCopy(m.t.type, nm'.'m.t.name)
if m.t.type ^== '' then
return o3GenCopy(m.t.type, nm)
if m.t.0 = '' then
return ''
res = ''
do tx=1 to m.t.0
res = strip(res o3GenCopy(m.t.tx, nm))
end
return res
endProcedure o3GenCopy
o3ClaMet: procedure expose m.
parse arg cl, me
if symbol('m.typ3.n2t.cl') ^== 'VAR' then
call err 'no type' cl 'in o3ClaMet('cl',' me')'
ty = m.typ3.n2t.cl
if symbol('m.o3.met.ty.me') ^== 'VAR' then
call err 'no method' me 'in type' cl 'in o3ClaMet('cl',' me')'
return m.o3.met.ty.me
endProcedure o3ClaMethod
o3New: procedure expose m.
parse arg className
if className == '' then
t = typ34Name('v')
else
t = typ34Name(className)
p = 'O3.O.'t
m.p.0 = m.p.0+1
obj = p'.'m.p.0
if className == '' then
drop m.typ3.o2t.obj
else
m.typ3.o2t.obj = t
say 'new' obj 'of class' className
return obj
endProcedure o3New
o3ObjMet: procedure expose m.
parse arg obj, me
if symbol('m.typ3.o2t.obj') == 'VAR' then do
c = m.typ3.o2t.obj
if symbol('m.o3.met.c.me') == 'VAR' then
return m.o3.met.c.me
call err 'no method' me 'in class' c 'of object' obj
end
if abbrev(obj, 'O3.CAST.') then do
cx = pos('.', obj, 9)
return 'M="'substr(obj, cx+1)'";' ,
o3ClaMet(substr(obj, 9,cx-9), me)
end
end
call err 'no class found for object' obj
endProcedure o3ObjMet
o3Cast: procedure
parse arg obj, cl
if abbrev(obj, 'O3.CAST.') then
obj = substr(obj, 1 + pos('.', obj, 9))
return 'O3.CAST.'cl'.'obj
endProcedure oCast
o3Copy: procedure expose m.
parse arg m, t
if symbol('m.typ3.o2t.m') == 'VAR' then
c = m.typ3.o2t.m
else if abbrev(m, 'O3.CAST.') then
parse var m 'O3.CAST.' c ':' m
else do
m.t = m.m
drop m.o3.o2t.t
return t
end
p = 'O3.MET.'m.typ3.o2t.m'.o3Copy'
if symbol('m.p') == 'VAR' then
interpret m.p
else
m.t = m.m
m.o3.o2t.t = m.o3.o2t.m
return t
endProcedure o3Copy
o3CopyNew: procedure expose m.
parse arg m
if symbol('m.o3.o2c.m') == 'VAR' then
return o3Copy(m, o3New(m.o3.o2c.m))
return o3Copy(m, o3New(''))
endProcedure o3CopyNew
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
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
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
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
/* copy o end *********************************************************/
/*---------------------------------------------------------------------
type with generic Types
---------------------------------------------------------------------*/
call errReset 'h'
call typ3Test
exit
typ3Test: procedure expose m.
call typ3Ini
meta = typ3New('t')
t1 = typ3New('n tf12 f eins f zwei v')
say 'f**2 ' t1
call typ3Say meta, t1
say 'f**2 ' typ3New('n tf2 f zwei v')
say 'f**2 ' typ3New('f eins f zwei v ')
say 'r s f**2' typ3New('r s f eins f zwei v ')
t2 = typ3New('n rs1 u s f eins f zwei v ',
, 'm', 'mEins mEins code','mEmpty')
call typ3Say meta, t2
call typ3Say meta, meta, 'meta'
say 'r s f**2' t2
say 's rs1 ' typ3New('s rs1')
m.qq.0 = 2
call typ3Dump
call typ3Say meta, typ3New(' rs1'), 't rs1 '
call typ3Say typ3New(' rs1 '), qq, 's rs1 '
say 'union' m.x m.x.name m.x.type
say 'meta@u' typ3New('meta@u', typ3New(,'u',,
, typ3New(,'f', v, 'name') ,
typ3New(,'s', v)))
say 'meta@f' typ3New('meta@f', typ3New(,'u',,
, typ3New(,'f', v, 'name') ,
typ3New(,'f', v, 'field')))
exit
qq1 = typ3New('u(f fEins pEins, f fZwei pZwei)',
, 'qq1', 'pEins pZwei')
say 'qq1 ' qq1
call typ3Say meta, qq1
pp1 = typ3New('qq1(v, r v)')
say 'pp1 ' pp1
call typ3Say meta, pp1
call typ3Say pp1, 'v'
qq2 = typ3New('u(f fEZ qq1(qEins,qZwei),f fZD qq1(qZwei,qDrei))',
, 'qq2', 'qEins qZwei qDrei')
say 'qq2 ' qq2
call typ3Say meta, qq2
pp2 = typ3New('qq2(f ppEins v, f ppZwei r v, f ppDrei r r v)')
say 'pp2 ' pp2
call typ3Say meta, pp2
call typ3Say pp2, 'v'
exit
return
/* copy typ3 begin *****************************************************
meta
c choice name type
f field name type
n name name type
p parameter name type
q param type name type stem
r reference type
s stem type
u union stem
v value
***********************************************************************/
typ3Ini: procedure expose m.
if m.typ3.ini == 1 then
return
m.typ3.ini = 1
call mapIni
m.typ3.0 = 0
m.typ3.tmp.0 = 0
call mapReset 'TYP3.N2T'
m.typ3.register = ''
meta = typ3New('n t u' ,
'c v n v v,' ,
'c r n r r,' ,
'c s n s r,' ,
'c u n u s r,',
'c f n f' typ3New('u f NAME v, f TYPE r')',',
'c n n n' typ3New('u f NAME v, f TYPE r')',',
'c c n c' typ3New('u f NAME v, f TYPE r')',',
'c m n m' typ3New('u f NAME v, f MET v') )
call typ3RegisterAdd "m.typ3.o2t.m = '"typ34Name('t')"'"
return
endProcedure typ3Ini
typ3Mutate: procedure expose m.
parse arg m, name
m.typ3.o2t.m = typ34Name(name)
return
endProcedure typ3Mutate
typ3Register: procedure expose m.
parse arg m
interpret m.typ3.register
return
endProcedure typ3Register
typ3RegisterAdd: procedure expose m.
parse arg code
call typ3Ini
regOld = m.typ3.register
m.typ3.register = code
do y = 1 to m.typ3.0
call typ3Register 'TYP3.'y
end
m.typ3.register = regOld code';'
return
endProcedure typ3RegisterAdd
typ3Dump: procedure expose m.
parse arg f, t
if f = '' then
f = 1
if t = '' then
t = m.typ3.0
do y=f to t
a = 'TYP3.'y
l = ''
if m.a.0 > 0 then
l = mCat(a, ', ')
say a m.a m.a.name m.a.type m.a.0 l
end
return
endProcedure typ3Dump
typ34Name: procedure expose m.
parse arg nm
if symbol('m.typ3.n2t.nm') == 'VAR' then
return m.typ3.n2t.nm
call err 'no type' nm
endProcedure typ34Name
typ34Obj: procedure expose m.
parse arg m
if symbol('m.typ3.o2t.m') == 'VAR' then
return m.typ3.o2t.m
call err 'typ34Obj('m') object not found'
endProcedure typ34Name
typ3New: procedure expose m.
parse arg tyEx
/* say left('typ3New', 20) tyEx */
if arg() <= 1 then
if mapHasKey(typ3.n2t, tyEx) then
return mapGet(typ3.n2t, tyEx)
t = typ3NewTmp(tyEx)
if arg() > 1 then do
pr = copies(arg(2) || ' ', length(arg(2)) == 1)
u = t
do while m.u ^== 'u'
if m.u.type == '' then
call err 'no union found' tyEx
u = m.u.type
end
do ax = 2+(pr ^== '') to arg()
call mAdd u, typ3New(pr || arg(ax))
end
end
p = typ3Permanent(t, 1)
if arg() <= 1 then
call mapAdd typ3.n2t, tyEx, p
/* say left('typ3New' p, 20) tyEx */
return p
endProcedure typ3New
typ3NewTmp: procedure expose m.
parse arg t3 nm re
if length(t3) > 1 then do
if nm ^== '' then
call err 'type' t3 'should stand alone:' t3 nm re
if abbrev(t3, 'TYP3.') then
return t3
if ^mapHasKey(typ3.n2t, t3) then
call err 'undefined type' t3
return mapGet(typ3.n2t, t3)
end
t = mAdd(typ3.tmp, t3)
m.t.name = ''
m.t.type = ''
m.t.met = ''
m.t.0 = ''
if pos(t3, 'v') > 0 then do
if nm ^== '' then
call err 'basicType' t3 'end of Exp expected:' t3 nm re
end
else if t3 = 'u' then do
fx = 0
m.t.0 = 0
re = nm re
ux = 0
do until fx = 0
tx = pos(',', re, fx+1)
if tx > fx then
sub = strip(substr(re, fx+1, tx-fx-1))
else
sub = strip(substr(re, fx+1))
if sub ^== '' then do
ux = ux + 1
m.t.ux = typ3New(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & t3 ^== 'r' then do
call err 'basicType' t3 'name or type Exp expected:' t3 nm re
end
else do
if pos(t3, 'sr') > 0 then do
if nm ^== '' then
m.t.type = typ3NewTmp(nm re)
end
else do
if pos(t3, 'cfmn') < 1 then
call err 'unsupported basicType' t3 'in' t3 nm re
m.t.name = nm
if t3 = 'm' then
m.t.met = re
else if re = '' then
call err 'basicType' t3 'type Exp expected:' t3 nm re
else
m.t.type = typ3NewTmp(re)
end
end
return t
endProcedure typ3NewTmp
typ3Permanent: procedure expose m.
parse arg t, free
if ^ abbrev(t, 'TYP3.TMP.') then
return t
if m.t.type ^== '' then
m.t.type = typ3Permanent(m.t.type)
if m.t.0 ^== '' then do
do tx=1 to m.t.0
m.t.tx = typ3Permanent(m.t.tx)
end
end
/* search equal permanent type */
do vx=1 to m.typ3.0
p = typ3'.'vx
if typ3Equal(t, p) then
leave
end
if vx > m.typ3.0 then do
p = mAdd(typ3, m.t)
m.p.name = m.t.name
m.p.type = m.t.type
m.p.met = m.t.met
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if m.p = 'n' then do
if mapHasKey(typ3.n2t, m.p.name) then
call err 'type' m.p.name 'already defined'
else
call mapAdd typ3.n2t, m.p.name, p
end
end
if free == 1 then
m.typ3.tmp.0 = substr(t, 10) - 1
call typ3Register p
return p
endProcedure typ3Permanent
typ3Equal: procedure expose m.
parse arg l, r
if m.l ^== m.r | m.l.type ^== m.r.type | m.l.0 ^= m.r.0,
| m.l.name ^== m.r.name | m.l.met ^== m.r.met then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx ^== m.r.sx then
return 0
end
return 1
endProcedure typ3Equal
typ3Say: procedure expose m.
parse arg t, a, pr
call typ3SayDone t, a, pr, pr
return
endProcedure typ3Say
typ3SayDone: procedure expose m. done.
parse arg t, a, pr, p1
if pos('.type', t a) > 0 then call err '?????? .type'
if p1 == '' then
p1 = pr
if right(p1, 1) ^== ' ' then
p1 = p1' '
if done.t.a == 1 then do
say p1'done @'a
return 0
end
done.t.a = 1
if m.t == 'v' then do
say p1'=' m.a
return 0
end
if m.t == 'n' then
return typ3SayDone(m.t.type, a, pr, p1'typeName' m.t.name)
if m.t == 'f' then
return typ3SayDone(m.t.type, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
reTo = m.a
if reTo == '' then
say p1'refTo' m.t.type '@null@'
else if m.t.type ^== '' then
return typ3SayDone(m.t.type, reTo, pr,
, p1'refTo' m.t.type '@'m.a)
else if symbol('m.typ3.o2t.reTo') == 'VAR' then
return typ3SayDone(m.typ3.o2t.reTo, reTo, pr,
, p1'refTo dynType' m.typ3.o2t.reTo '@'reTo)
else
say p1'refTo noType' reTo '@'a
return 0
end
if m.t = 'u' then do
say p1'union' m.t.0 '@'a
do ux=1 to m.t.0
call typ3SayDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
say p1'stem' m.a.0 m.t.type '@'a
do ux=1 to m.a.0
call typ3SayDone m.t.type, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call typ3SayDone m.t.type, a, pr, p1'c' m.t.name m.t.type
return 0
end
if m.t = 'm' then
return
call err 'bad basic type' m.t
return
endProcedure typ3SayDone
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 typ3 end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.read = ''
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
call scanIni
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanReset
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.atEnd = 1
m.m.pos = 1
return m
endProcedure scanSrc
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len ^= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok ^== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok ^== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if ^ scanVerify(m, '0123456789') then
return 0
if chEn^==0 & pos(substr(m.m.src, m.m.pos,1), m.m.scanNameR)>0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
scanInt: procedure expose m.
parse arg m, chEn
if scanNat(m, chEn) then
return 1
ox = m.m.pos
if pos(substr(m.m.src, ox, 1) , '+-') < 1 then
return 0
m.m.pos = ox + 1
if | scanNat(m) then do
m.m.pos = ox
return 0
end
m.tok =substr(m.m.src, ox, 1)|| m.tok
return 1
endProcedure scanInt
scanBrackets: procedure expose m.
parse arg m, op, cl, st
sx = m.m.pos
dep = 0
do forever
call scanVerify m, op || cl || st, 'm'
if ^ scanChar(m, 1) then
if dep = 0 then
leave
else
call scanErr m, 'closing bracket' cl 'missing'
if m.m.tok = op then
dep = dep + 1
else if dep < 1 then do
m.m.pos = m.m.pos - 1
leave
end
else if m.m.tok = cl then
dep = dep - 1
end
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
return m.m.tok ^== ''
endProcedure scanBrackets
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.m.key = m.m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.read ^== '' then
interpret 'res = ' oObjMethod(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment ^== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.read ^== '' then
interpret 'return' oObjMethod(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.read == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg"\n" ||' oObjMethod(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv ^== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys ^== '' then
call err 'not implemented mapRemove('a',' ky')'
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') ^== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') ^== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA ^== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a ^== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m 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 *****************************************************/