Jump to content

$T.REX: Difference between revisions

added whitespace, used better indentations, changed comments, add more idiomatic code, other cosmetic changes.
m (added more whitespace. -- ~~~~)
(added whitespace, used better indentations, changed comments, add more idiomatic code, other cosmetic changes.)
Line 42:
<br>Some REXXes doen't have a &nbsp; '''SOUND''' &nbsp; BIF, so one is included here ──► [[SOUND.REX]].
<br><br>REXX programs not included are &nbsp; '''$H''' &nbsp; which shows '''help''' and other documentation.
<lang rexx>/*REXX*/ trace off /* There be many dragons below. */
parse arg !
if !all(0) then exit 0 /*help options and boilerplate.*/
 
zz = !! /*save a copy of original args. */
if !cms then address ''
signal on halt /*be able to handle a HALT. */
signal on novaluenoValue /*catch REXX vars with noValue. */
signal on syntax /*catch REXX syntax errors. */
numeric digits 300 /*be able to handle some big 'uns*/
Line 70:
scr0 shics VMout VScolor VSdisp x1 x2
 
@abc = 'abcdefghijklmnopqrstuvwxyz'; @abcU = @abc; upper @abcU
@abcU = @abc; upper @abcU
 
#ms = 0
?.a = 0
?.b = 0
?.block = 0
?.e = 0
?.end = 0
?.i = 0
?.ks = 0
?.L = 0
?.p = 0
?.q = 0
?.r = 0
?.ruler = 0
?.s = 0
?.scale = 0
?.ts = 0
?.x = 0
?.z = 0
boxing = 0
highL = 0
LLd = 0
LLk = 0
LLx = 0
maxhic = 0
 
## = 1
Line 102 ⟶ 103:
?.t = 1
 
?.bd = .2
?.bf = 800
?.bs = 2
?.o = 9999
?.rulerb = ' '
?.scaleb = ' '
?.scaled = '.'
?.scalep = '+'
?.use = '.'
esc = '1b'x"["
 
his='H() H{} H[] H<> H≤≥ H«» H/\"'
#his=words(his)
do jh=1 for 7#his
hh.jh=substr(word(his,jh),2)
end /*jh*/
 
colorSupport=!pcrexx | !r4 | !roo /*colors are supported by these. */
 
boxCH = '+-+|+-+|' /*define some boxing characters. */
Line 122 ⟶ 126:
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/
 
if !pcrexx|colorSupport then do !r4 | !roo then do /*use pre-saved color values. */
_=translate(!var('SCREEN'), ,";,") /*envVar.*/
if \datatype(space(_,0), "W") then _='36 40'
scr0=esc || translate(0 _, ';', " ")'m'
colorC.0=scr0
colorC.1=esc"1;33m"
end
 
do jz=1 while zz\==''
if ?.end==1 | pos('=',zz)==0 | pos(" "?.use,' 'zz)==0 then do
@=@ zz
Line 135 ⟶ 140:
end
if left(zz,1)==' ' then lz=lz" "
parse var zz yy1 2 yy2 3 1 yy ' ' zz
 
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2,"U") then
do 1
parse var yy 2 _ "=" dotv 2 _1 3
if datatype(_,'U') then
do
Line 149 ⟶ 154:
end
else select
when _=='BIN' then yy=valn("'"dotv"'B",'BIN',"B")
when _=='BOX' then do
if dotv=="" then ?.BOX=boxCH
else ?.BOX=dotv
iterate jz
end
when _=='DEC' then yy=valn("'"dotv"'D",'DEC',"D")
when _=='INV' then yy=.inv(dotv)
when _=='HEX' then yy=valn("'"dotv"'X",'HEX',"X")
when _=='USE' then do
dotv=tb(dotv,"USE",'.')
iterate jz
end
otherwise ?._=dotv; iterate jz
end /*select*/
end
Line 173 ⟶ 178:
end
end
end /*do 1*/
 
if @=='' then @=lz || yy
Line 180 ⟶ 185:
end /*jz*/
 
if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */
 
if ?.a\==0 then call .a
Line 193 ⟶ 198:
if ?.f\=='' then call .f
 
do _j=1 for 7#his
_=?.hi._j
if _\=='' & \!regina then do
Line 201 ⟶ 206:
end /*_j*/
 
if ?.i\==0 then do; call wn 'I',0,sw(); ?.ib=tb(?.ib,'IB'); end
call wn 'I',0,sw()
?.ib=tb(?.ib,'IB')
end
if ?.j\=='' then call .j
if ?.k\=='' then ?.k =valn(?.k,"K")
Line 270 ⟶ 278:
end /*select*/
 
if ?.block==0 then call tellIt _
else call blocker
end /*jj*/
end /*jt*/
Line 287 ⟶ 295:
when ?.L\==0 then call sayAline
otherwise call sayNline
end /*select*/
 
if ?.c\=='' then call VMcolor VMout,space(VScolor VSdisp)
Line 295 ⟶ 303:
if ?.scale>0 then call inches ?.scale,1
_=abs(?.a)
 
if _==99 & \?.q then !cls
else do min(99,_)
call wit bline
end /*min(...···*/
 
if ?.w\=='' then call .w
 
if !pcrexx then if ?.q & LLd>79 then if LLd>sw() then say
 
/*(above) PC-REXX bug: wrapped lines are */
/* overwritten during cleanup. */
return 0
Line 310 ⟶ 320:
.b: call wn 'B',-99,99,sd() /*B is for beeps (sounds). */
 
if ?.bd\==.2 then do
_=translate(?.bd,,',')
__=_
do while __\==''
parse var __ ?.bd __
call wn 'BD', .1, 9, ,"N"
end /*while*/
?.bd=_
end
 
if ?.bf\==800 then do
_=translate(?.bf,,',')
__=_
do while __\==''
parse var __ ?.bf __
call wn 'BF', 1, 20000
end /*while*/
?.bf=_
end
return
 
Line 342 ⟶ 352:
if _=='*NONE*' then ?.box=
boxing= ?.box\==''
if \boxing then return
 
if _=='SINGLELINE' then _=boxCH
Line 351 ⟶ 361:
end /*_*/
_=verify(@,' ')-1
if _>0 then @=@ || copies(" ",ldb_)
return
 
Line 360 ⟶ 370:
call cp 'QUERY SCREEN',1
parse var cp.1 "VMOUT" VMout
'QUERY VSCREEN CMS ALL (LIFO'
if rc==0 then pull "(" . . VScolor VSdisp .
if ?.c=='BRITE' then call VMcolor "DEFAULT NONE"
Line 366 ⟶ 376:
end
 
if !regina\colorSupport then ?.c= /*ReginaMost canREXXes don't handle colors. support color*/
return
 
Line 386 ⟶ 396:
/*──────────────────────────────────.EF subroutine──────────────────────*/
ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/
?.f = ?.ef
return
 
Line 406 ⟶ 416:
/*──────────────────────────────────.J subroutine───────────────────────*/
.j: upper ?.j /*Justify (or not) the text. */
if ?.j=='' then ?.j = 'N' /*Justify (or not) the text. */
else ?.j= left(?.j,1) /*just use the first letter of .J*/
 
if pos(?.j,"ACJLNR")==0 then call er 55, ?.j '.J='
Line 422 ⟶ 432:
/*──────────────────────────────────.L subroutine───────────────────────*/
.L: upper ?.L /*Line(s) for the text is shown. */
if !cms then do
'$QWHAT DSC'
if rc==4 then ?.L=0
end
 
if ?.L=='CMSG' then ?.L="*"
call wn 'L',-sd(),sd()
if ?.L<0 then ?.L=sd()-?.L
return
 
Line 473 ⟶ 483:
 
if ?.s<0 then do
if left(?.o,1)=='-' then then /*check for conflicting options*/
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
onlys = -?.s
Line 479 ⟶ 489:
end
 
if left(?.o,1)=="-" & left(?.s,1)=='-' then
call er 61,"O="?.o 'S='?.s "(both can't be negative)"
return
Line 519 ⟶ 529:
 
/*──────────────────────────────────.W subroutine───────────────────────*/
.w: if ?.q then return
if ?.wb\=='' then ?.wb=tb(?.wb, 'WB')
 
ww=translate(?.w,,"_")
if ww='dd'x then ww = "press any key to continue ..."
if ww='de'x then ww = "press the ENTER key to continue ..."
call '$T' ".C=yel" translate(ww,?.wb,' ')
if ww='dd'x then call inkey
if ww='de'x then pull external
return
 
Line 539 ⟶ 549:
/*──────────────────────────────────.XK subroutine──────────────────────*/
.xk: do ##=1
parse var @ _ (xk) @
if _=='' & @=="" then leave
tx.## = _
Line 565 ⟶ 575:
call sound word(?.bf, jb_), word(word(?.bd,jb_) .2,1)
end /*jb_*/
 
end /*jb */
return
Line 622 ⟶ 631:
if dark & left(cc,2)=='1;' then cc="0"substr(cc,2)
 
if !cms then do
if hue='GRAY' | hue=="BLACK" then hue='WHITE'
if hue="BROWN" then hue='YELLOW'
end
 
color.cc# = hue
Line 679 ⟶ 688:
else _=$scale(?.ruler 'RULE' _ 'Q')
 
parse var _ _.1 '9'x _.2 '9'x _.3
 
do jk=1 for 3
Line 689 ⟶ 698:
/*──────────────────────────────────MS subroutine───────────────────────*/
ms: #ms=#ms+1 /*justification and indentation. */
parse arg _i
 
select
Line 711 ⟶ 720:
 
if \?.q then do
if !cms then '$CLEAR .WL='?.L _mm
if !dos then call dsay,
esc || (?.L-1) || ";0f"colorC.0 || _mm || scr0
end
Line 726 ⟶ 735:
if skp() then iterate
call wr _mm
if ?.q then iterate
 
if !cms then '$CLEAR .C=BRITE' _mm
else if !dos then call dsay colorC.0 || _mm || scr0
end /*jj*/
return
Line 737 ⟶ 746:
if skp() then iterate
 
if !dos then do
if ?.c=='' then call dsay _mm
else call dsay colorC.0 || _mm || scr0
call wr _mm
end
else call wit _mm
end /*jj*/
return
Line 844 ⟶ 853:
 
/*──────────────────────────────────VMCOLOR subroutine──────────────────*/
VMcolor: if \!cms then return
parse arg c1,c2
if c1\=='' then call cp "SCREEN VMOUT" c1
if c2\=='' then "SET VSCREEN CMS" c2
Line 852 ⟶ 861:
/*──────────────────────────────────WN subroutine───────────────────────*/
wn: procedure expose ?. /*normalize, validate N in range.*/
arg z, L, H, d, t
_ = ?.z
parse upper var _ f 2
m = pos(f,'MH')\==0
 
if m | ,f=='*' then do
_ = (word(d H L sw(),1)) / word(1 2,m+1)substr(_,2)
f=='*' then do
_ = (word(d H L swif \datatype()_,1)"N") / word(1then interpret 2,m+1)substr'_='translate(_,2"%",'/')
if \datatype(_,"N") then interpret '_ ?.z ='translate( _,"%",'/')
?.z = _ end
end
 
if datatype(_,"N") then ?.z = _/1
if \datatype(_,left(t"W",1)) then call er 53, _ '.'z"="
if L\=='' then if _<L | _>H then call er 81,L H _ "value for option ."z'='
return _
 
/*──────────────────────────────────WR subroutine───────────────────────*/
wr: parse arg wr wr /*write [argument 1] ───> disk. */
if ?.f=='' then return /*Nothing to write? Then skip it.*/
if highL & ahics\=='' then wr=translate(wr,, ahics) /*has highlighting?*/
Line 879 ⟶ 887:
 
call lineout ?.f /*close the file. */
return 0
 
/*═════════════════════════════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; if !crx then !env='DOS'; 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'; !crx=left(!sys,6)=='DOSCRX'; call !rex; return
!var: call !fid; if !kexx then return space(dosenv(arg(1))); return space(value(arg(1),,!env))
.a: call wn 'A',-99,99,sd(); ?.ab=tb(?.ab,'AB'); return
$block: !call='$BLOCK'; call '$BLOCK' arg(1); !call=; return result
$mkdir: !call='$MKDIR'; call '$MKDIR' arg(1); !call=; return result
$scale: !call='$SCALE'; call '$SCALE' arg(1); !call=; return result
cp: ' "EXECIO'" '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc
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
p: return word(arg(1),1)
halt: call er .1
kw: parse arg kw; return kw c2x(?.kw)
lower: return translate(arg(1),@abc,@abcu)
novaluenoValue: !sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
proper: procedure; arg f 2; parse arg 2 r; return f || r
sd: if ?.scrdepth=='' then parse value scrsize() with ?.scrdepth ?.linesize .; return ?.scrdepth
sw: if ?.Linesizelinesize=='' then ?.Linesizelinesize=linesize(); return ?.Linesizelinesize
syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
wit: call dsay arg(1); call wr arg(1); return</lang>
 
 
 
</lang>
/*═════════════════════════════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))
.a: call wn 'A',-99,99,sd(); ?.ab=tb(?.ab,'AB'); return
$block: !call='$BLOCK'; call '$BLOCK' arg(1); !call=; return result
$mkdir: !call='$MKDIR'; call '$MKDIR' arg(1); !call=; return result
$scale: !call='$SCALE'; call '$SCALE' arg(1); !call=; return result
cp: 'EXECIO' '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc
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
p: return word(arg(1),1)
halt: call er .1
kw: parse arg kw; return kw c2x(?.kw)
lower: return translate(arg(1),@abc,@abcu)
novalue:!sigl=sigl;call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
proper: procedure; arg f 2;parse arg 2 r; return f || r
sd: if ?.scrdepth=='' then parse value scrsize() with ?.scrdepth ?.linesize .;return ?.scrdepth
sw: if ?.Linesize=='' then ?.Linesize=linesize(); return ?.Linesize
syntax: !sigl=sigl;call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
wit: call dsay arg(1); call wr arg(1); return</lang>
Cookies help us deliver our services. By using our services, you agree to our use of cookies.