$ERR.REX
<lang rexx>/**/trace o; parse arg !; if !all(arg()) then exit if !cms then address signal on halt; signal on novalue; signal on syntax numeric digits 100
@ctty = 'CTTY' /*point to the CTTY cmd*/ @globalv = 'GLOBALV' /*point to the GLOBALV cmd*/ @finis = 'FINIS' /*point to the FINIS cmd*/ @subcom = 'SUBCOM' /*point to the SUBCOM cmd*/ @cpset = 'CP SET' /*point to the CP SET cmd*/ @conwait = 'CONWAIT' /*point to the CONWAIT cmd*/ @cpspool = 'CP SPOOL' /*point to the CP SPOOL cmd*/ @cmstype = 'SET CMSTYPE' /*point to SET CMSTYPE cmd*/
if !cms |!dos then @ = '────────'
else @ = '--------'
parse var !! !! ' ..F=' ftops if ftops\== then ftops='.F='ftops etops=strip(ftops '.C=red .END=1') g.1=space(!!) pblank='05'x /*use pseudoblank as blank.*/
do j=2 to 9 k=j-1 parse var g.k a.k g.j if a.k==',' then a.k= g.k=translate(g.k,,pblank) a.k=translate(a.k,,pblank) aU.k=a.k; upper aU.k L.k=length(a.k) c.k=comma(a.k) w.k=length(c.k) end /*j*/
a2=a.2; a3=a.3; a4=a.4; a5=a.5; a6=a.6; a7=a.7; a8=a.8
g3=g.3; g4=g.4; g5=g.5; g6=g.6; g7=g.7; g8=g.8
aa5=a.5 if isnum(aa5) then aa5=abs(aa5) i=a.1 errmsgto= errmsgnt= xedit=0
if !cms then do
@globalv 'SELECT' !fn 'GET ERRMSGTO ERRMSGNT'
@finis '* * *'
@cmstype 'RT'
@conwait
@cpspool 'CON TERM'
@cpset' IMSG ON'
@cpset' EMSG ON'
@subcom 'XEDIT'
xedit=\rc & \cmsflag('SUBSET')
ufid=a3 a4 a5
end
if !dos then do
if \!nt then @ctty 'con'
_=a4
if _\== & right(_,1)\=="\" then _=_'\'
ufid=_ || a2"."a3
end
i=space(translate(i,,'-'),0) if i== then call erb 57
if i=0 then do
_=
iL=length(i)
if iL>1 then _=@'author'@"÷÷÷÷Gerard J. Schildberger"
if iL>2 then _=_ '÷÷phone (701)-242-8238'
if iL>3 then _=_ '÷÷E-mail gerardS@rrt.net'
if iL>5 then _=_ '÷÷9411 West Ridge Road,'
if iL>5 then _=_ '÷÷Hankinson, ND 58041'
atops=strip(ftops '.A=-2 .X=-2 .E=2 .C=yell .J=c .BOX= .KD=÷')
if _\== then call $t atops _
exit 0
end
if i==14000 |,
i=='14.1' then do
htops=strip(ftops '.A=-1 .X=-1 .E=1 .C=red .J=c .BOX=')
call $t htops 'The REXX program' @ a2 @ "has been halted !"
exit 14000
end
if \isint(i) then call erb 53,i "error_code" oi=i xedit= xedit & oi>0 i=abs(i) if i<1400 | i>1499 then call erb 99,oi k=i-1400 if xedit then address 'XEDIT' "SET MSGM ON LONG" call sy call sy "($$$"i") *error*:"
if k==0 then call sy "some commands can't or shouldn't be executed while in" g3 if k==1 then call sy "the" g3 'was previously specified or specified more than once' if k==2 then call sy "the" a4 "argument can't be" choose("negative",g5)":" a3 if k==3 then call sy 'the (disk) filemode' a3 "can't have any read-only extensions" g4 if k==4 then call sy 'the' a4 "filemode/address can't be" choose('RELEASEd',g5)":" a3 if k==5 then do;call sy "illegal compator operator" @ a3 'specified,';call sy "it must be one of: = \= < <= > >= \< \>";end if k==6 then call sy "no special characters are allowed in the" g4':' a3 if k==7 then call sy "fixed-point underflow or overflow (result is too small or too large)" if k==8 then call sy "illegal filemode" @ a3 @ g4 if k==9 then call sy "a terminal screen (CRT) is required with the" @ a3 @ 'feature' if k==10 then if a3== then call sy "missing fileid for" g4
else call sy "illegal fileid" @ space(a3 a4 a5) @ g6
if k==11 then call sy "comparand operand must be an = or \= when using *xxx* type comparisons" if k==12 then call sy "not enough" choose('virtual storage',g4)", at least" a3 'are needed' if k==13 then do;call sy "REXX syntax error";if isint(a.6) then call sy errortext(a.6);call syline;end if k==14 then call sy 'the' a5 "argument" a3 "can't be" choose('greater',a.7) "than" a6 a4 if k==15 then do;if a3== then call sy "division by zero"
else do;call sy 'raising a negative number' @ a3 @;call sy "to a negative or an odd fractional power" @ a4 @;call fto g5;end;end
if k==16 then do;call sy "illegal MDISK" g4 'address:' a3",";call sy 'it must be exactly three hexadecimal characters (but not 000), or it may be';call sy "preceeded by an asterisk (*) followed by three decimal characters";end if k==17 then do;call sy "undefined REXX variable referenced" a.6;call syline;end if k==18 then do;call sy "illegal MDISK address or filemode,";call sy "the 191 A MDISK address is reserved for the CMS user's private MDISK";end if k==19 then call sy 'numeric digits ('comma(a6)") isn't sufficient to" a4 a5 'to' a3 if k==20 then call sy "the" a3 @ a4 'and' g5 @ "aren't alike" if k==21 then call sy choose("increment",a3) 'must be preceeded by a plus (+) or a minus (-)' if k==22 then do;_='combination of characters:';if L.4==1 then _="character:";call sy a3 'contains an invalid' _ g4;end if k==23 then call sy "the" a3 choose("option",a5) "requires the" a4 choose('option or feature',g6) if k==24 then call sy "illegal" choose('volume',a4) "serial:" a3 ' (it must be six or less characters)' if k==25 then do;call sy "you must be in the" a3 'mode/program to use the';call sy "specified command (or its" g4 "option)";end if k==26 then do;call sy "illegal MDISK" g4 'address:' a3",";call sy 'it must be exactly three hexadecimal characters (but not 000)';end if k==27 then call sy choose('number',g4) "can't be negative or zero (must be positive):" a3 if k==28 then call sy "duplicate" a3 'defined or specified:' g4 if k==29 then call sy "illegal filemode:" a3', it must be one character' if k==30 then do;call say30;if a5==a6|a6==|a6=="," then call sy "it must be" space(aa5 g8 _b)
else do;_to='to';if a6==aa5+1 then _to="or";call sy 'it must be from' aa5 _to a6 _b;end;end
if k==31 then call sy "no lines (or incorrect lines) were put in the program stack" g3 if k==32 then call sy 'the command' a3 "exited, but it isn't supposed to exit or stop" if k==33 then call sy 'the' a3 "MDISK isn't a CMS MDISK, it's in the wrong format" if k==34 then call sy @ a3 a4 @ "can't be executed from the" a5 'MDISK' if k==35 then do;call sy "no" choose('argument',a4) 'was specified after or';call fto a3 g5;end if k==36 then call sy 'file' @ g3 @ "can't exist on the" a5 'MDISK' if k==37 then do;y=a3;_=pos(a3,"`{[(«');if _\==0 then y=translate(word('single_quote double_quote grave_accent left_brace left_bracket left_parenthesis left_double_carrot',_),,"_") a3;call sy 'unmatched' y g4;end if k==38 then call sy 'file' @ space(a3 a4 a5) @ choose("can't be located or is empty",g6) if k==39 then call sy "the" a3 choose('argument',a8) 'must be' a4 a5 "the" a6 choose('argument',a7) if k==40 then do;call sy 'argument' @ a3 @ "isn't a valid hexadecimal string/number";call sy "(it contains a character other than 0123456789ABCDEFabcdef or a blank)";call fto g4;end if k==41 then do;call sy "VM userid" @ g3 @ "doesn't exist or";call sy 'is illegal (it may have an illegal character in it)';end if k==42 then call sy "the MDISK" a4 'for the user' a3 "doesn't exist" if k==43 then call sy "illegal password for the" a3 a5 'MDISK was specified' if k==44 then do;call sy "a CMS command is being used out of context, or";call sy 'a command was renamed, or the FSTs have been altered';_='DOS';if cms then _="CMS";call sy '(you may have to IPL' _")";end if k==45 then call sy 'VM userid' @ g3 @ "isn't logged on" if k==46 then call sy "the file's" @ g4 "LRECL can't exceed" a3 if k==47 then call sy a3 @ a4 @ "not found" g5 if k==48 then do;_=;L=1;if L.4==1|right(aU.4,1)=='X' then _=" an";if _== then L=0;call sy @ a3 g5 @ 'contains'_ "invalid character"s(L)':' a4;end if k==49 then call sy "CP LINK error for MDISK" a4 'userid' a3 if k==50 then do;call sy 'illegal/invalid' a3 "specified" @ a4 @;call fto g5;end if k==51 then call sy choose("documentation",a5) 'for' a3 a4 "couldn't be located" if k==52 then do;call sy "arguments aren't permitted";call fto a4;end if k==53 then do;call sy 'argument' @ a3 @ "isn't numeric" g5;call fto a4;end if k==54 then do;call sy "not enough" choose('arguments',a3) "were specified" g5;call fto a4;end if k==55 then do;call sy "illegal argument" @ a3 @ g5;call fto a4;end if k==56 then call sy "illegal number of" choose('arguments',a4) "were specified" g5 a3 if k==57 then do;y=choose("arguments",a3);z='was';if translate(right(y,1))=="S" then z='were';call sy "no" y z "specified";end if k==58 then call sy "only" g3 'argument's(a3) 'are accepted' if k==59 then do;call sy "too many" choose('arguments',a3) "were specified" g5;call fto a4;end if k==60 then call sy "argument#" a4 @ a3 @ 'must be an * or numeric' if k==61 then call sy "conflicting arguments:" g3 if k==62 then call sy choose('fileid1',a3) "and" choose('fileid2',a4) "can't be identical" g5 if k==63 then do;call sy "no" 'argument was specified after or';call fto g3;end if k==64 then call sy "up to" g3 'argument's(a3) 'are accepted' if k==65 then call sy "bad argument" @ a3 @ "illegal use of" g4 if k==66 then call sy "only" a3 'to' a4 "arguments are accepted" if k==67 then call sy "unable to parse" a3 'from the results of:' g4 if k==68 then do;call sy "return code" a3 'doing:';call sy g4;i=a3;end if k==69 then call sy 'user' @ a3 @ "can't be logged on while the command" @ a2 @ 'is running' if k==70 then do;if a3==2 then call sy "the" @ a2 @ 'command must be executed under the' a4 "userid";if a3==1 then call sy "the" @ a2 @ "command must be executed from the A MDISK";call sy "illegal use of the" @ a2 @ "command, subrc="a3;end if k==71 then call sy "can't attach a" g3 if k==72 then do;call sy 'argument' @ a3 @ "isn't alphabetic" g5;call fto a4;end if k==73 then do;call sy "an attempt was made to execute an unauthorized or restricted command";if g3\== then call sy g3;end if k==74 then call sy "the user" @ a3 @ 'must be in' a4 "mode" if k==75 then call sy "no" choose('write',a4) "access to the" @ choose('A',space(left(a3),1)) @ "MDISK" if k==76 then call sy a3 g5 "isn't known or supported:" a4 if k==77 then call sy space('error' a3 "in writing to disk file" @ g4 @) if k==78 then call sy choose("file",g6) @ a3 a4 a5 @ 'not found' if k==79 then call sy "the time window for execution is" a3 'through' a4 if k==80 then call sy @ a3 @ "isn't a known userid" if k==81 then do;call sy 'argument' @ a5 space(@ g7) "is out of range";_=max(w.3,w.4);if L.3\==0 then call sy 'the lower limit is:' right(c.3,_);if L.4\==0 then call sy 'the upper limit is:' right(c.4,_);call fto a6;end if k==82 then call sy g4 @ a3 @ "can't be located" if k==83 then call sy "the" @ g3 @ 'option is required' if k==84 then call sy "file" @ g4 @ 'had a syntax error for' a3 if k==85 then call sy "illegal combination of arguments:" g4 if k==86 then do;call sy "the" choose(a3,a2) 'command is being invoked out of context';if g4\== then call sy g4;end if k==87 then do;call sy 'argument' @ a3 @ "isn't a valid" choose('bit digit',a4);call sy '(it contains more than one binary digit)';call fto g5;end if k==88 then call sy g4 @ a3 @ "doesn't exist" if k==89 then call sy 'the' a3 "command can't be found" if k==90 then do;call sy 'evaluation of' a3 "contains a zero divisor and";call sy 'the result is infinite' g4;end if k==91 then do;call sy 'argument' @ a3 @ "isn't a valid" choose('bit string',a4);call sy '(it contains a non-binary character other than 0 or 1)';call fto g5;end if k==92 then do;call sy choose('argument',a4) @ a3 @ "isn't a whole number (integer)" g7;call fto a5;end if k==93 then call sy "file" @ g3 @ 'already exists' if k==94 then call sy "the T-DISK requested can't be obtained" if k==95 then call sy "not enough free storage can be obtained" if k==96 then call sy "illegal file" @ g3 @ 'or it was incorrectly modified' if k==97 then do;call sy "a command failed,";if a3 \== then call sy "sub-command" @ g3 @',';call sy "it's all or partially restricted to authorized users";end if k==98 then do;call sy "an attempt was made to execute the" @ a2 @ 'command while';call sy "the user" @ userid() @ "was in disconnected mode";end if k==99 then call sy "illegal error number for the" !fn 'REXX EXEC' ":" g3 if a2\== then call sy "for the" @ a2 @ 'command or function.' call sy if errmsgnt\== & errmsgto\== then call sy "A notification (via $M) of this error has been sent to" errmsgto if !cms then @globalv 'SELECT' !fn "PURGE" if \isint(i) then call er 53,i exit sign(oi)*i
/*──────────────────────────────────DCHARS subroutine───────────────────*/ dchars: chr.= _='¶'; chr._='paragraph_mark' _='§'; chr._='section_mark' _='!'; chr._='exclaimation_point' _='"'; chr._='double_quote' _='#'; chr._='pound_or_hash_mark' _='$'; chr._='dollar_sign' _='%'; chr._='percent_sign' _='&'; chr._='ampersand' _="'"; chr._='single_quote' _='('; chr._='left_parenthesis' _=')'; chr._='right_parenthesis' _='*'; chr._='asterisk' _='+'; chr._='plus_sign' _=','; chr._='comma' _='-'; chr._='minus_sign' _='.'; chr._='period' _='/'; chr._='slash' _=':'; chr._='colon' _='; ';chr._='semi-colon' _='<'; chr._='less-than' _='='; chr._='equal_sign' _='>'; chr._='greater-than' _='?'; chr._='question_mark' _='@'; chr._='commercial_at' _='['; chr._='left_bracket' _='\'; chr._='backslash' _=']'; chr._='right_bracket' _='^'; chr._='circumflex' _='_'; chr._='underscore' _='`'; chr._='grace_accent' _='{'; chr._='left_brace' _='|'; chr._='OR-or-pipe' _='}'; chr._='right_brace' _='~'; chr._='tilde' _='¢'; chr._='cent_sign' _='£'; chr._='pound_sign' _='¥'; chr._='yen_sign' _='₧'; chr._='peseta_sign' _='ƒ'; chr._='franc_sign' _='¿'; chr._='inverted_question_mark' _='¬'; chr._='not_sign' _='¡'; chr._='inverted_exclaimation_point' _='«'; chr._='left_guillemet' _='»'; chr._='right_guillemet' _='─'; chr._='dash_or_hyphen' _='±'; chr._='plus_or_minus' _='≥'; chr._='greater_then_or_equal_to' _='≤'; chr._='less_then_or_equal_to' _='÷'; chr._='divison' _='°'; chr._='degree' _='∙'; chr._='bullet' _='√'; chr._='radical' return
/*═════════════════════════════general 1-line subs════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/ !all:!!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1 !cal:if symbol('!CALL')\=="VAR" then !call=;return !call !env:!env='ENVIRONMENT';if !sys=='MSDOS'|!brexx|!r4|!roo then !env='SYSTEM';if !os2 then !env='OS2'!env;!ebcdic=1=='f0'x;return !fid:parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .;call !sys;if !dos then do;_=lastpos('\',!fn);!fm=left(!fn,_);!fn=substr(!fn,_+1);parse var !fn !fn '.' !ft;end;return word(0 !fn !ft !fm,1+('0'arg(1))) !rex:parse upper version !ver !vernum !verdate .;!brexx='BY'==!vernum;!kexx='KEXX'==!ver;!pcrexx='REXX/PERSONAL'==!ver|'REXX/PC'==!ver;!r4='REXX-R4'==!ver;!regina='REXX-REGINA'==left(!ver,11);!roo='REXX-ROO'==!ver;call !env;return !sys:!cms=!sys=='CMS';!os2=!sys=='OS2';!tso=!sys=='TSO'|!sys=='MVS';!vse=!sys=='VSE';!dos=pos('DOS',!sys)\==0|pos('WIN',!sys)\==0|!sys=='CMD';call !rex;return !var:call !fid;if !kexx then return space(dosenv(arg(1)));return space(value(arg(1),,!env)) $t: !call=']$T';call "$T" arg(1);call=;return choose: parse arg c1,c2; if c2==|c2=="," then return c1; else return c2 comma:procedure;parse arg _,c,p,t;c=pickblank(c,",");o=p(p 3);p=abs(o);t=p(t 999999999);if \isint(p)|\isint(t)|p==0|arg()>4 then return _;n=_'.9';#=123456789;k=0;return comma_() comma_:if o<0 then do;b=verify(_,' ');if b==0 then return _;e=length(_)-verify(reverse(_),' ')+1;end;else do;b=verify(n,#,"M");e=verify(n,#'0',,verify(n,#"0.",'M'))-p-1;end;do j=e to b by -p while k<t;_=insert(c,_,j);k=k+1;end;return _ er:parse arg _1,_2;call '$ERR' "14"p(_1) p(word(_1,2) !fid(1)) _2;if _1<0 then return _1;exit result erb:call sy;if a2\=="" then call sy '('!fn "was invoked by the" @ a2 @ 'EXEC)';call er arg(1),arg(2) fto:parse arg fto ftox;ftoo='option';if right(fto,2)=='()' then ftoo='function';if fto\== then call sy "for the" ftoo @ space(fto ftox) @;return halt: call er .1 isint: return datatype(arg(1),'W') isnum: return datatype(arg(1),'N') novalue:!sigl=sigl;call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) opf: if right(arg(1),2)=='()' then return "function";return 'option' p: return word(arg(1),1) pickblank:procedure;parse arg x,y;arg xu;if xu=='BLANK' then return ' ';return p(x y) s: if arg(1)==1 then return arg(3);return p(arg(2) 's') say30:if a5==-1 then call sy 'illegal' a4":" a3;else call sy "illegal length of" a4":" a3;_t=p(a7 'character');_b=_t||s(p(a6 aa5))" in length";return sy:sy=arg(1);if length(sy)<81 then do;call syit sy;return;end;sysy=;do forever while sy\==;parse var sy _t sy;if length(sysy _t)<80 then do;sysy=sysy _t;iterate;end;call syitb;sysy=_t;end;if strip(sysy)\== then call syitb;return syfunc:if left(a6,1)==']' then do;_sl=g8;call sy "invocation of an undefined REXX function/subroutine" substr(a6,2);end;return syit:syit=arg(1);if xedit then address 'XEDIT' "EMSG" syit;else if a2=='$T' then say syit;else call $t etops syit;if errmsgto\==&syit\== then call '$M' errmsgto syit;return syitb:if left(sysy,1)==' ' then sysy=substr(sysy,2);call syit sysy;return syline:if a5\==0 then call sy 'on line' a5 "of" ufid;_sl=g7;call syfunc;if _sl\== then do;call sy;call sy "REXX sourceline is:";call sy;call sy _sl;call sy;end;if !cms then do;'EXECSTAT' a2 a3;if rc==0 then "EXECDROP" a2 a3;end;return syntax:!sigl=sigl;call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)</lang>