$T.REX: Difference between revisions

Line 42:

<br>Some REXXes doen't have a   '''SOUND'''   BIF, so one is included here ──► [[SOUND.REX]].

<br><br>REXX programs not included are   '''$H'''   which shows '''help''' and other documentation.

<lang rexx>/**/ trace off /* There be many dragons below. */

<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 ~~novalue~~ /*catch REXX vars with noValue. */

signal on noValue /*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~~

@abc = 'abcdefghijklmnopqrstuvwxyz'

@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:

Line 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='H() H{} H[] H<> H≤≥ H«» H/\'

#his=words(his)

do jh=1 for 7

do jh=1 for #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:

Line 126:

if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/

if ~~!pcrexx|~~ ~~!r4~~ | ~~!roo~~ ~~then~~ do /*use pre-saved color values. */

if colorSupport then do /*use pre-saved color values. */

_=translate(!var('SCREEN'), ,";,") /*envVar*/

_=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:

Line 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:

Line 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:

Line 178:

end

end /*1*/

end /*do 1*/

if @=='' then @=lz || yy

Line 180:

Line 185:

end /*jz*/

if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */

if ?.a\==0 then call .a

Line 193:

Line 198:

if ?.f\=='' then call .f

do _j=1 for 7

do _j=1 for #his

_=?.hi._j

if _\=='' & \!regina then do

Line 201:

Line 206:

end /*_j*/

if ?.i\==0 then do~~; call wn 'I',0,sw(); ?.ib=tb(?.ib,'IB'); end~~

if ?.i\==0 then do

call wn 'I',0,sw()

?.ib=tb(?.ib,'IB')

⚫

end

if ?.j\=='' then call .j

if ?.k\=='' then ?.k =valn(?.k,"K")

Line 270:

Line 278:

end /*select*/

if ?.block==0 then call tellIt _

else call blocker

end /*jj*/

end /*jt*/

Line 287:

Line 295:

when ?.L\==0 then call sayAline

otherwise call sayNline

end /*select*/

if ?.c\=='' then call VMcolor VMout,space(VScolor VSdisp)

Line 295:

Line 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(~~...~~*/

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 */

/*(above) PC-REXX bug: wrapped lines are*/

/* overwritten during cleanup. */

return 0

Line 310:

Line 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:

Line 352:

if _=='*NONE*' then ?.box=

boxing= ?.box\==''

if \boxing then return

if _=='SINGLELINE' then _=boxCH

Line 351:

Line 361:

end /*_*/

_=verify(@,' ')-1

if _>0 then @=@ || copies(" ",~~ldb~~)

if _>0 then @=@ || copies(" ",_)

return

Line 360:

Line 370:

call cp 'QUERY SCREEN',1

parse var cp.1 "VMOUT" VMout

'QUERY VSCREEN CMS ALL(LIFO'

'QUERY VSCREEN CMS ALL (LIFO'

if rc==0 then pull "(" . . VScolor VSdisp .

if ?.c=='BRITE' then call VMcolor "DEFAULT NONE"

Line 366:

Line 376:

end

if ~~!regina~~ then ?.c= /*~~Regina~~ ~~can~~'t ~~handle colors.~~ */

if \colorSupport then ?.c= /*Most REXXes don't support color*/

return

Line 386:

Line 396:

/*──────────────────────────────────.EF subroutine──────────────────────*/

ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/

?.f = ?.ef

return

Line 406:

Line 416:

/*──────────────────────────────────.J subroutine───────────────────────*/

.j: upper ?.j /*Justify (or not) the text. */

if ?.j=='' then ?.j = 'N' /*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*/

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:

Line 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:

Line 483:

if ?.s<0 then do

if left(?.o,1)=='-' ~~then~~ /*check for conflicting options*/

if left(?.o,1)=='-' then /*check for conflicting options*/

call er 61,"O="?.o 'S='?.s "(both can't be negative)"

onlys = -?.s

Line 479:

Line 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:

Line 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:

Line 549:

/*──────────────────────────────────.XK subroutine──────────────────────*/

.xk: do ##=1

parse var @ _ (xk) @

if _=='' & @=="" then leave

tx.## = _

Line 565:

Line 575:

call sound word(?.bf, jb_), word(word(?.bd,jb_) .2,1)

end /*jb_*/

end /*jb */

return

Line 622:

Line 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:

Line 688:

else _=$scale(?.ruler 'RULE' _ 'Q')

parse var _ _.1 '9'x _.2 '9'x _.3

do jk=1 for 3

Line 689:

Line 698:

/*──────────────────────────────────MS subroutine───────────────────────*/

ms: #ms=#ms+1 /*justification and indentation. */

parse arg _i

select

Line 711:

Line 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:

Line 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:

Line 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:

Line 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:

Line 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 | ,

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 sw(),1)) / ~~word(1~~ ~~2,m+1)substr~~(_,2)

if \datatype(_,"N") then interpret '_='translate(_,"%",'/')

if ~~\datatype(_,"N")~~ ~~then~~ ~~interpret~~ '_=~~'translate(~~_~~,"%",'/')~~

?.z = _

~~?.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'='

if L\=='' then if _<L | _>H then call er 81,L H _ "value for option ."z'='

return _

/*──────────────────────────────────WR subroutine───────────────────────*/

wr: parse arg 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:

Line 887:

call lineout ?.f /*close the file. */

return

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)

⚫

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>

/*═════════════════════════════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