zOs/REXX.O08/MTEST
/* copy mTest begin ***************************************************
test infrastructure plus tests for wr, wr io and scan
***********************************************************************/
/*--- all tests ------------------------------------------------------*/
call mTestAll
exit
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
mTestAll: procedure expose m.
call mTestTest
call mTestScan
/*
call mTestWr
call mTestWrFore
call mTestIO
*/
call mTestTotal
return
endProcedure mTestAll
mTestTest: procedure expose m.
call mTestBegin 'mTestTest: test mTest internals',
, "test line eins",
, "test line zwei",
, "test line drei ganz lang 1 ...li",
|| "ne drei ganz lang 2 ...line drei",
|| " ganz lang 3 ...line drei ganz l",
|| "ang 4 und schluss."
call mTestLn 'test line eins'
call mTestLn 'test line zwei'
call mTestLn 'test line drei ganz lang 1 ',
' ...line drei ganz lang 2 ',
' ...line drei ganz lang 3 ',
' ...line drei ganz lang 4 und schluss.'
call mTestEnd
return
endProcedure mTestTest
/*--- test wr writerDescriptor nur mit stems -------------------------*/
mTestWr: procedure expose m.
pT = wrNew()
call mTest pT,
, "--- mTestWr ==> wrIni",
, "--- writeLn eins",
, "text eins", "text eins.2", "text eins.3",
, "--- write a",
, "m.a.1: elf",
, "m.a.2: zwoelf",
, "--- writeLn 20",
, "text 20",
, "--- closing buffer"
call mTestOut pT, 'mTestWr ==> wrIni'
call mTestOut pT, 'writeLn eins'
call writeLn pT, 'text eins', 'text eins.2', 'text eins.3'
m.a.1 = 'm.a.1: elf'
m.a.2 = 'm.a.2: zwoelf'
m.a.0 = 2
call mTestOut pT, 'write a'
call write pT, a
call mTestOut pT, 'writeLn 20'
call writeLn pT, 'text 20'
call mTestOut pT, 'closing buffer'
call wrClose pT
call mTest pT,
, "--- testing out",
, "outLn eins vor out a",
, "m.a.1: elf",
, "m.a.2: zwoelf",
, "outLn VIER nach out a ",
, "--- testing wrDefine",
, "beginStem 1",
, "line writeLn eins vor out a",
, "end Stem 1",
, "beginStem 2",
, "line m.a.1: elf",
, "line m.a.2: zwoelf",
, "end Stem 2",
, "beginStem 1",
, "line writeLn eins nach out a vor close",
, "end Stem 1",
, "close pX"
call outPush pT
call mTestOut pT, 'testing out'
call outLn 'outLn eins vor out a'
call out a
call outLn 'outLn VIER nach out a '
call mTestOut pT, 'testing wrDefine'
pX = wrDefine(wrNew(), 'call outLn "beginStem" m.stem.0',
, 'call outLn "close pX"',
, 'call outLn "line" m.line',
, 'call outLn "end Stem" m.stem.0')
call writeLn pX, 'writeLn eins vor out a'
call write pX, a
call writeLn pX, 'writeLn eins nach out a vor close'
call wrClose pX
call wrClose pT
call outPop
call mTest pT,
, "--- stem A ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A ==> B ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A,A==> B strip ==> test",
, "a.1 eins",
, "a.2 zwei",
, "a.1 eins",
, "a.2 zwei"
pX = wrNew()
m.a.1 = 'a.1 eins '
m.a.2 = 'a.2 zwei '
m.a.0 = 2
call wrDefine
call mTestOut pt, 'stem A ==> test'
call wrFromDS pT, 'stem=A'
call wrDSFromDS 'stem=B', 'stem=A'
call mTestOut pt, 'stem A ==> B ==> test'
call wrFromDS pT, 'stem=B'
call wr2DS pX, 'stem=B strip=1'
call wrFromDS pX, 'stem=A'
call wrFromDS pX, 'stem=A'
call wrClose pX
call mTestOut pt, 'stem A,A==> B strip ==> test'
call wrFromDS pT, 'stem=B'
call wrClose pT
return
endProcedure mTestWr
/*--- foreground test, schreibt nur auf Bildschirm ohne Vergleich ----*/
mTestWrFore: procedure expose m.
say '--- mTestWr Foreground wr2DS dsn=*'
t = wrNew()
call wr2DS t, 'dsn=*'
call writeLn t, 'first writeln to dsn=*'
say '--- write ABC to dsn=*'
call write t, wrArgs('ABC', 0, 'ABC.1 eins', 'ABC.2','ABC.3 .')
call writeLn t, 'after write a', 'last writeln to dsn=*'
call wrClose t
say '--- outLn'
call outLn 'first outLn line'
say '--- out ABC'
call out 'ABC'
call outLn 'outLn after out a', 'last outLn'
say '--- mTestWr Foreground end'
return
endProcedure mTestWrFore
/*--- test io Funktionen auf Datasets --------------------------------*/
mTestIO: procedure expose m.
pO = wrNew()
pT = wrNew()
dsnPr = 'test.out'
tst = date('s') time()
do i=0 by 1
if i>5 then
call err 'no nonExisting dataset found in' dsnPr'0..'dsn
dsn = dsnPr||i
if sysDsn(dsn) == 'DATASET NOT FOUND' then
leave
end
call mTest pT,
, "--- allocating "dsn,
, "--- writing to "dsn,
, "--- appending to "dsn,
, "--- reading "dsn,
, "zeile eins ln "tst" ",
, "zeile zwei a.1 "tst" ",
, "zeile zwei a.2 "tst" ",
, "zeile vier ln "tst" ",
, "zeile funf app "tst" ",
, "zeile sech a.1 "tst" ",
, "zeile sieb a.2 "tst" ",
, "zeile acht app "tst" "
call mTestOut pT, 'allocating' dsn
call wr2DS pO, 'disp=new,catalog lrecl=35 dsn='dsn
call mTestOut pT, 'writing to' dsn
call writeLn pO, 'zeile eins ln ' tst
call write pO, wrArgs(a, 0, 'zeile zwei a.1' tst,
, 'zeile zwei a.2' tst)
call writeLn pO, 'zeile vier ln' tst
call wrClose pO
call mTestOut pT, 'appending to' dsn
call wr2DS pO, 'dsn='dsn 'strip=1 ioa=a'
call writeLn pO, 'zeile funf app' tst ' '
call write pO, wrArgs(a, 0, 'zeile sech a.1' tst ' ',
, 'zeile sieb a.2' tst)
call writeLn pO, 'zeile acht app' tst ' '
call wrClose pO
call mTestOut pT, 'reading' dsn
rx = readDS(wrNew(), 'dsn='dsn)
do while readLn(rx, vv)
call writeLn pT, m.vv
end
call wrClose pT
call mTest pT,
, "--- wrFromDS "dsn,
, "zeile eins ln "tst" ",
, "zeile zwei a.1 "tst" ",
, "zeile zwei a.2 "tst" ",
, "zeile vier ln "tst" ",
, "zeile funf app "tst" ",
, "zeile sech a.1 "tst" ",
, "zeile sieb a.2 "tst" ",
, "zeile acht app "tst" "
call mTestOut pT, 'wrFromDS' dsn
call wrFromDs pT, 'dsn='dsn
call wrClose pT
call mTest pT,
, "--- wr2DS append to 666 records "dsn"",
, "--- readln 666 records "dsn"",
, "read 123 line 123 from dss dsn="dsn": append line 123 ",
|| " ",
, "read 246 line 246 from dss dsn="dsn": append line 246 ",
|| " ",
, "read 369 line 369 from dss dsn="dsn": append line 369 ",
|| " ",
, "read 492 line 492 from dss dsn="dsn": append line 492 ",
|| " ",
, "read 615 line 615 from dss dsn="dsn": append line 615 ",
|| " ",
, "eof at 667 eof after line 666 from dss dsn="dsn": appe",
|| "nd line 666 "
call mTestOut pT, 'wr2DS append to 666 records' dsn
call wr2DS pO, 'dsn='dsn 'strip=1 ioa=a'
ox = 0
do rx=9 to 667
ox = ox + 1
m.qrs.ox = 'append line' rx
if rx // 111 = 0 then do
m.qrs.0 = ox-1
call write pO, qrs
call writeLn pO, m.qrs.ox
ox = 0
end
end
call mTestOut pT, 'readln 666 records' dsn
call wrClose pO
call readDS pO, 'dsn='dsn
do r=1 while readLn(pO, v2)
if r//123=0 then
call writeLn pT, 'read' r readInfo(pO, '*')':' m.v2
end
call writeLn pT, 'eof at' r readInfo(pO, '*')':' m.v2
call wrClose pT
call mTest pT,
, "--- read 666 records "dsn"",
, "read q 1 line 1 from dss dsn="dsn" disp=old,delete: ze",
|| "ile eins ln "tst" ",
, "read q 2 line 102 from dss dsn="dsn" disp=old,delete: ",
|| "append line 102 ",
, "read q 3 line 203 from dss dsn="dsn" disp=old,delete: ",
|| "append line 203 ",
, "read q 4 line 304 from dss dsn="dsn" disp=old,delete: ",
|| "append line 304 ",
, "read q 5 line 405 from dss dsn="dsn" disp=old,delete: ",
|| "append line 405 ",
, "read q 6 line 506 from dss dsn="dsn" disp=old,delete: ",
|| "append line 506 ",
, "read q 7 line 607 from dss dsn="dsn" disp=old,delete: ",
|| "append line 607 ",
, "eof eof after line 666 from dss dsn="dsn" disp=old,del",
|| "ete",
, "--- sysdsn("dsn") = DATASET NOT FOUND"
call mTestOut pT, 'read 666 records' dsn
call readDs pO, 'dsn='dsn 'disp=old,delete'
do q=1 by 1 while read(pO, myStem)
call writeLn pt, 'read q' q,
readInfo(pO, q-m.myStem.0)':' m.myStem.q
end
call writeLn pt, 'eof' readInfo(pO, q-m.myStem.0)
call mTestOut pT, 'sysdsn('dsn') =' sysdsn(dsn)
call wrClose pT
return
endProcedure mTestIO
/*--- test scan ------------------------------------------------------*/
mTestScan: procedure expose m.
call mTestBegin 'mTestScan 1',
, "scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s",
|| "' ",
, "scan name tok a034 key val ",
, "scan char tok , key val ",
, "scan name tok Und key val ",
, "scan space 1 tok key val ",
, "scan name tok hr123sdfER key val ",
, "scan string quo tok ""st1"" key val st1",
, "scan space 1 tok key val ",
, "scan string apo tok 'str2''mit''apo''s' key val st",
|| "r2'mit'apo's",
, "scan space 4 tok key val "
call mTestScan1,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call mTestEnd
call mTestBegin 'mTestScan 2',
, "scan src litEinsfr 23 sR'str1'litZwei ""str2""""mi",
|| "t quo""s ",
, "scan literal tok litEins key val ",
, "scan name tok fr key val ",
, "scan space 1 tok key val ",
, "scan number tok 23 key val ",
, "scan space 1 tok key val ",
, "scan name tok sR key val ",
, "scan string apo tok 'str1' key val str1",
, "scan literal tok litZwei key val str1",
, "scan space 1 tok key val ",
, "scan string quo tok ""str2""""mit quo"" key val st",
|| "r2""mit quo",
, "scan name tok s key val str2""mit quo",
, "scan space 1 tok key val "
call mTestScan1,"litEinsfr 23 sR'str1'litZwei ""str2""""mit quo""s "
call mTestEnd
call mTestBegin 'mTestScan3',
, "scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan keyValue tok no= key aha val <default>",
, "scan word tok ;+-=f key aha val ;+-=f",
, "scan keyValue tok cdEf key ab val cdEf",
, "scan keyValue tok 'strIng' key eF val strIng",
, "scan no word tok key eF val "
call mTestScan1 w," aha;+-=f ab=cdEf eF='strIng' "
call mTestEnd
call mTestBegin 'scan4: 3 Zeilen mit nextLine',
, "name erste",
, "space",
, "name Zeile",
, "space",
, "nextLine",
, "nextLine",
, "space",
, "name dritte",
, "space",
, "name Zeile",
, "space",
, "name schluss",
, "space"
call mCopyArgs a, 0, 'erste Zeile ',,' dritte Zeile schluss '
call scanStem s, a
do while ^ scanAtEnd(s)
if scanName(s) then call mTestLn 'name' m.tok
else if scanVerify(s, ' ') then call mTestLn 'space'
else if scanNL(s) then call mTestLn 'nextLine'
else call scanErr s, 'not scanned'
end
call mTestEnd
call mTestBegin 'scan5: 3 Zeilen mit spaceLn',
, "name erste",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name dritte",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name schluss",
, "spaceLn"
call scanStem s, a
do while ^ scanAtEnd(s)
if scanName(s) then call mTestLn 'name' m.tok
else if scanSpaceNL(s) then call mTestLn 'spaceLn'
else call scanErr s, 'not scanned'
end
call mTestEnd
call mTestBegin 'scan6: 10 Zeilen mit Kommentar',
, "key abc=efg + 1 ",
, "key efg=2",
, "key j=x",
, "key k=y",
, "key l=schluss",
, "atEnd 1"
call mCopyArgs 'abc', 0,
, " * kommentar ",
, " abc ='efg + 1 ' * komm 2 ",
, " efg * komm 3 ",
, " = * komm 4 ",
, " * komm 5 ",
, " 2 j=x k=y l=* komm 6 ",
, " * komm 7 ",
, " ",
, " schluss ",
, " * end komment "
call scanStem s, 'abc'
call scanOptions s, , , '*'
do while scanKeyValue(s)
call mTestLn 'key' m.key'='m.val
end
call mTestLn 'atEnd' scanAtEnd(s)
call mTestEnd
call mTestTotal
return
endProcedure mTestScan
/*--- one single test scan with lines to scan in stem ln -------------*/
mTestScan1:
parse arg fun ., ln
call mTestLn 'scan src' ln
call scanLine s, ln
do while ^scanAtEnd(s)
if fun = w then do
if scanKeyValue(s, '<default>') then o = 'keyValue '
else if scanword(s) then o = 'word '
else o = 'no word '
end
else if scanLit(s, 'litEins') then o = 'literal '
else if scanLit(s, 'litZwei') then o = 'literal '
else if scanName(s) then o = 'name '
else if scanString(s) then o = 'string apo'
else if scanString(s, '"') then o = 'string quo'
else if scanNum(s) then o = 'number '
else if scanVerify(s, ' ') then o = 'space' length(m.tok)
else if scanChar(s,1) then o = 'char '
else call scanErr s, 'not scanned'
call mTestLn 'scan' o 'tok' m.tok 'key' m.key ,
'val' m.val
end
return
endProcedure mTestScan1
/***********************************************************************
test writer infrastructure
***********************************************************************/
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
mTestBegin: procedure expose m.
parse arg m.mTest.msg
m.mTest.out.0 = 0
say '*** begin' m.mTest.msg
do cx = 1 to arg()-1
m.mTest.cmp.cx = arg(cx+1)
end
m.mTest.cmp.0 = cx-1
m.mTest.err = 0
return
endProcedure mTestBegin
/*--- write to test: say lines and compare them ----------------------*/
mTestLn: procedure expose m.
parse arg line
ox = m.mTest.out.0 + 1
m.mTest.out.0 = ox
m.mTest.out.ox = line
say left(ox, 4) line
if ox > m.mTest.cmp.0 then do
if ox = m.mTest.cmp.0 + 1 then
call mTestErr 'more new Lines' ox
end
else if m.mTest.out.ox ^== m.mTest.cmp.ox then do
say 'old^^' || m.mTest.cmp.ox
m.mTest.err = m.mTest.err + 1
end
return
endProcedure mTestLn
/*--- close test: check differences and say compare strings ----------*/
mTestEnd: procedure expose m.
parse arg
if m.mTest.cmp.0 ^= m.mTest.out.0 then do
call mTestErr 'old' m.mTest.cmp.0 'lines ^= new' m.mTest.out.0
do nx = m.mTest.out.0 + 1 to ,
min(m.mTest.out.0 + 10, m.mTest.cmp.0)
say 'old--'m.mTest.cmp.nx
end
end
say '***' m.mTest.err 'errors in' m.mTest.msg
if m.mTest.err > 0 then do
say 'new lines:' m.mTest.out.0
len = 60
do nx=1 to m.mTest.out.0
str = quote(m.mTest.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.mTest.out.0)
end
end
if symbol('m.mTest.errTotal') ^== 'VAR' then
m.mTest.errTotal = 0
m.mTest.errTotal = m.mTest.errTotal + m.mTest.err
return
endProcedure mTestEnd
/*--- write a single test message ------------------------------------*/
mTestOut: procedure expose m.
parse arg m, msg
call writeLn m, '---' msg
return
endProcedure mTestOut
/*--- say total errors and fail if not zero --------------------------*/
mTestTotal: procedure expose m.
if m.mTest.errTotal = 0 then
say m.mTest.errTotal 'errors total'
else
call err m.mTest.errTotal 'errors total'
return
endProcedure mTestTotal
/*--- test err: message, count it and continue -----------------------*/
mTestErr: procedure expose m.
parse arg msg
say '*** error' msg
m.mTest.err = m.mTest.err + 1
return
endProcedure mTestErr
/* copy mTest end **************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
x = x / 0
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
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 zIspfRc
back as return code
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy mrw begin *****************************************************
interface m mRead and mWrite
mNew
convenience function to write to current output
***********************************************************************/
test: procedure
call mCopyArgs a, 0, 'eins ...', 'zwei ...', 'drei ... schluss'
call mIni
r = mNew()
s = mNew()
call mDefReadFromStem r, a
say 0 mReadLn(r,x) "'"m.x"'"
call mDefReadFromStem s, a
do i=1 to 5
say i mReadLn(r,x) "'"m.x"' read s" mReadLn(s, y) m.y
end
exit
endProcedure
/*--- initialize m ---------------------------------------------------*/
mIni: procedure expose m.
m.mrw.0 = 0
m.mrw.ini = 1
return
endProcedure mIni
mNew: procedure expose m.
m.mrw.0 = m.mrw.0 + 1
return m.mrw.0
endProcedure mNew
mDefRead: procedure expose m.
parse arg m, rexx
m.mrw.m.readLnIx = ''
m.mrw.m.read = rexx
return
endProcedure mDefRead
mRead: procedure expose m.
parse arg m, stem
interpret m.mrw.m.read
endProcedure mRead
/*--- put next line into m.line, return false at eof -----------------*/
mReadLn: procedure expose m.
parse arg m, line
if m.mrw.m.readLnIx == '' ,
| m.mrw.m.readLnIx >= m.mrw.m.readLnStem.0 then do
if ^ mRead(m, 'MRW.'m'.READLNSTEM') then do
m.line = ''
return 0
end
lx = 1
end
else do
lx = 1 + m.mrw.m.readLnIx
end
m.mrw.m.readLnIx = lx
m.line = m.mrw.m.readLnStem.lx
return 1
endProcedure readLn
mDefReadFromStem: procedure expose m.
parse arg m, stem
m.mrw.m.readFromStem = stem
call mDefRead m, 'if m.mrw.m.readFromStem == "" then return 0;' ,
'call mCopyStem stem, 0, m.mrw.m.readFromStem;' ,
'm.mrw.m.readFromStem = "";',
'return 1;'
return
endProcedure mDefReadStem
mReadFromStem: procedure expose m.
parse arg m, stem
si = m.mrw.m.readStem
ix = m.mrw.m.readStemIx + 1
m.mrw.m.readStemIx = ix
if ix <= m.si.0 then do
m.stem = m.si.ix
return 1
end
else do
m.stem = ''
return 0
end
endProcedure mReadFromStem
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
mCopyStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure mCopyStmm
/*--- fill stem dst from index dx with arguments ---------------------*/
mCopyArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure mCopyArgs
mSay: procedure expose m.
parse arg stem, msg
l = length(m.stem.0)
if l < 3 then
l = 3
say left('', l, '-') msg 'mSay begin stem' stem m.stem.0
do ix = 1 to m.stem.0
say right(ix, l) strip(m.stem.ix, 't')
end
say left('', l, '-') msg 'mSay end stem' stem m.stem.0
return
endProcedure mSayem
/* copy mrw end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
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
scanNum(m) : scan integer (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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanStem: procedure expose m.
parse arg m, inStem
call scanStart m
m.scan.m.stem = inStem
m.scan.m.stIx = 0
call scanNL m, 1
return
endProcedure scanStem
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
st = m.scan.m.stem
if st == '' then
return 0
ix = m.scan.m.stIx + 1
if ix > m.st.0 then
return 0
m.scan.m.src = m.st.ix
m.scan.m.stIx = ix
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
m.scan.m.stem = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
if namePlus = '' then
namePlus = '0123456789'
m.scan.m.name = nameOne || namePlus
end
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
st = m.scan.m.stem
return st == '' | m.st.0 <= m.scan.m.stIx
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
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.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- 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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.scan.m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
st = m.scan.m.stem
if st ^== '' then
say 'stem' st 'line' m.scan.m.stIx 'of' m.st.0
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then
return res
else if ^ scanLit(m, cc) then
return res
else if ^scanNL(m, 1) then
return res
res = 1
end
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/