zOs/REXX.O08/TST
call errReset h
if adrEdit('macro (mArgs) NOPROCESS', '*') == 0 then
exit editMacro(mArgs)
if 1 then
call tstAll
if 1 then
call tstComp
exit
call compIni
call tstCompComp
exit
call tstCompPrimary
call tstCompDataIO
call tstTotal
call tstAll
exit
call tstEnv
call tstAll
editMacro: procedure expose m.
parse upper arg mArgs
call adrIsp 'control errors return'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 4 | pc = 12 | pc = 16 then do
say 'bitte Bereich mit q oder qq auswaehlen'
return 4
end
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
if pc = 0 then
call adrEdit "(dst) = lineNum .zDest"
else
dst = rLa
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
call compIni
call envIni
i = jBuf()
o = jBuf()
call jOpen i, 'w'
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(i)
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
call errReset 'h', 'call compErrHandler ggTxt, ggStem,' rFi',' rLa
r = compile(cmp, ty)
call errReset 'h', 'call runErrHandler ggTxt, ggStem,' ,
quote(o)',' dst
call envPush env('>£', o)
call oRun r
call envPop
lab = lineBefSt(dst+1, , o'.BUF')
return 0
endProcedure editMacro
compErrHandler: procedure expose m.
parse arg ggTxt, ggStem, rFi, rLa
call errReset 'h'
say 'compErr' ggTxt
say 'compErr' m.ggstem.0 m.ggstem.1
say 'compErr' m.ggstem.0 m.ggstem.2
parse var m.ggStem.2 "pos " pos " in line " lin":"
say "line" lin "pos" pos'.' 'rFi' rFi
lab = lineBef((rFi+lin), 'msgline', right('*', pos), ggTxt)
if ggStem ^== '' then
call lineBefSt lab, 'msgLine', ggStem
exit 0
endSubroutine compErrHandler
lineBefCmd: procedure
parse arg wh
if datatype(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) ^= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure lineBefCmd
lineBef: procedure
parse arg wh, type
cmd = lineBefCmd(wh)
do ax=3 to arg()
li = arg(ax)
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure lineBef
lineBefSt: procedure expose m.
parse arg wh, type, st
cmd = lineBefCmd(wh)
do ax=1 to m.st.0
li = m.st.ax
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure lineBefSt
runErrHandler: procedure expose m.
parse arg ggTxt, ggStem, so, dst
call errReset 'h'
say 'run error' ggTxt
lab = lineBefSt(dst+1, , so'.BUF')
say 'lab' lab
call lineBef lab, msgline, '*** error:' ggTxt
if ggStem ^== '' then
call lineBefSt lab, msgline, ggSt
exit 0
endSubroutine runErrHandler
/* tstComp +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
/*************
abc
efg
abc efg $@{ call err 'wie gehts' 'dir heute' $}
abc efg asdf
**************
abc
efg
abc efg
*************/
out eins
out zwei
out eins
out eins
out zwei
out zwei
out eins
out zwei
out eins
out zwei
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompStmt
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstTotal
return
endProcedure tstComp
tstCompRun: procedure expose m.
parse arg type cnt
src = jBuf()
call jOpen src, 'w'
do sx=2 to arg()
call jWrite src, arg(sx)
end
cmp = comp(src)
call jOut 'compile' type',' (sx-2) 'lines:' arg(2)
r = compile(cmp, type)
say "compiled: >>>>" r "<<<<" m.r.code
call jOut "run without input"
call mCut 'T.IN', 0
call oRun r
if cnt == 3 then do
call jOut "run with 3 inputs"
call mAdd 'T.IN', "eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
m.t.inIx = 0
call oRun r
end
return
endProcedure tstCompRun
tstCompDataConst: procedure expose m.
call tst t, 'tstCompDataConst',
, "compile d, 8 lines: Lline one, $** asdf",
, "run without input",
, " Lline one, ",
, "line two.",
, "line threecontinued on 4",
, "line five fortsetzung",
, "line six fortsetzung"
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
call tstEnd t
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
call tst t, 'tstCompDataVars',
, "compile d, 4 lines: Lline one, $** asdf",
, "run without input",
, " Lline one, ",
, "lline zwei output",
, "lline 3 ",
, "variable v1 = valueV1 ${v1}= valueV1| "
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }| '
call tstEnd t
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
call tst t, 'tstCompShell',
, "compile s, 9 lines: $$ Lline one, $** asdf",
, "run without input",
, "Lline one,",
, "lline zwei output",
, "v1 = valueV1 ${v1}= valueV1|",
, "REXX JOUT L5 CONTINUED L6 CONTINUED L7",
, "L8 ONE",
, "L9 END"
call tstCompRun 's' ,
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call jOut rexx jout l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call jOut l8 one ' ,
, 'call jOut l9 end'
call tstEnd t
return
endProcedure tstCompDataVars
tstCompPrimary: procedure expose m.
call tst t, 'tstCompPrimary',
, "compile d, 11 lines: Strings $""$""""$""""""""$"""""" $'$'",
|| "'$''''$'''",
, "run without input",
, "Strings $""$""""$"" $'$''$'",
, "rexx 3*5 = 15",
, "data line three line four bis hier",
, "shell line five line six bis hier",
, "var get v1 value Eins, v1 value Eins ",
, "var isDef v1 1, v2 0 ",
, "jIn eof 1",
, "var read >1 0 rr undefined",
, "jIn eof 2",
, "var read >2 0 rr undefined",
, "run with 3 inputs",
, "Strings $""$""""$"" $'$''$'",
, "rexx 3*5 = 15",
, "data line three line four bis hier",
, "shell line five line six bis hier",
, "var get v1 value Eins, v1 value Eins "
call mAdd t.cmp,
, "var isDef v1 1, v2 0 ",
, "<jIn 1< eins zwei drei",
, "var read >1 1 rr eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "var read >2 1 rr zehn elf zwoelf?"
call envRemove 'v2'
call tstCompRun 'd' 3 ,
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx 3*5 = $( 3 * 5 $)',
, 'data $-[ line three',
, 'line four $] bis hier',
, 'shell $-{ $$ line five',
, '$$ line six $} bis hier',
, '$= v1 = value Eins $=rr=undefined',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v$( 1 * 1 + 0 $) }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr'
call tstEnd t
return
endProcedure tstCompPrimary
tstCompStmt: procedure expose m.
call tst t, 'tstCompStmt1',
, "compile s, 8 lines: $= v1 = value eins $= v2 £ 3*5*7 ",
, "run without input",
, "data v1 value eins v2 105",
, "eins",
, "zwei",
, "drei",
, "vier",
, "fuenf",
, "elf",
, "zwoelf dreiZ ",
, "vierZ ",
, "fuenfZ",
, "lang v1 value eins v2 945",
, "oRun ouput 1"
call envPut 'oRun', oRunner('call jOut "oRun ouput" (1*1)')
call envRemove 'v2'
call tstCompRun 's' ,
, '$= v1 = value eins $= v2 £ 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@{$$ zwei $$ drei ',
, ' $@{ $} $@{ $@{ $$vier $} $} $} $$fuenf',
, '$$elf $@[ zwoelf dreiZ ',
, ' $@[ $] $@[ $@[ vierZ $] $] $] $$fuenfZ',
, '$£ "lang v1" $v1 "v2" ${v2}*9',
, '$@run $oRun'
call tstEnd t
call tst t, 'tstCompStmt2',
, "compile s, 1 lines: $@for qq $$ loop qq $qq",
, "run without input",
, "jIn eof 1",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "loop qq eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "loop qq zehn elf zwoelf?",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "loop qq zwanzig 21 22 23 24 ... 29|",
, "jIn eof 4"
call tstCompRun 's' 3 ,
, '$@for qq $$ loop qq $qq'
call tstEnd t
return
endProcedure tstCompStmt
tstCompDataIO: procedure expose m.
call tst t, 'tstCompDataHereData',
, "compile d, 13 lines: herdata $<<stop ",
, "run without input",
, " herdata ",
, "heredata 1 $x",
, "heredata 2 $y",
, "nach heredata",
, " herdata [ ",
, "heredata 1 xValue",
, "heredata 2 yValueY",
, "nach heredata [",
, " herdata { ",
, "HEREDATA 1 xValue",
, "heredata 2 yValueY",
, "nach heredata {"
call tstCompRun 'd' ,
, ' herdata $<<stop ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata',
, ' herdata [ $<<[stop ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata [',
, ' herdata { $<<{st',
, 'call jOut heredata 1 $x',
, '$$heredata 2 $y',
, 'st $$ nach heredata {'
call tstEnd t
dsn = tstDsn('lib37', 'r')'(readInp)'
call mAdd mCut(abc, 0), 'readInp line 1', 'readInp line 2'
call writeDsn dsn '::f37', m.abc., ,1
call envPut 'dsn', dsn
call tst t, 'tstCompDataIO',
, "compile d, 4 lines: input 1 $<$dsn ::fb ",
, "run without input",
, " input 1 ",
, "readInp line 1 ",
, "readInp line 2 ",
, " nach dsn input und nochmals mit & ",
, "readInp line 1 ",
, "readInp line 2 ",
, " und schluiss."
call tstCompRun 'd' ,
, ' input 1 $<$dsn ::fb ',
, ' nach dsn input und nochmals mit & ' ,
, ' $<&dsn('dsn2jcl(dsn)') dd(xyz)',
, ' und schluiss.'
call tstEnd t
return
endProcedure tstCompDataIO
tstCompPipe: procedure expose m.
call tst t, 'tstCompPipe1',
, "compile s, 1 lines: call envPreSuf ""(1 "", "" 1)""",
, "run without input",
, "jIn eof 1",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "(1 eins zwei drei 1)",
, "<jIn 2< zehn elf zwoelf?",
, "(1 zehn elf zwoelf? 1)",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "(1 zwanzig 21 22 23 24 ... 29| 1)",
, "jIn eof 4"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"'
call tstEnd t
call tst t, 'tstCompPipe2',
, "compile s, 2 lines: call envPreSuf ""(1 "", "" 1)""",
, "run without input",
, "jIn eof 1",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "jIn eof 4",
, "[2 (1 eins zwei drei 1) 2]",
, "[2 (1 zehn elf zwoelf? 1) 2]",
, "[2 (1 zwanzig 21 22 23 24 ... 29| 1) 2]"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! call envPreSuf "[2 ", " 2]"'
call tstEnd t
call tst t, 'tstCompPipe3',
, "compile s, 3 lines: call envPreSuf ""(1 "", "" 1)""",
, "run without input",
, "jIn eof 1",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "jIn eof 4",
, "<3 [2 (1 eins zwei drei 1) 2] 3>",
, "<3 [2 (1 zehn elf zwoelf? 1) 2] 3>",
, "<3 [2 (1 zwanzig 21 22 23 24 ... 29| 1) 2] 3>"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! call envPreSuf "[2 ", " 2]"',
, ' $! call envPreSuf "<3 ", " 3>"'
call tstEnd t
call tst t, 'tstCompPipe4',
, "compile s, 7 lines: call envPreSuf ""(1 "", "" 1)""",
, "run without input",
, "jIn eof 1",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "jIn eof 4",
, "<3 [222 [221 [21 [20 (1 eins zwei drei 1) 20] 21] 221] 222",
|| "] 3>",
, "<3 [222 [221 [21 [20 (1 zehn elf zwoelf? 1) 20] 21] 221] 22",
|| "2] 3>",
, "<3 [222 [221 [21 [20 (1 zwanzig 21 22 23 24 ... 29| 1) 20]",
|| " 21] 221] 222] 3>"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! $@{ call envPreSuf "[20 ", " 20]"',
, ' $! call envPreSuf "[21 ", " 21]"',
, ' $! $@{ call envPreSuf "[221 ", " 221]"',
, ' $! call envPreSuf "[222 ", " 222]"',
, '$} $} ',
, ' $! call envPreSuf "<3 ", " 3>"'
call tstEnd t
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
call tst t, 'tstCompRedir',
, "compile s, 5 lines: $>#eins $@for vv $$<$vv> $; ",
, "run without input",
, "jIn eof 1",
, "output eins ",
, "output piped zwei ",
, "run with 3 inputs",
, "<jIn 1< eins zwei drei",
, "<jIn 2< zehn elf zwoelf?",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "jIn eof 4",
, "output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 2",
|| "1 22 23 24 ... 29|>",
, "output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?",
|| ">yz ab<zwanzig 21 22 23 24 ... 29|>yz"
dsn = tstDsn('libvb', 'r')'(redir1)'
call envPut 'dsn', dsn
call tstCompRun 's' 3 ,
, ' $>#eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-{$<#eins$}$; ',
, ' $@for ww $$b${ww}y ',
, ' $> $dsn ::v $! call envPreSuf "a", "z" $<# eins',
, '$;$$ output piped zwei $-{$<$dsn$} '
call tstEnd t
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
call tst t, 'tstCompCompShell',
, "compile s, 5 lines: $$compiling shell $; $= rrr = $-cmpShe",
|| "ll $<<aaa",
, "run without input",
, "compiling shell",
, "running einmal",
, "RUN 1 COMPILED einmal",
, "jIn eof 1",
, "running zweimal",
, "RUN 1 COMPILED zweimal",
, "jIn eof 2",
, "run with 3 inputs",
, "compiling shell",
, "running einmal",
, "RUN 1 COMPILED einmal",
, "<jIn 1< eins zwei drei",
, "compRun eins zwei dreieinmal"
call mAdd t'.CMP',
, "<jIn 2< zehn elf zwoelf?",
, "compRun zehn elf zwoelf?einmal",
, "<jIn 3< zwanzig 21 22 23 24 ... 29|",
, "compRun zwanzig 21 22 23 24 ... 29|einmal",
, "jIn eof 4",
, "running zweimal",
, "RUN 1 COMPILED zweimal",
, "jIn eof 5"
call tstCompRun 's' 3 ,
, "$$compiling shell $; $= rrr = $-cmpShell $<<aaa",
, "call jOut run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
call tst t, 'tstCompCompData',
, "compile s, 5 lines: $$compiling data $; $= rrr = $-cmpData",
|| " $<<aaa",
, "run without input",
, "compiling data",
, "running einmal",
, "call jOut run 1*1*1 compiled einmal",
, "running zweimal",
, "call jOut run 1*1*1 compiled zweimal",
, "run with 3 inputs",
, "compiling data",
, "running einmal",
, "call jOut run 1*1*1 compiled einmal",
, "running zweimal",
, "call jOut run 1*1*1 compiled zweimal"
call tstCompRun 's' 3 ,
, "$$compiling data $; $= rrr = $-cmpData $<<aaa",
, "call jOut run 1*1*1 compiled $cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
return
endProcedure tstCompComp
/* tstAAA ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
tstAll: procedure expose m.
call tstM
call tstMap
call tstMapVia
call tstScan
call tstO
call tstJsay
call tstJ
call tstCat
call tstEnv
call tstEnvCat
call tstEnvBar
call tstEnvVars
call tstCatDsn
call tstTotal
return
endProcedure tstAll
tstTstSay: procedure
call tst x, 'test eins', "test eins einzige testZeile"
call tstOut x, "test eins einzige testZeile"
call tstEnd x
call tst x, 'test zwei', "zwei 1. testZeile",
, "zwei 2. und letsdfazte testZeile"
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x
call tst y, 'test drei',
, "drei 1. testZeile",
, "drei 2. tEstZeile",
, "drei 3. testZeile test line drei ganz lang 1 ",
|| " ...line drei ganz lang 2 ",
|| " ...line drei ganz lang 3 .",
|| "..line drei ganz lang 4 und schluss."
call tstOut y, 'drei 1. testZeile'
call tstOut y, 'drei 2. testZeile'
call tstOut y, 'drei 3. testZeile',
'test line drei ganz lang 1 ',
' ...line drei ganz lang 2 ',
' ...line drei ganz lang 3 ',
' ...line drei ganz lang 4 und schluss.'
call tstEnd y
call tstTotal
endProcedure tstTstSay
tstM: procedure
call tst t, 'tstM',
, "symbol m.b LIT",
, "mDefIfNot 1 0 m.b 1",
, "mInc b 2 m.b 2",
, "symbol m.a LIT",
, "mAdd a A.2",
, "mAdd a A.3",
, "m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4",
, "m.c: 5: 1=c vor AddSt a 2=eins 3=zwei",
, " 4=drei 5=c nach addSt a 6=M.C.6"
call tstOut t, 'symbol m.b' symbol('m.b')
call tstOut t, 'mDefIfNot' mDefIfNot(b, 1) mDefIfNot(b, 2) 'm.b' m.b
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vor AddSt a'
call mAddSt c, a
call mAdd c, 'c nach addSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3
call tstOut t, ' 4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
m = mapNew('K')
ky = mapKeys(m)
say '***mapNew' m 'keys' ky
call tst t, 'tstMap',
, "map "m": zwei --> 2",
, "map "m": Zwei is not defined",
, "map stem "ky" 4",
, "map "m": eins --> 1",
, "map "m": zwei --> 2",
, "map "m": drei --> 3",
, "map "m": vier --> 4",
, "*** err: duplicate key in mAdd("m", eins, 1)",
, "map "m": zwei is not defined",
, "q 2 zwei drei",
, "map stem Q 2",
, "map Q: zwei --> 2Q",
, "map Q: drei --> 3Q",
, "map stem "m" 3",
, "map "m": eins --> 1",
, "map "m": zwei --> 2PUT",
, "map "m": vier --> 4PUT",
, "*** err: duplicate key in mAdd("m", zwei, 2ADDDUP)"
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zwei', 2q
call mapAdd q, 'drei', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstEnd t
return
endProcedure tstMap
tstMapVia: procedure expose m.
call tst t, 'tstMap',
, "map M: K --> A",
, "mapVia(m, K) A",
, "*** err: missing m.A at 3 in mapVia(M, K*)",
, "mapVia(m, K*) M.A",
, "mapVia(m, K*) valAt m.a",
, "mapVia(m, K*) valAt m.a",
, "*** err: missing m.A.aB at 5 in mapVia(M, K*aB)",
, "mapVia(m, K*aB) M.A.aB",
, "mapVia(m, K*aB) valAt m.A.aB",
, "*** err: missing m.valAt m.a at 4 in mapVia(M, K**)",
, "mapVia(m, K**) M.valAt m.a",
, "mapVia(m, K**) valAt m.valAt m.a",
, "mapVia(m, K**F) valAt m.valAt m.a.F"
drop m.a.
call mapReset m
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
m.a = 'valAt m.a'
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
u='A.aB'
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
u= m.a
m.u = 'valAt m.'u
m.u.f = 'valAt m.'u'.F'
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
call tstOut t, 'mapVia(m, K**F) ' mapVia(m, 'K**F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a':' key '-->' mapGet(a, key)
else
call tstOut t, 'map' a':' key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstJsay: procedure expose m.
call jIni
call jOut 'out eins'
call jOut 'out zwei jIn' jIn(vv) 'vv='vv
vv = 'value'
call jOut 'out drei jIn' jIn(vv) 'vv='vv 'Schluss'
return
endProcedure tstJsay
tstJ: procedure expose m.
call jIni
oldJin = m.j.jIn
oldJOut = m.j.jOut
m.j.jIn = t
m.j.jOut = t
b = jOpen(jBuf(), 'w')
call tst t, "tstJ",
, "out eins",
, "<jIn 1< tst in line 1 eins ,",
, "1 jIn() tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "2 jIn() tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "3 jIn() tst in line 3 drei |",
, "jIn eof 4",
, "jIn() 3 reads vv VV",
, "line buf line one",
, "line buf line two",
, "line buf line three",
, "line buf line four",
, "*** err: jWrite(" || b", buf line four) but not ope",
|| "ned w"
call jOut 'out eins'
do lx=1 by 1 while jIn(var)
call jOut lx 'jIn()' m.var
end
call jOut 'jIn()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, 'r'
do while (jRead(b, line))
call jOut 'line' m.line
end
call jWrite b, 'buf line four'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstCat: procedure expose m.
call catIni
call tst t, "tstCat",
, "catRead 1 line 1",
, "catRead 2 line 2",
, "catRead 3 line 3",
, "appRead 1 line 1",
, "appRead 2 line 2",
, "appRead 3 append 4",
, "appRead 4 append 5",
, "appRead 5 line 3"
i = cat('£', jBuf('line 1', 'line 2'), '£', jBuf('line 3'))
call jOpen i, 'r'
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen i, 'a'
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen i, 'r'
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstCatDsn: procedure expose m.
call catIni
call tst t, "tstCatDsn",
, "write read 0 last 10 vor anfang",
, "write read 1 last 80 links1 1 und rechts | .",
, "write read 2 last 80 liinks2 2 und rechts | .",
, "write read 5 last 80 links5 5 rechts5",
, "write read 99 last 80 links99 99 rechts",
, "write read 100 last 80 links100 100 rechts",
, "write read 101 last 80 links101 101 rechts",
, "write read 999 last 80 links999 999 rechts",
, "write read 1000 last 80 links1000 1000 rechts",
, "write read 1001 last 80 links1001 1001 rechts",
, "write read 2109 last 80 links2109 2109 rechts",
, "out > eins 1 ",
|| " ",
, "out > eins 2 schluss. ",
|| " ",
, "buf eins",
, "buf zwei",
, "buf drei",
, "out > zwei mit einer einzigen Zeile ",
|| " ",
, " links1 1 und rechts | . ",
|| " "
pds = tstDsn('lib', 'r')
call tstCatDsnWr pds, 0, ' links0', ' und rechts | . '
call tstCatDsnWr pds, 1, ' links1', ' und rechts | . '
call tstCatDsnWr pds, 2, 'liinks2', ' und rechts | . '
call tstCatDsnWr pds, 5, 'links5', 'rechts5'
call tstCatDsnWr pds, 99, 'links99', 'rechts'
call tstCatDsnWr pds, 100, 'links100', 'rechts'
call tstCatDsnWr pds, 101, 'links101', 'rechts'
call tstCatDsnWr pds, 999, 'links999', 'rechts'
call tstCatDsnWr pds, 1000, 'links1000', 'rechts'
call tstCatDsnWr pds, 1001, 'links1001', 'rechts'
call tstCatDsnWr pds, 2109, 'links2109', 'rechts'
pd2 = tstDsn('li2', 'r')
call envPush env('>', pd2'(eins) ::F')
call jOut 'out > eins 1'
call jOut 'out > eins 2 schluss.'
call envPop
call envPush env('>', pd2'(zwei) ::F')
call jOut 'out > zwei mit einer einzigen Zeile'
call envPop
b = jBuf("buf eins", "buf zwei", "buf drei")
call envPush env('<+', pd2'(eins) ::F', '+£', b,
,'+£', jBuf(), '+', pd2'(zwei)',
,'+', pds'(WR0)','', pds'(wr1)')
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstCatDsn
tstCatDsnWR: procedure expose m.
parse arg dsn, num, le, ri
io = catDsn(dsn'(wr'num') ::F')
call jOpen io, 'w'
do x = 1 to num
call jWrite io, le x ri
end
if num > 100 then
call catDsnReset io, dsn'(wr'num') ::F'
call jOpen io, 'r'
m.vv = 'vor anfang'
do x = 1 to num
if ^ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead'
if jRead(io, vv) then
call err x'+1 jRead'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstCatDsnRW
tstEnv: procedure expose m.
call envIni
c = jBuf()
call tst t, "tstEnv",
, "before envPush",
, "after envPop",
, "*** err: jWrite("c", write nach pop) but not op",
|| "ened w",
, "<jIn 1< tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "jIn eof 4",
, "before readWrite 2 c --> std",
, "before readWrite 1 b --> c",
, "b line eins",
, "b zwei |",
, "nach readWrite 1 b --> c",
, "add nach pop",
, "after push c only",
, "tst in line 1 eins ,",
, "tst in line 2 zwei ; "
call mAdd t'.CMP',
, "tst in line 3 drei |",
, "nach readWrite 2 c --> std",
, "*** err: jWrite("c", ) but not opened w"
call jOut 'before envPush'
b = jBuf("b line eins", "b zwei |")
call envPush env('<£', b, '>£', c)
call jOut 'before readWrite 1 b --> c'
call envReadWrite
call jOut 'nach readWrite 1 b --> c'
call envPop
call jOut 'after envPop'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call envPush env('>>£', c)
call jOut 'after push c only'
call envReadWrite
call envPop
call envPush env('<£', c)
call jOut 'before readWrite 2 c --> std'
call envReadWrite
call jOut 'nach readWrite 2 c --> std'
call envPop
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call tst t, "tstEnvCat",
, "c1 contents",
, "c1 line eins |",
, "before readWrite 1 b* --> c*",
, "b1 line eins|",
, "b2 line eins",
, "b2 zwei |",
, "after readWrite 1 b* --> c*",
, "c2 contents",
, "c2 line eins |"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call envPush env('<+£', b0, '<+£', b1, '<£', b2,
,'>>+£', c1, '<£', c2)
call jOut 'before readWrite 1 b* --> c*'
call envReadWrite
call jOut 'after readWrite 1 b* --> c*'
call envPop
call envPush env('<£', c1)
call jOut 'c1 contents'
call envReadWrite
call envPop
call envPush env('<£', c2)
call jOut 'c2 contents'
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstEnv
tstEnvBar: procedure expose m.
call tst t, 'tstEnvBar',
, "+0 vor envBarBegin",
, "<jIn 1< tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "jIn eof 4",
, "+7 nach envBarLast",
, "[7 +6 nach envBar 7]",
, "[7 +2 nach envBar 7]",
, "[7 +4 nach nested envBarLast 7]",
, "[7 (4 +3 nach nested envBarBegin 4) 7]",
, "[7 (4 (3 +1 nach envBarBegin 3) 4) 7]",
, "[7 (4 (3 tst in line 1 eins , 3) 4) 7]",
, "[7 (4 (3 tst in line 2 zwei ; 3) 4) 7]",
, "[7 (4 (3 tst in line 3 drei | 3) 4) 7]",
, "[7 (4 (3 +1 nach readWrite vor envBar 3) 4) 7]",
, "[7 (4 +3 nach preSuf vor nested envBarLast 4) 7]",
, "[7 +4 nach preSuf vor nested envBarEnd 7]"
call mAdd t.cmp,
, "[7 +5 nach nested envBarEnd vor envBar 7]",
, "[7 +6 nach readWrite vor envBarLast 7]",
, "+7 nach readWrite vor envBarEnd",
, "+8 nach envBarEnd"
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call envReadWrite
call jOut '+1 nach readWrite vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call envPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call envPreSuf '(4 ', ' 4)'
call jOut '+4 nach preSuf vor nested envBarEnd'
call envBarEnd
call jOut '+5 nach nested envBarEnd vor envBar'
call envBar
call jOut '+6 nach envBar'
call envReadWrite
call jOut '+6 nach readWrite vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call envPreSuf '[7 ', ' 7]'
call jOut '+7 nach readWrite vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call tstEnd t
return
endProcedure tstEnvBar
tstEnvVars: procedure expose m.
call tst t, "tstEnvVars",
, "put v1 value eins",
, "v1 hasKey 1 get value eins",
, "v2 hasKey 0",
, "via v1.fld via value",
, "one to theBur",
, "two to theBuf"
put1 = envPut('v1', 'value eins')
call tstOut t, 'put v1' put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1*FLD')
call envPush env('>#', 'theBuf')
call jOut 'one to theBur'
call jOut 'two to theBuf'
call envPop
call envPush env('<#', 'theBuf')
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstEnvVars
tstScan: procedure expose m.
call tst t, 'tstScan.1',
, "scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' ",
, "scan n tok 4: a034 key val ",
, "scan 1 tok 1: , key val ",
, "scan n tok 3: Und key val ",
, "scan v tok 1: key val ",
, "scan n tok 10: hr123sdfER key val ",
, "scan q tok 5: ""st1"" key val st1",
, "scan v tok 1: key val st1",
, "scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's",
, "scan v tok 1: key val str2'mit'apo's"
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
call tst t, 'tstScan.2',
, "scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' ",
, "scan n tok 4: a034 key val ",
, "scan 1 tok 1: , key val ",
, "scan n tok 3: Und key val ",
, "scan b tok 0: key val ",
, "scan n tok 10: hr123sdfER key val ",
, "scan s tok 5: ""st1"" key val st1",
, "scan b tok 0: key val st1",
, "scan s tok 19: 'str2''mit''apo''s' key val str2'mit'apo's",
, "scan b tok 0: key val str2'mit'apo's"
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
call tst t, 'tstScan.3',
, "scan src a034,'wie 789abc",
, "scan n tok 4: a034 key val ",
, "scan 1 tok 1: , key val ",
, "*** err: scanErr ending Apostroph(') missing",
, " e 1: last token scanPosition 'wie 789abc",
, " e 2: pos 6 in string a034,'wie 789abc",
, "scan 1 tok 1: ' key val ",
, "scan n tok 3: wie key val ",
, "scan 1 tok 1: key val ",
, "*** err: scanErr illegal number end",
, " e 1: last token 789 scanPosition abc",
, " e 2: pos 14 in string a034,'wie 789abc",
, "scan d tok 3: 789 key val ",
, "scan n tok 3: abc key val "
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
call tst t, 'jTestScan.4',
, "scan src litEinsefr 23 sdfER'str1'litZwei ""str2""""mit qu",
|| "o""s ",
, "scan l tok 7: litEins key val ",
, "scan n tok 3: efr key val ",
, "scan b tok 0: key val ",
, "scan d tok 2: 23 key val ",
, "scan b tok 0: key val ",
, "scan n tok 5: sdfER key val ",
, "scan a tok 6: 'str1' key val str1",
, "scan l tok 7: litZwei key val str1",
, "scan b tok 0: key val str1",
, "scan q tok 15: ""str2""""mit quo"" key val str2""mit quo",
, "scan n tok 1: s key val str2""mit quo",
, "scan b tok 0: key val str2""mit quo"
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
call tst t, 'jTestScan.5',
, "scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan b tok 0: key val ",
, "scan k tok 4: no= key aha val def",
, "scan 1 tok 1: ; key aha val def",
, "scan 1 tok 1: + key aha val def",
, "scan 1 tok 1: - key aha val def",
, "scan 1 tok 1: = key aha val def",
, "scan k tok 4: no= key f val def",
, "scan k tok 4: cdEf key ab val cdEf",
, "scan b tok 4: cdEf key ab val cdEf",
, "scan k tok 8: 'strIng' key eF val strIng",
, "scan b tok 8: 'strIng' key eF val strIng"
call tstScan1 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
call jTest t, 'jTestScanReader',
, "jOut: name erste",
, "jOut: space",
, "jOut: name Zeile",
, "jOut: space",
, "jOut: nextLine",
, "jOut: nextLine",
, "jOut: space",
, "jOut: name dritte",
, "jOut: space",
, "jOut: name Zeile",
, "jOut: space",
, "jOut: name schluss",
, "jOut: space"
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
call jOpen b, 'r'
call scanReader s, b
do while ^scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.m.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jTestEnd t
call jTest t, 'jTestScanReader mit spaceLn',
, "tstOut t,: name erste",
, "jOut: spaceLn",
, "jOut: name Zeile",
, "jOut: spaceLn",
, "jOut: name dritte",
, "jOut: spaceLn",
, "jOut: name Zeile",
, "jOut: spaceLn",
, "jOut: name schluss",
, "jOut: spaceLn"
call jOpen b, 'r'
call scanReader s, b
do forever
if scanName(s) then call jOut 'name' m.m.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jTestEnd t
return
endProcedure jTestScan
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg types, ln
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
do forever
x = scanType(s, types)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstO: procedure expose m.
call tst t, 'tstO',
, "class R with 2 methods",
, " print call tstOut T, 'Rprint' m a1",
, " say call tstOut T, 'Rsay ' m a2; return",
, "class S with 3 methods",
, " print call tstOut T, 'Sprint' m a1; return",
, " say call tstOut T, 'Rsay ' m a2; return",
, " quak call tstOut T, 'Squak ' m a3; return 'quak'a3",
, "O.CLAOBJ.R.1 class R",
, "O.CLAOBJ.S.1 class S",
, "oR.print call tstOut T, 'Rprint' m a1",
, "oS.print call tstOut T, 'Sprint' m a1; return",
, "oS.say call tstOut T, 'Rsay ' m a2; return",
, "Rsay O.CLAOBJ.R.1 arg oR say",
, "Rprint O.CLAOBJ.R.1 arg oR print",
, "Rsay O.CLAOBJ.S.1 arg oS say"
call mAdd t.cmp ,
, "Sprint O.CLAOBJ.S.1 arg oS print",
, "Squak O.CLAOBJ.S.1 arg oS quak",
, "quak: quakarg oS quak",
, "Rprint O.CLAOBJ.S.1 cast(os, R)",
, "Sprint O.CLAOBJ.S.1 cast(os, R), S)",
, "mutate oS R O.CLAOBJ.S.1",
, "Rprint O.CLAOBJ.S.1 mutate R",
, "oRun 7*3 21",
, "oRun 12*12 144"
oo = 'call tstOut' t','
cR = oNewClass('R')
call oClaAddMethods cR, "print", oo "'Rprint' m a1",
, "say", oo "'Rsay ' m a2; return"
cS = oNewClass('S', "R")
call oClaAddMethods cS, "print", oo "'Sprint' m a1; return",
, "quak", oo "'Squak ' m a3; return 'quak'a3"
cc = 'R S'
do cx=1 to words(cc)
cla = word(cc, cx)
call tstOut t, 'class' cla 'with' m.o.claMet.cla.0 'methods'
do mx=1 to m.o.claMet.cla.0
met = m.o.claMet.cla.mx
call tstOut t, ' ' met mapGet('O.CLAMET.'cla, met)
end
end
oR = oNew(cR)
oS = oNew(cS)
call tstOut t, oR 'class' oGetClass(oR)
call tstOut t, oS 'class' oGetClass(oS)
call tstOut t, 'oR.print' oObjMethod(oR, 'print')
call tstOut t, 'oS.print' oObjMethod(oS, 'print')
call tstOut t, 'oS.say' oObjMethod(oS, 'say')
call tstClassRsay oR, 'arg oR say'
call tstClassRprint oR, 'arg oR print'
call tstClassRsay oS, 'arg oS say'
call tstClassRprint oS, 'arg oS print'
call tstOut t, 'quak:' tstClassSquak(oS, 'arg oS quak')
q1 = oCast(oS, 'R')
call tstClassRprint q1, 'cast(os, R)'
q2 = oCast(q1, 'S')
call tstClassRprint q2, 'cast(os, R), S)'
call tstOut t, 'mutate oS R' oMutate(oS, 'R')
call tstClassRprint oS, 'mutate R'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
call oRunnerReset rr, 'return 12 * 12'
call tstOut t, 'oRun 12*12' oRun(rr)
call tstEnd t
return
endProcedure tstClass
tstClassRprint: procedure expose m.
parse arg m, a1
interpret oObjMethod(m, 'print')
return
endProcedure tstClassRprint
tstClassRsay: procedure expose m.
parse arg m, a2
interpret oObjMethod(m, 'say')
endProcedure tstClassRsay
tstClassSquak: procedure expose m.
parse arg m, a3
interpret oObjMethod(m, 'quak')
endProcedure tstClassSquak
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call scanReadIni
cc = oNewClass('Compiler')
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.scan = scanRead(src)
return compReset(nn, src)
endProcedure comp
compReset: procedure expose m.
parse arg m, src
call scanReadReset m.m.scan, src, , ,'$*'
m.m.chDol = '$'
m.m.chSpa = ' '
m.m.chNotWord = '${}=£:' || m.m.chSpa
m.m.stack = 0
return m
endProceduere compReset
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp ^== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, type
if type == 's' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = compShell(m)
end
else if type == 'd' then do
what = "data";
expec = "sExpression or block";
src = compData(m, 0)
end
else do
call err "bad type " type
end
if ^ scanAtEnd(m.m.scan) then
call scanErr m.m.scan, expec "expected: compile" what ,
" stopped before end of input"
r = oRunner(src)
return r
endProcedure compile
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
exprs = compPushStem(m)
do forever
aftEol = 0
do forever
text = "";
do forever
if scanVerify(s, m.m.chDol, 'm') then
text = text || m.s.tok
if ^ compComment(m) then
leave
end
nd = compExpr(m, 'd')
befEol = scanReadNL(s)
if nd <> '' | (aftEol & befEol) ,
| verify(text, m.m.chSpa) > 0 then do
if text ^== '' then
text = quote(text)
if text ^== '' & nd ^= '' then
text = text '|| '
call mAdd exprs, 'e' compNull2EE(text || nd)
end
if ^ befEol then
leave
aftEol = 1
end
one = compStmt(m)
if one == '' then
one = compRedirIO(m, 0)
if one == '' then
leave
call mAdd exprs, 's' one
end
if m.exprs.0 < 1 then do
if makeExpr then
res = '""'
else
res = ';'
end
else do
do x=1 to m.exprs.0 while left(m.exprs.x, 1) = 'e'
end
res = ''
if makeExpr & x > m.exprs.0 then do
res = substr(m.exprs.1, 3)
do x=2 to m.exprs.0
res = res substr(m.exprs.x, 3)
end
end
else do
do x=1 to m.exprs.0
if left(m.exprs.x, 1) = 'e' then
res = res 'call jOut'
res = res substr(m.exprs.x, 3)';'
end
if makeExpr then
res = "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
end
call compPop m, exprs
return res
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one ^== '' then
res = res one
if ^ scanLit(m.m.scan, '$;') then
return strip(res)
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type
res = ''
if type == 'w' then
charsNot = m.m.chNotWord
else
charsNot = m.m.chDol
s = m.m.scan
if pos(type, 'sw') > 0 then
call compSpComment m
do forever
txt = ''
do forever
if scanVerify(s, charsNot, 'm') then
txt = txt || m.s.tok
if ^ compComment(m) then
leave
end
pr = compPrimary(m)
if pr = '' & pos(type, 'sw') > 0 then
txt = strip(txt, 't')
if txt ^== '' then
res = res '||' quote(txt)
if pr = '' then do
if pos(type, 'sw') > 0 then
call compSpComment m
if res == '' then
return ''
return substr(res, 5)
end
res = res '||' pr
end
return ''
endProcedure compExpr
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp ^== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m
s = m.m.scan
if ^ scanLit(s, '$') then
return ''
if scanString(s) then
return m.s.tok
if scanLit(s, '(') then do
one = compCheckNN(m, compLang(m, 0), 'rexx expexted after $(')
if ^ scanLit(s, '$)') then
call scanErr s, 'closing $) missing after $(...'
return '('one')'
end
if scanLit(s, '-[') then do
res = compData(m, 1)
if ^scanLit(s, '$]') then
call scanErr s, 'closing $] missing after $-[ data'
return res
end
if scanLit(s, '-{') then do
res = compShell(m)
if ^scanLit(s, '$}') then
call scanErr s, 'closing $} missing after $-{ shell'
return "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
if scanLit(s, '-cmpShell', '-cmpData') then do
return 'compile(comp(envRead2Buf()),' ,
'"'substr('ds', 1+(m.s.tok == '-cmpShell'), 1)'")'
end
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = 'envIsDefined'
else if scanLit(s, '>') then
f = 'envRead'
else
f = 'envGet'
nm = compExpr(m, 'w')
if ^scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'('nm')'
end
if scanName(s) then
return 'envGet('quote(m.s.tok)')'
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 ^== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast ^== '' then do
if ^ scanLit(s, '$!') then
leave
call compSpNlComment m
end
one = compStmts(m)
if one == '' then do
if stmtLast ^== '' then
call scanErr s, 'stmts expected afte $!'
if ios == '' then
return ''
leave
end
if stmtLast ^== '' then
stmts = stmts 'call envBar;' stmtLast
stmtLast = one
end
end
if stmts ^== '' then
stmtLast = insert('Begin', stmts, pos('envBar;', stmts)+5) ,
'call envBarLast;' stmtLast 'call envBarEnd;'
if ios ^== '' then do
if stmtLast == '' then
stmtLast = 'call envReadWrite;'
stmtLast = 'call envPush env('substr(ios, 3)');' stmtLast ,
'call envPop;'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
if ^ scanLit(s, '$&', '$<<', '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
call scanVerify s, '+-£#[{'
opt = opt || m.s.tok
/* ???? call compSpComment m */
if left(opt, 2) ^== '<<' then do
if verify(opt, '[{', 'm') > 0 ,
| (left(opt, 1) == '&' & pos('£', opt) > 0) then
call scanErr s, 'inconsistent io redirection option' opt
ex = compCheckNN(m, compExpr(m, 's'),
, 'expression expected after $'opt)
end
else do
if verify(opt, '-£#', 'm') > 0 then
call scanErr s, 'inconsistent io redirection option' opt
if ^ scanName(s) then
call scanErr s, 'stopper expected in heredata after $'opt
stopper = m.s.tok
call scanVerify s, m.m.chSpa
if ^ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after $'opt||stopper
buf = jOpen(jBuf(), 'w')
do while ^ scanLit(s, stopper)
call jWrite buf, m.s.src
if ^ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after $'opt||stopper
end
call jClose buf
ex = quote(buf)
if verify(opt, '[{', 'm') > 0 then do
if pos('[', opt) > 0 then
ex = "compile(comp("ex"), 'd')"
else
ex = "compile(comp("ex"), 's')"
if makeExpr then
return "'<£', envRun("ex")"
else
return "call oRun" ex";"
end
opt = '<£'
end
if makeExpr then
return "'"opt"'," ex
else if left(opt, 1) = '>' then
call scanErr s, 'cannot write ioRedir $'opt
else
return "call envReadWrite '"opt"'," ex
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
res = ''
do forever
one = compStmt(m)
if one == '' then
one = compLang(m, 1)
if one == '' then
return res
res = res strip(one)
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = compCheckNN(m, compExpr(m, 'w'), "variable name")
if scanLit(s, "=") then
vl = compExpr(m, 's')
else if scanLit(s, "£") then
vl = compCheckNN(m, compLang(m, 0),
, 'java expression after $= .. £')
else
call scanErr s, '= or £ expected after $= name'
return 'call envPut' nm',' vl';'
end
else if scanLit(s, '$@{') then do
call compSpNlComment m
one = compShell(m)
if ^ scanLit(s, "$}") then
call scanErr s, "closing $} missing for $@{ shell"
return "do;" one "end;"
end
else if scanLit(s, '$@[') then do
call compSpNlComment m
one = compData(m, 0)
if ^ scanLit(s, "$]") then
call scanErr s, "closing $] missing for $@] data"
return "do;" one "end;"
end
else if scanLit(s, '$$') then do
return 'call jOut' compExpr(m, 's')';'
end
else if scanLit(s, '$£') then do
return 'call jOut' compCheckNN(m, compLang(m, 0),
, 'language expression after $£')';'
end
else if scanLit(s, '$@for') then do
v = compCheckNN(m, compExpr(m, 'w') ,
, "variable name after $@for")
call compSpNlComment m
return 'do while envRead('v');',
compCheckNN(m, compStmt(m),
, "statement after $@for variable") 'end;'
end
else if scanLit(s, '$@run') then do
return 'call oRun' compCheckNN(m, compExpr(m, 's'),
, 'expression after $@run') ';'
end
return ''
endProcedure compStmt
/*--- compile a language clause
multi=0 a single line for a rexx expression
multi=1 mulitple lines for rexx statements
(with rexx line contiunation) -----------------------*/
compLang: procedure expose m.
parse arg m, multi
s = m.m.scan
res = ''
do forever
if scanVerify(s, m.m.chDol, 'm') then do
res = res || m.s.tok
end
else do
one = compPrimary(m)
if one ^== '' then
res = res || one
else if compComment(m) then
res = res || ' '
else if ^multi then
return res
else if ^ scanReadNl(s) then do
if res == '' then
return res
else
return strip(res)';'
end
else do
res = strip(res)
if right(res, 1) = ',' then
res = strip(left(res, length(res)-1))
else
res = res';'
end
end
end
endProcedure compLang
/*--- convert stmts to an expression yielding the output ------------*/
compStmts2ExprBuf: procedure expose m.
parse arg stmts
rr = oRunner(stmts)
return "envRun('"rr"')"
endProcedure compStmts2ExprBuf
/*--- convert '' to an empty expression ------------------------------*/
compNull2EE: procedure
parse arg e
if e = '' then
e return '""'
return e
endProcedure compNull2EE
/*--- if va == '' then issue an error with msg -----------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if ^ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return 0
return 1
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
found = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
found = 1
else if compComment(m) then
found = 1
else
return found
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- return stems ---------------------------------------------------*/
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
tst: procedure expose m.
parse arg m, nm
if m.tst.ini <> 1 then
call tstIni
m.m.name = nm
m.tst.act = m
m.tst.tests = m.tst.tests+1
call oMutate m, 'Tst'
ox = 1
m.m.cmp.ox = left('****** start tst' nm '', 79, '*')
do ax=3 to arg()
ox = ox + 1
m.m.cmp.ox = arg(ax)
end
m.m.cmp.0 = ox
m.m.in.0 = 0
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
call mAdd m'.IN', 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei |'
call oMutate m, 'Tst'
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
call envPush env( '<-£', m, '>-£', m)
call tstOut m, m.m.cmp.1
return 'TST.'m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt
m.tst.act = ''
call envPop
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
if m.m.out.0 ^= m.m.cmp.0 then do
call tstErr m, 'old' m.m.cmp.0 'lines ^= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.m.cmp.0)
say 'old - ' m.m.cmp.nx
end
end
if m.m.err > 0 then do
say 'new lines:' (m.m.out.0 - 1)
len = 60
do nx=2 to m.m.out.0
str = quote(m.m.out.nx, '"')
pr = ' , '
do while length(str) > len
l=len
if substr(str, l-1, 1) = '"' then
if posCount('"', left(str, l-1)) // 2 = 0 then
l = l-1
say pr left(str, l-1)'",'
str = '"'substr(str, l)
pr = ' ||'
end
say pr str || left(',', nx < m.m.out.0)
end
end
say left('******' m.m.name 'end with' m.m.err 'errors ', 79,
, '*')
return
endProcedure tstEnd
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'jOut:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
call mAdd m'.OUT', arg
nx = m.m.out.0
if nx > m.m.cmp.0 then do
if nx = m.m.cmp.0+1 then
call tstErr m, 'more new Lines' nx
end
else if m.m.cmp.nx ^== arg then do
call tstErr m, 'next line old' nx '^^^ new overnext'
say m.m.cmp.nx
end
say arg
return
endProcedure tstOut
tstRead: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
call tstOut m, '<jIn' ix'<' m.arg
return 1
end
call tstOut m, 'jIn eof' ix
return 0
endProcedure tstRead
tstDsn: procedure
parse arg suf, opt
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' & sysDsn("'"dsn"'") ^== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
return dsn
endProcedure tstDsn
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '******'
say '******'
say '******' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '******'
say '******'
if m.tst.err ^== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '*** error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt, ggStem
if m.tst.act == '' then
call err ggTxt, ggStem, '*'
call tstOut m.tst.act, '*** err:' ggTxt
if ggStem ^== '' then
do x=1 to m.ggStem.0
call tstOut m.tst.act, ' e' x':' m.ggStem.x
end
return
endSubroutine tstErrHandler
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini == 1 then
return
m.tst.ini = 1
call envIni
m.tst.err = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
call oClaAddMethods oNewClass("Tst"),
, "jRead", "return tstRead(m, var)",
, "jWrite", "call tstOut m, line"
call errReset 'h', 'call tstErrHandler ggTxt, ggStem'
return
endProcedure tstIni
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
/* copy tst end **************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
nn = oNew("Env")
m.nn.doClose.0 = 0
call envReset nn
do ax=1 by 2 to arg()-1
call envAddIo nn, arg(ax), arg(ax+1)
end
return nn
endProcedure env
envReset: procedure expose m.
parse arg m
call envClose m
m.m.in = ''
m.m.out = ''
m.m.doClose.0 = 0
m.m.lastCat = ''
do ax=2 by 2 to arg()-1
call envAddIo m, arg(ax), arg(ax+1)
end
return m
endProcedure envReset
envClose: procedure expose m.
parse arg m
do cx=1 to m.m.doClose.0
call jClose m.m.doClose.cx
end
m.m.doClose.0 = 0
return m
endProcedure envClose
envAddIO: procedure expose m.
parse arg m, opt, spec
contX = pos("+", opt)
if contX > 0 then do
opt = left(opt, contX-1)substr(opt,contX+1)
contX = 1
if m.m.lastCat == '' then
m.m.lastCat = cat()
end
if m.m.lastCat ^== '' then
call catAdd m.m.lastCat, opt, spec
else
oc = catMake(opt, spec)
if contX then
return
if m.m.lastCat ^== '' then do
oc = m.m.lastCat
m.m.lastCat = ''
opt = left(m.oc.opts.1, 1)
end
o1 = left(opt, 1)
if pos(o1, 'r<') > 0 then do
if m.m.in ^== '' then
call err 'envAddIo('opt',' spec') duplicate stdIn'
m.m.in = oc
end
else if pos(o1, 'wa>') > 0 then do
if m.m.out ^== '' then
call err 'envAddIo('opt',' spec') duplicate stdOut'
m.m.out = oc
end
if pos('-', opt) < 1 then do
call jOpen oc, catOpt(opt)
call mAdd m'.DOCLOSE', oc
end
return m
endProcedure envAddIO
envLink: procedure expose m.
parse arg m, old
if m.m.lastCat ^== '' then
call err 'envLink with open cat'
if m.m.in == '' then
m.m.in = m.j.jIn
if m.m.out == '' then
m.m.out = m.j.jOut
return m
endProcedure envLink
envReadWrite: procedure expose m.
parse arg opt, rdr
if opt ^== '' then
call envPush env(opt, rdr)
do while jIn(v)
call jOut m.v
end
if opt ^== '' then
call envPop
return
endProcedure envReadWrite
envRead2Buf: procedure expose m.
b = jBuf()
call envPush env('>£', b)
call envReadWrite
x = envPop()
return b
endProcedure envRead2Buf
envPreSuf: procedure expose m.
parse arg le, ri
do while jIn(v)
call jOut le || m.v || ri
end
return
endProcedure envPreSuf
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envRead: procedure expose m.
parse arg na
return jIn(env.vars.na)
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na)
envPut: procedure expose m.
parse arg na, va
return mapPut(env.vars, na, va)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
envIni: procedure expose m.
if m.env.ini == 1 then
return
m.env.ini = 1
call catIni
call oClaAddMethods oNewClass("Env", "JRW"),
, "jOpen", "call err 'envOpen('m', 'arg')'",
, "jReset", "return envReset(m, arg, arg(3), arg(4), arg(5))",
, "jClose", "call envClose m"
m.env.0 = 1
call mapReset env.vars
ex = env()
m.env.1 = ex
m.ex.in = m.j.jIn
m.ex.out = m.j.jOut
return
endProcedure
envPush: procedure expose m.
parse arg e
ex = m.env.0
call envLink e, m.env.ex
ex = ex + 1
m.env.0 = ex
m.env.ex = e
m.j.jIn = m.e.in
m.j.jOut = m.e.out
return e
endProcedure envPush
envPop: procedure expose m.
ox = m.env.0
if ox <= 1 then
call err 'envPop on empty stack' ox
call envClose m.env.ox
ex = ox - 1
m.env.0 = ex
e = m.env.ex
m.j.jIn = m.e.in
m.j.jOut = m.e.out
return m.env.ox
endProcedure envPop
envBarBegin: procedure expose m.
call envPush env('>£', jBuf())
return
endProcedure envBarBegin
envBar: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.oldEnv.out, '>£', jBuf())
return
endProcedure envBar
envBarLast: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.oldEnv.out)
return
endProcedure envBarLast
envBarEnd: procedure expose m.
oldEnv = envPop()
return
endProcedure envBarEnd
/*--- return the output buffer of oRunner m --------------------------*/
envRun: procedure expose m.
parse arg m
b = jBuf()
call envPush env('>£', b)
call oRun m
x = envPop()
return b
endProcedure envRun
/* copy env end *******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
catOpt: procedure
parse arg opt, keep
if abbrev(opt, '<') then
o = 'r'substr(opt, 2)
else if abbrev(opt, '>>') then
o = 'a'substr(opt, 3)
else if abbrev(opt, '>') then
o = 'w'substr(opt, 2)
else if pos(left(opt, 1), 'rwa') > 0 then
o = opt
else
o = '?'opt
if keep ^== 1 then
o = translate(o, ' ', '£#')
return space(o, 0)
endProcedure catOpt
catMake: procedure expose m.
parse arg opt, spec
o = catOpt(opt, 1)
if pos('£', o) > 0 then
return spec
else if pos('#', o) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, '£', '#'), envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', o) > 0 then
return catDsn('&'spec)
else
return catDsn(spec)
call err 'catMake implement' opt
if defDsn == '' then do
o = left(o, length(o)-1)
end
else if defDsn == '' then do
rw = catDsn(spec)
end
else do
rw = jReset(defDsn, spec)
end
if pos('-', o) < 1 then
call jOpen rw, o
return rw
endProcedure catMake
cat: procedure expose m.
m = oNew('Cat')
m.m.catIx = -9
call catReset m
do ax=1 by 2 to arg()
call catAdd m, arg(ax), arg(ax+1)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
call jClose m
m.m.opts.0 = 0
m.m.RWs.0 = 0
m.m.catIx = -9
do ax=2 to arg()
call catAdd m, arg(ax), arg(ax+1)
end
return m
endProcedure catReset
catAdd: procedure expose m.
parse arg m
if m.m.catIx ^== -9 then
call err 'catAdd('m',' arg(2)',' arg(3)') but opened,',
'catIx='m.m.catIx
bx = m.m.RWs.0
do ax=2 by 2 to arg()
bx=bx+1
m.m.opts.bx = catOpt(arg(ax))
m.m.RWs.bx = catMake(arg(ax), arg(ax+1))
end
m.m.RWs.0 = bx
m.m.opts.0 = bx
return
endProcedure catAdd
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
xx = max(1, m.m.catIx)
if xx <= m.m.RWs.0 & pos('-', m.m.opts.xx) < 1 then
call jClose m.m.catCur
m.m.catIx = -9
call oMutate m, 'Cat'
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
call jClose m
if oo = 'r' then do
m.m.catIx = 0
m.m.catCur = catNextRdr(m)
call oMutate m, 'CatRead'
end
else if oo == 'w' | oo == 'a' then do
if m.m.RWs.0 < 1 then
call err 'catOpen('m',' oo') but no writer'
m.m.catIx = -7
m.m.catCur = m.m.RWs.1
if pos('-', m.m.opts.1) < 1 then do
aa = m.m.opts.1
if pos(left(aa, 1), 'wa') < 1 then
aa = overlay(oo, aa)
call jOpen m.m.catCur, aa
end
call oMutate m, 'CatWrite'
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 & pos('-', m.m.opts.cx) < 1 then
call jClose m.m.catCur
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
oo = overlay('r', m.m.opts.cx)
if pos('-', oo) < 1 then
call jOpen m.m.RWs.cx, oo
return m.m.RWs.cx
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catCur ^== ''
if jRead(m.m.catCur, var) then
return 1
m.m.catCur = catNextRdr(m)
end
return 0
endProcedure catRead
catDsn: procedure expose m.
parse arg spec
m = oNew('CatDsn')
m.m.readIx = 'c'
ix = mInc('CAT.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'CAT.BUF'ix
call catDsnReset m, spec
return m
endProcedure catDsn
catDsnReset: procedure expose m.
parse arg m, sp
call jClose m
if symbol('m.m.defDD') ^== 'VAR' then
m.m.defDD = 'CDD' mInc('CAT.DEFDD')
m.m.spec = sp
return m
endProcedure catDsnReset
catDsnOpen: procedure expose m.
parse arg m, opt
call jClose m
buf = m.m.buf
if opt == 'r' then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
call readDDBegin word(aa, 1)
call oMutate m, 'CatDsnRead'
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == 'w' then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else
call err 'catDsnOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call oMutate m, 'CatDsnWrite'
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure catDsnOpen
catDsnClose:
parse arg m
buf = m.m.buf
if m.m.readIx ^== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure catDsnClose
catDsnRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if ^ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure catDsnRead
catDsnWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure catDsnWrite
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
m.cat.buf = 0
call jIni
call oClaAddMethods oNewClass("Cat", "JRW"),
, "jOpen", "return catOpen(m, arg)",
, "jReset", "return catReset(m, arg)",
, "jClose", "call catClose m"
call oClaAddMethods oNewClass("CatRead", "Cat"),
, "jRead", "return catRead(m, var)"
call oClaAddMethods oNewClass("CatWrite", "Cat"),
, "jWrite", "call jWrite m.m.catCur, line; return"
call oClaAddMethods oNewClass("CatDsn", "JRW"),
, "jOpen", "return catDsnOpen(m, arg)",
, "jReset", "return catDsnReset(m, arg)",
, "jClose", "call catDsnClose m"
call oClaAddMethods oNewClass("CatDsnRead", "CatDsn"),
, "jRead", "return catDsnRead(m, var)"
call oClaAddMethods oNewClass("CatDsnWrite", "CatDsn"),
, "jWrite", "call catDsnWrite m, line"
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
/**********************************************************************
adr*: address an environment
***********************************************************************/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', ds) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
interpret oObjMethod(m, 'jRead')
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
interpret oObjMethod(m, 'jWrite')
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret oObjMethod(m, 'jReset')
call oMutate m, 'JRW'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret oObjMethod(m, 'jOpen')
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret oObjMethod(m, 'jClose')
return m
endProcedure jClose
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
call oIni
call oClaAddMethods oNewClass("JRW"),
, "jRead", "call err 'jRead('m',' var') but not opened r'",
, "jWrite", "call err 'jWrite('m',' line') but not opened w'"
call oClaAddMethods oNewClass("Jin", "JRW"),
, "jRead", "drop m.arg; return 0"
m.j.jIn = oNew("Jin")
call oClaAddMethods oNewClass("Jout", "JRW"),
, "jWrite", "say 'jOut:' line"
m.j.jOut = oNew("Jout")
call oClaAddMethods oNewClass("Jbuf", "JRW"),
, "jOpen", "return jBufOpen(m, arg)",
, "jReset", "return jBufReset(m, arg)",
, "jClose", "call oMutate m, 'Jbuf'"
call oClaAddMethods oNewClass("JbufRead", "Jbuf"),
, "jRead", "return mNext(m'.BUF', m'.READIX', var)"
call oClaAddMethods oNewClass("JbufWrite", "Jbuf"),
, "jWrite", "call mAdd m'.BUF', line"
return
endProcedure jInit
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
jBuf: procedure expose m.
m = oNew('Jbuf')
call jBufReset m
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
call jClose m
if opt == 'r' then do
m.m.readIx = 0
return oMutate(m, "JbufRead")
return m
end
if opt == 'w' then
m.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
return oMutate(m, "JbufWrite")
endProcedure jBufOpen
/* copy j end *********************************************************/
/* copy o begin *******************************************************/
oClaMethod: procedure expose m.
parse arg cl, me
if symbol('m.o.claMet.cl.me') = 'VAR' then
return m.o.claMet.cl.me
else
call err 'no method' me 'in class' cl
endProcedure oClaMethod
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
if pos(left(name, 1), '0123456789') > 0 | ^datatype(name, 'a') then
call err 'bad class name' name
if mapHasKey(o.claNames, name) then
call err 'duplicate class' name
call mapAdd o.claNames, name
m.o.claObj.name.0 = 0
call mapReset 'O.CLAMET.'name, '='
do sx=1 to words(super)
sup = word(super, sx)
if ^mapHasKey(o.claNames, sup) then
call err 'superclass' sup 'is not initialized'
suMe = 'O.CLAMET.'sup
do x=1 to m.suMe.0
me = m.suMe.x
call mapPut 'O.CLAMET.'name, me, mapGet(suMe, me)
end
end
return name
endProcedure oNewClass
oClaAddMethods: procedure expose m.
parse arg cla
me = 'O.CLAMET.'cla
do ax=2 by 2 to arg()
call mapPut me, arg(ax), arg(ax+1)
end
return
endProcedure oClaAddMethods
oNew: procedure expose m.
parse arg cla
if symbol('M.O.CLANAMES.cla') ^== 'VAR' then
call err 'class' cla 'is not initialized'
nn = 'O.CLAOBJ.'cla'.'mInc('O.CLAOBJ.'cla'.0')
if symbol('m.o.obj2cla.nn') == 'VAR' then
call err 'oNew already defined:' nn
m.o.obj2cla.nn = cla
return nn
endProcedure oNew
oGetClass: procedure expose m.
parse arg obj
if symbol('m.o.obj2cla.obj') = 'VAR' then
return m.o.obj2cla.obj
else
call err 'no class found for object' obj
endProcedure oGetClass
oMutate: procedure expose m.
parse arg obj, cla
if symbol('M.O.CLANAMES.cla') ^== 'VAR' then
call err 'class' cla 'is not initialized'
m.o.obj2cla.obj = cla
return obj
endProcedure oMutate
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 mapReset o.claNames, '='
call oClaAddMethods oNewClass('ORunner'), 'oRun', 'call oRun m'
return
endProcedure oIni
/* copy o end *********************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(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, m.m.scanName1, namePlus, m.m.scanComment
call scanIni
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.read = ''
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.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, lit
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, qu
m.m.tok = ''
if qu = '' then do
qu = substr(m.m.src, m.m.pos, 1)
if pos(qu, "'""") < 1 then
return 0
end
else do
if substr(m.m.src, m.m.pos, 1) ^== qu then
return 0
end
bx = m.m.pos
ax = bx + 1
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.scan.m.pos
if pos(substr(m.scan.m.src, ox, 1) , '+-') < 1 then
return 0
m.scan.m.pos = ox + 1
if | scanNat(m) then do
m.scan.m.pos = ox
return 0
end
m.tok =substr(m.scan.m.src, ox, 1)|| m.tok
return 1
endProcedure scanInt
/*--- 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
scanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.scan.type.src = opt
m.scan.type.pos = cx
call scanString 'SCAN.TYPE'
a2 = m.scan.type.val
cx = m.scan.type.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'n' then
res = scanName(s)
else if f == 'q' then
res = scanString(s, '"')
else if f == 's' then
res = scanString(s)
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
else if pos(f, '123456789') > 0 then
res = scanChar(s, f)
else
call err 'bad scanType' f
if res then
return f
end
return ''
endProcedure scanType
scanAtEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
if m.m.read ^== '' then
interpret oObjMethod(m, 'scanAtEnd')
return 1
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, scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanInfo:
parse arg m, st
x = m.st.0 + 1
m.st.0 = x
m.st.x = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.read ^== '' then
interpret oObjMethod(m, 'scanInfo')
x = x + 1
m.st.x = 'pos' m.m.Pos 'in string' strip(m.m.src, 't')
m.st.0 = x
return st
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1 then
call scanIni
call jIni
call oClaAddMethods oNewClass('ScanRead'),
, 'scanReadNl', 'return scanReadNlImpl(m, unCond)',
, 'scanAtEnd', 'return scanReadAtEnd(m)',
, 'scanSpaceNl', 'scanReadSpaceNl(m)',
, 'scanInfo', 'return scanReadInfo(m, st)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanReadReset(oNew('ScanRead'), rdr , n1, np, co)
scanReadReset: procedure expose m.
parse arg m, rdr, n1, np, co
call scanReset m, n1, np, co
m.m.atEnd = 0
m.m.lineX = 0
m.m.read = rdr
call jOpen rdr, 'r'
call scanReadNl m, 1
return m
endProcedure scanReader
scanReadNl: procedure expose m.
parse arg m, unCond
interpret oObjMethod(m, 'scanReadNl')
endProcedure scanReadNl
/*--- return true/false whether we are at the end of line / reader ---*/
scanReadAtEnd: procedure expose m.
parse arg m
return m.m.atEnd
endProcedure scanReadAtEnd
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond ^== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = ^ jRead(m.m.read, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return ^ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if ^ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadInfo: procedure expose m.
parse arg m, st
if m.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.m.pos 'in'
call mAdd st, qq 'line' m.m.lineX':' strip(m.m.src, 't')
return st
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy map begin*******************************************************
map
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset( , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if m.map.ini ^== 1 then
call mapIni
if a == '' | symbol('m.map.a2.a.mix') ^== 'VAR' then do
call mAdd 'MAP.MAP', a
mx = m.map.map.0
if a == '' then
a = 'MAP.K2V.'mx
m.map.A2.a.mix = mx
end
else do
mx = m.map.A2.a.mix
call mapClear a
end
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.STEM.'mx
else
st = ''
m.map.a2.a.stem = st
if st ^== '' then
m.st.0 = 0
return a
endProcedure
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
mapKeys: procedure expose m.
parse arg a
if m.map.a2.a.stem == '' then
call err 'mapKeys('a') with no keys'
return m.map.a2.a.stem
endProcedure mapKeys
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.ky = val
if m.map.a2.a.stem ^== '' then
return mAdd(m.map.a2.a.stem, ky)
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg a, ky, val
if m.map.a2.a.stem ^== '' then
if symbol('m.a.ky') ^== 'VAR' then
call mAdd m.map.a2.a.stem, ky
m.a.ky = val
return val
endProcedure mapPut
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
drop m.a.ky
return val
endProcedure mapRemove
mapHasKey: procedure expose m.
parse arg a, ky
return symbol('m.a.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg a, ky
if symbol('m.a.ky') ^== 'VAR' then
call err 'missing key in mapGet('a',' ky')'
return m.a.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg a, ky, orDef
if symbol('m.a.ky') == 'VAR' then
return m.a.ky
else
return orDef
endProcedure mapGetOr
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') ^== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') ^== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt ^== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li ^= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.map.0 = 0
return
endProcedure mIni
/* copy map end *******************************************************/
/* copy m begin ********************************************************
stem handling
***********************************************************************/
/*--- 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
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- 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
mNext: procedure expose m.
parse arg m, ix, var
nx = m.ix + 1
if nx > m.m.0 then
return 0
m.ix = nx
m.var = m.m.nx
return 1
endProcedur mNext
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- 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
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, ggStem, ggOpt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then do
interpret m.err.handler
return 12
end
say 'fatal error:' ggTxt
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if ggStem ^== '' then do
do ggXX=1 to m.ggStem.0
say ' ' m.ggStem.ggXX
end
if ggXX > 3 then
say 'fatal error in' ggS3':' ggTxt
end
parse source . . ggS3 . /* current rexx */
if ggOpt == 'h' 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 setRc(12)
endSubroutine err
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, st, op
say 'fatal error:' msg
call help
call err msg, st, 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
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- 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
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
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
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 *****************************************************/