LineEDitor
From Pickwiki
Back to BasicSource
My version of Unidata's AE that was written to cope with a move to Universe when we were relying on AE's security capabilities. This has a few extra things like an embedded full-page editor and search and change histories. The original source code (version 1.03) was released to public domain by Public Trust of New Zealand as a way of thanking the Pick community for assistance given over the years.
https://sites.google.com/site/nzpickie/home/programs
program led
* This editor reproduces the UniData Alternate Editor for QM/U2
* The code is based on LED, a line editor released into
* the public domain by Public Trust of New Zealand.
* Written by Keith Robert Johnson.
*====================================================================
* Version information
* 2.00 - Simplified code - No longer supporting R83
* Downcased the source to comply with QM standards.
*====================================================================
$define universe
$ifdef qm
$include err.h
voc = @voc
$else
open 'VOC' to voc else stop 201,'VOC'
$endif
$ifdef universe
$options information
$endif
$ifdef unidata
$basictype 'U'
$endif
* INITIALISE
prompt ''
am = char(254); vm = char(253); sm = char(252)
true = 1 = 1; false = not(true); qt = '"\':"'"
common /led$data/ edkeep,secure,kept
equ cellsize to 100
dim memr(1)
* List of verbs for viewing data only
viewverb = 'VIEW':am:'BROWSE':am:'LOOK'
* XCOM data - YES this editor will do $commands like AE does
dim junk(100)
equ this to junk(1)
equ item to junk(2)
equ here to junk(3)
equ x$cc to junk(11)
equ comi to junk(13)
equ comd to junk(14)
equ last to junk(15)
equ comdmark to junk(19)
equ wordmark to junk(20)
equ fnam to junk(24)
equ xsep to junk(25)
mat junk = ''
xsep = ' '
wordmark = ' '
comdmark = '`'
* Local data
begn = @(0) ; ceop = @(-3) ; ceol = @(-4) ; goup = @(-10)
revb = @(-13) ; revf = @(-14) ; undb = @(-15) ; undf = @(-16)
heap = false ; salt = '' ; rlen = 0
plen = system(3)-1 ; pwin = plen-1 ; line = '' ; here = 0
dim fr(10) ; mat fr = '' ; fr(3) = 'MCU'
oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = '' ; oopk = ''
join = '' ; nill = '' ; fold = ''
macn = 0 ; macc = ''
pick = '' ; lastfind = '' ; huge = 99999999
* Turn off page prompt
test = @(0,0)
* Find Match words - a LOOP can have multiple WHILE and UNTIL conditions
fm.words = '' ; fm.findf = '' ; fm.finda = ''
fm.words<1> = 'END' ; fm.findf<1> = 'END'
fm.finda<1> = 'IF':vm:'END':vm:'OPEN':vm:'OPENSEQ':vm:'BEGIN':vm:'LOCATE'
fm.words<2> = 'LOOP' ; fm.findf<2> = 'REPEAT':vm:'UNTIL':vm:'WHILE'
fm.words<3> = 'UNTIL'; fm.findf<3> = fm.findf<2>
fm.finda<3> = 'LOOP':vm:'UNTIL':vm:'WHILE'
fm.words<4> = 'WHILE'
fm.findf<4> = fm.findf<2>; fm.finda<4> = fm.finda<3>
fm.words<5> = 'FOR' ; fm.findf<5> = 'NEXT'
fm.words<6> = 'NEXT' ; fm.finda<6> = 'FOR'
fm.words<7> = 'BEGIN' ; fm.findf<7> = 'END CASE':vm:'CASE'
fm.words<8> = 'CASE' ; fm.findf<8> = 'CASE':vm:'END CASE'
fm.finda<8> = 'BEGIN CASE':vm:'CASE'
fm.words<9> = 'LOCKED' ; fm.findf<9> = 'END'
fm.finda<9> = 'READU':vm:'READVU':vm:'MATREADU'
fm.words<10> = 'REPEAT' ; fm.finda<10> = fm.finda<3>
* Special for C code
fm.words<11> = '{' ; fm.findf<11> = '}'
fm.words<12> = '}' ; fm.finda<12> = '{'
*
endwords = 'IF\OPEN\OPENSEQ\READNEXT\READ\READU\READV\READVU\'
endwords := 'MATREAD\MATREADU\LOCATE'
convert '\' to am in endwords
* page editor stuff
botl = system(3) - 2; clpg = @(-1)
* bell = char(7) ; span = system(2)
bell = @sys.bell ; span = system(2)
bott = @(0,system(3)-1):ceol
* Define key activity numbers - 22 keys defined
equ uarr to 1, darr to 2, larr to 3, rarr to 4
equ upag to 5, dpag to 6, lpag to 7, rpag to 8
equ tpag to 9, bpag to 10
equ escp to 11, phlp to 12, zoom to 13
equ delc to 14, dell to 15, delr to 16
equ back to 17, carr to 18, togg to 19, writ to 20
equ skey to 21, rkey to 22
* Set up the keys - In QM we can use generic key mapping (YAY)
* but I also like to have default keys
acts = '' ; keys = ''
* Arrow keys
acts<-1> = uarr ; keys<-1> = char(205)
acts<-1> = uarr ; keys<-1> = char(26)
acts<-1> = darr ; keys<-1> = char(206)
acts<-1> = darr ; keys<-1> = char(10)
acts<-1> = larr ; keys<-1> = char(203)
acts<-1> = larr ; keys<-1> = char(21)
acts<-1> = rarr ; keys<-1> = char(204)
acts<-1> = rarr ; keys<-1> = char(6)
* Page movement keys
acts<-1> = upag ; keys<-1> = char(207)
acts<-1> = upag ; keys<-1> = char(16)
acts<-1> = dpag ; keys<-1> = char(208)
acts<-1> = dpag ; keys<-1> = char(14)
acts<-1> = lpag ; keys<-1> = char(209)
acts<-1> = lpag ; keys<-1> = char(1)
acts<-1> = rpag ; keys<-1> = char(210)
acts<-1> = rpag ; keys<-1> = char(5)
acts<-1> = tpag ; keys<-1> = char(214)
acts<-1> = tpag ; keys<-1> = char(20)
acts<-1> = bpag ; keys<-1> = char(215)
acts<-1> = bpag ; keys<-1> = char(2)
* delete character, line, and delete to end of line keys
acts<-1> = delc ; keys<-1> = char(212)
acts<-1> = delc ; keys<-1> = char(4)
acts<-1> = dell ; keys<-1> = char(216)
acts<-1> = dell ; keys<-1> = char(127)
acts<-1> = dell ; keys<-1> = char(24)
acts<-1> = delr ; keys<-1> = char(217)
acts<-1> = delr ; keys<-1> = char(11)
acts<-1> = delr ; keys<-1> = char(18) ;* for Wyse terminals
* backspace and carriage return keys
acts<-1> = back ; keys<-1> = char(008)
acts<-1> = carr ; keys<-1> = char(013)
* escape, help, Go to line, toggle insert/overwrite mode, save keys
acts<-1> = escp ; keys<-1> = char(027)
acts<-1> = escp ; keys<-1> = char(017)
acts<-1> = phlp ; keys<-1> = char(128)
acts<-1> = zoom ; keys<-1> = char(007)
acts<-1> = togg ; keys<-1> = char(211)
acts<-1> = togg ; keys<-1> = char(009)
acts<-1> = writ ; keys<-1> = char(129)
acts<-1> = writ ; keys<-1> = char(023)
* search key, reverse search key
acts<-1> = skey ; keys<-1> = char(130) ;* F3 for search
acts<-1> = rkey ; keys<-1> = char(166) ;* shift-F3 for reverse search
mode = 'LINE'
* The saved stuff
pres = '' ; look = '' ; stak = ''
wild = false ; shew = false
chan = '' ; olda = '' ; cmat = '' ; mmat = ''
caseflag = false ; spaceflag = true ; blockflag = true
* Save the standard defaults in the session variable if it's not set
$ifdef universe
if unassigned(edkeep) then edkeep = '0'
$else
if assigned(edkeep) else edkeep = '0'
$endif
if edkeep eq '0' then
edkeep = pres:am:look:am:stak:am:wild:am:chan:am:olda:am:shew
edkeep := am:cmat:am:mmat:am:not(caseflag):am:not(spaceflag)
edkeep := am:not(blockflag)
kept = ''
end
* Get the 'as-is' settings from the session variable
pres = edkeep<1>
look = edkeep<2>
stak = edkeep<3>
wild = edkeep<4> ; wild = not(not(wild))
chan = edkeep<5>
olda = edkeep<6>
shew = edkeep<7> ; shew = not(not(shew))
cmat = edkeep<8>
mmat = edkeep<9>
caseflag = not(edkeep<10>)
spaceflag = not(edkeep<11>)
blockflag = not(edkeep<12>)
* Get forced default flags
!&&&
! nick = true
!&&&
read temp from voc, '&ED.OPTIONS' then
line = upcase(trim(remove(temp, dlim)))
if line[1,1] eq 'X' then
loop
line = upcase(trim(remove(temp, dlim)))
begin case
case line[1,8] eq 'BLOCK ON'
blockflag = true
case line[1,9] eq 'BLOCK OFF'
blockflag = false
case line[1,7] eq 'CASE ON'
caseflag = true
case line[1,8] eq 'CASE OFF'
caseflag = true
case line[1,8] eq 'SPACE ON'
spaceflag = true
case line[1,9] eq 'SPACE OFF'
spaceflag = true
case line[1,7] eq 'SHOW ON'
shew = true
case line[1,8] eq 'SHOW OFF'
shew = true
end case
while dlim repeat
end
end
$ifdef universe
if unassigned(secure) then secure = '0'
$else
if assigned(secure) else secure = '0'
$endif
prepprog = '' ; prepflag = false
postprog = '' ; postflag = false
*********** UniData AE-style security start
$ifdef unidata
prepprog = getenv('PREPROG_AE_UDT')
$endif
$ifdef universe
execute 'ENV' capturing temp
xxno = dcount(temp,am)
for xx = 1 to xxno
line = temp<xx>
if field(line,'=',1) eq 'PREPROG_AE_UDT' then
prepprog = field(line,'=',2)
xxno = xx
end
next xx
$endif
$ifdef qm
* QM doesn't allow underscores in environmental variables, so
* this is the closest I can get to AE environmental variable name.
call !atvar(prepprog,'@PREPROG.AE.UDT')
$endif
* These next two tests are from the AE security documentation
* They may not be required, but you can set them up if you want
* if prepprog[1,3] eq 'AE_' then prepprog = ''
* if prepprog[len(prepprog)-2,3] ne '_AE' then prepprog = ''
if prepprog ne '' then prepflag = true
* The following security definitions mirror those of I_AE_SECURITY
* in UniData. I have only copied the functionality for SEC.SET
* being "NONE" (that is, this user cannot edit) and the general
* disabling of LOAD via the SEC.LOAD.FLG at first call to @PREPPROG;
* and inhibiting of file updates via subsequent @PREPPROG calls.
dim security(40)
equ sec.set to security(1) ;* set by preprog on very first call
* These fields are set in preprog
equ sec.read.flg to security(2) ;* read ok or not
equ sec.write.flg to security(3) ;* write ok or not
equ sec.delete.flg to security(4) ;* delete ok or not
equ sec.unload.flg to security(5) ;* unload ok or not
equ sec.load.flg to security(6) ;* load ok or not
equ sec.xeq.flg to security(7) ;* xeq ok or not
equ sec.xcom.flg to security(8) ;* xcoms ok or not
* the following 5 fields pass information to preprog & postprog,
equ sec.fn to security(9) ;* file name
equ sec.id to security(10);* record id
equ sec.dir.flg to security(11);* 1 if file is a directory
equ sec.newfile.flg to security(12);* 1 if new file name
equ sec.active.sel.flg to security(13);* 1 if select list is active
* this is how to make AE stop and return to calling program or ecl
equ sec.stop.flg to security(14);* set to 1 to force ae to stop
* for secondary calls to preprog; the first 3 cannot be changed
equ sec.call2.type to security(15);* 1 load, 2 unload
equ sec.fn2 to security(16);* second file - for load/unload
equ sec.id2 to security(17);* second id - for load or unload
equ sec.ok2.flg to security(18);* if 1, ok to load/unload
* 19-22 are used by postprog, which I have not implemented
equ sec.dict.flg to security(23) ;* 1 if fn is dict ...
equ sec.dict2.flg to security(24) ;* 1 if fn2 is dict ...
* field 25 is specific to UNIDATA AE, this and all other fields unused
* WARNING: preprog programs should not use the STOP or ABORT statements
* they should use the SEC.STOP.FLG to end nicely.
*********** UniData AE-style security end
* QM has it's own source control system depending on a callable program
* named SOURCE.CONTROL existing. It has the following fields
*
* DICT.FLAG - 'DICT' if a dictionary, otherwise ''
* FILE.NAME - name of file to be written
* RECORD.NAME - name of record to be written
* RECORD.DATA - the record to write
* CALLER - calling program identifier, I have used '3'
* WRITE.ALLOWED - 1 on call, returns 1 if write allowed and 0 otherwise
* UPDATED - 0 on call, returns 1 if RECORD.DATA is changed
source.control = false
$ifdef qm
if catalogued('SOURCE.CONTROL') then source.control = true
$else
* We can implement QM-style security if we want
if prepprog eq 'SOURCE.CONTROL' then source.control = true
$endif
if source.control then prepflag = false ; prepprog = ''
name = @logname
levl = @level
path = @path
term = @tty
whom = @userno
acct = @who
* This is to display unprintable characters safely
badc = char(255)
for xx = 0 to 31 ; badc := char(xx) ; next xx
for xx = 127 to 250 ; badc := char(xx) ; next xx
gudc = str('~',len(badc))
* eeePC does not distinguish between these
if index(upcase(system(7)),'EEEPC',1) then
badc := char(251):char(252):char(253); gudc := '[\]'
end else
badc := char(251):char(252):char(253)
gudc := char(179):char(178):char(185)
end
* The yes/no can be language independant!
yes = 'Yes' ; yes = upcase(trim(yes))
no = 'No' ; no = upcase(trim(no))
ny = '(':no[1,1]:'/':yes[1,1]:') >'
* Want to see these thing in a single page
presnumb = system(3)-2
if presnumb gt 20 then presnumb = 20
looknumb = presnumb; channumb = presnumb
* Want this to be no more than five pages
staknumb = (presnumb+1)*5+1
* Parse the command line - long way in before work starts, eh?
* Anything in brackets is an option - but we do not use them at all.
* "verb" is how this was called so it should work to call again
verb = ''
$ifdef qm
$include parser.h
call !parser(parser$reset, 0, @sentence, 0)
opts = false
options = ''
sentence = ''
loop
call !parser(parser$get.token, type, param, keyword)
until type eq parser$end do
begin case
case type eq 4 ; opts = true
case type eq 5 ; opts = false
case opts ; options<-1> = param
case 1 ; sentence<-1> = param
end case
repeat
$else
rest = @sentence
keepquot = false
gosub parse.rest
sentence = bite
temp = dcount(sentence,am)
options = sentence<temp>
if options[1,1] eq '(' then
options = field(field(options,'(',2),')',1)
sentence = delete(bite,temp,0,0)
end else options = ''
$endif
if options ne '' then options = ' (':options:')'
* The C option allows the user to build paragraphs
* using DATA statements to control the editor.
* Otherwise they are restricted to an interactive mode.
if index(upcase(options),'C',1)
then editpage = false
else editpage = true
if upcase(sentence<1>) eq 'RUN' then
verb = sentence<1>:' ':sentence<2>:' '
sentence = delete(sentence,1,0,0)
sentence = delete(sentence,1,0,0)
end
verb = verb:sentence<1>
sentence = delete(sentence,1,0,0)
* Check if a viewing verb has been used
* If so, we can turn off both security systems (I mope I'm right!)
* The security flags are set safe, and each command is tested
* individually, so I think it's pretty safe.
* FORMAT is still allowed, but no other change command.
viewflag = false ; view = 'edit'
locate(upcase(verb),viewverb;posn) then
viewflag = true
view = 'view'
source.control = false
prepflag = false
end
* OR, they used the V option
if index(upcase(options),'V',1) then
viewflag = true
view = 'view'
source.control = false
prepflag = false
end
* HELP location
help.def = '2.00'
help = ''
pagehelp = ''
fnam = sentence<1>
sentence = delete(sentence,1,0,0)
if upcase(fnam) eq 'DICT' then
fnam = 'DICT ':sentence<1>
sentence = delete(sentence,1,0,0)
end
idlist = sentence
if system(11) and idlist ne '' then
crt 'A select list was active, but specific ids were entered.'
crt 'Select list will be ignored.'
crt str('-',len('Select list will be ignored.'))
clearselect
end
open 'AE_COMS' to acom else
$ifdef qm
execute 'CREATE.FILE AE_COMS'
$else
execute 'CREATE.FILE AE_COMS 1 7'
$endif
open 'AE_COMS' to acom else stop 'Cannot open ':'AE_COMS'
test = @(0,0)
end
* Get file
loop
got.file = false
if fnam eq '' then
stub = 'File name? '
gosub get.rope; fnam = rope; crt
end
if fnam eq '' then stop
dprt = field(fnam,' ',1)
fprt = field(fnam,' ',2)
if fprt eq '' then fprt = dprt ; dprt = ''
open dprt, fprt to file then
got.file = true
end else
open upcase(dprt),upcase(fprt) to file then
got.file = true
end else
crt 'Cannot open ':'"':fnam:'"'
fnam = ''
end
end
until got.file do
repeat
if fileinfo(file,3) eq '4' then bleach = false else bleach = true
bleach = upcase(fileinfo(file,2))
if bleach[2] = 'BP' or bleach[7] = 'SFPROGS'
then bleach = false
else bleach = true
* Get the record
if idlist eq '*' then
idlist = ''
execute 'SELECT ':dprt:' ':fprt
test = @(0,0)
end
if system(11) then
eof = false
loop
readnext id else eof = true
until eof do
idlist<-1> = id
repeat
end
loop
killsign = false
if idlist eq '' then
stub = 'Record name? '
gosub get.rope; rest = rope ; crt
keepquot = false
gosub parse.rest
idlist = bite
bite = '' ; rest = ''
end
idcnt = dcount(idlist,am)
for id = 1 to idcnt until killsign
item = idlist<id>
gosub edit.item
next id
while killsign do
idlist = ''
repeat
edkeep = pres:am:look:am:stak:am:wild:am:chan:am:olda:am:shew
edkeep := am:cmat:am:mmat:am:not(caseflag):am:not(spaceflag)
edkeep := am:not(blockflag):am:lower(kept)
stop
* SUBROUTINES
* ***********
edit.item:
stopsign = false
here = 0 ; dnum = 0
beg = 0 ; fin = 0 ; krj = ''
crt
if idcnt gt 1 then crt '<':id:'/':idcnt:'> ':
if prepflag then
if secure eq '0' then
mat security = ''
sec.set = ''
call @prepprog(mat security)
if sec.set eq 'NONE' then stop
if sec.stop.flg then stop
secure = sec.set
end
mat security = ''
sec.set = secure
if sec.set then
sec.fn = fprt
sec.id = item
sec.dir.flg = fileinfo(file,3) = '4'
sec.newfile.flg = false
sec.active.sel.flg = false
sec.dict.flg = (dprt = 'DICT')
call @prepprog(mat security)
if sec.stop.flg then stop
if not(sec.read.flg) then return
end
end else
sec.stop.flg = false
sec.read.flg = true
sec.write.flg = true
sec.delete.flg = true
sec.xcom.flg = true
sec.unload.flg = true
sec.load.flg = true
sec.xeq.flg = true
sec.ok2.flg = true
* Apply the viewing flag
if viewflag then
crt 'VIEW ONLY - NO UPDATES ALLOWED'
sec.write.flg = false
sec.delete.flg = false
sec.xcom.flg = false
sec.unload.flg = false
sec.load.flg = false
sec.xeq.flg = false
sec.ok2.flg = false
end
end
readu this from file, item locked goto locked.record then
lock = true
carry.on:
gosub parse.record
crt 'Top of "':item:'" in "':fnam:'", ':last:' lines, ':len(this):' characters.'
end else
lock = true
this = ''
gosub parse.record
crt 'Top of new "':item:'" in "':fnam:'".'
end
orig = this
gosub get.lfmt
* Edit the record
loop
if mode<1> eq 'PAGE' then
pcol = rem(pchr-1,span)
prow = here+1-ptop
crt @(60,0):ceol:revb:mode<2>:revf:' ':fmt(here,'R#4'):
crt ',':fmt(pchr,'L#4'):
bite = temp[pchr,1]
if bite ne '' then crt ' (':seq(bite):')':
crt @(pcol,prow):
gosub get.page.comd
if mode eq 'LINE' then
crt bott:'Line Editor Mode':
if that ne this then
crt ' - CHANGES HAVE BEEN MADE':
oops = that ; oopc = 'PE'
oopl = savl<1> ; oopf = savl<2>
oopb = beg:am:fin ; oopk = krj
end
crt
that = ''
gosub display.line
end
end
if mode<1> eq 'LINE' then
* Get the command
if x$cc ne '' then
comi = x$cc<1>
x$cc = delete(x$cc,1,0,0)
end else
if mode<1> eq 'PAGE' then continue
if salt ne '' then
comi = salt<1,1,1>; del salt<1,1,1>
end else
stub = prmt:': '; heap = true
gosub get.rope; comi = rope; heap = false
end
if macn then macc<1,1,-1> = comi
end
gosub parse.command
if not(numb eq '' or numb matches '1N0N') then
crt ; gosub bad.command
continue
end
if comd eq '' then
gosub null.command
if comd eq '' then continue
end
* Save command to list
if comi ne '' and comi ne stak<1,1> and comd ne 'D' then
stak = insert(stak,1,1,0,comi)
stak = delete(stak,1,staknumb,0)
end
* Apply the command
if comd ne 'R' then crt
if comd matches '1N0N' then
here = comd
if here gt last then here = last
gosub display.line
continue
end
loop
redo = false
first = comd[1,1]
posn = index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',first,1)
on posn gosub a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
while redo do repeat
if stopsign then release file, item ; lock = false ; return
end
repeat
return
parse.command:
comi = trimf(comi)
dlim = oconv(oconv(comi,'MC/A'),'MC/N')[1,1]
if dlim eq '' then
rest = ''
comd = upcase(comi)
end else
posn = index(comi,dlim,1)
rest = comi[posn+1,huge]
comd = upcase(comi[1,posn-1])
end
temp = oconv(comd,'MCN')[1,1]
if temp ne '' then
temp = index(comd,temp,1)
numb = comd[temp,huge]
comd = comd[1,temp-1]
end else numb = ''
return
parse.line:
if line eq comdmark then line = ''
xx = 1
loop
temp = index(line,'^',xx)
while temp do
bite = line[temp,5]
if bite matches '"^^"3N' then
line = line[1,temp-1]:line[temp+1,len(line)]
xx += 1
end else
bite = bite[1,4]
if bite matches '"^"3N' then
line= line[1,temp-1]:char(bite[2,3]):line[temp+4,len(line)]
end else xx += 1
end
repeat
return
a: begin case
case comd eq 'A' ; * append
if viewflag then gosub viewonly ; return
if rest eq '' then rest = olda<1,1>
if rest eq '' then
crt 'No previous append command to repeat'
gosub bad.comd
return
end
olda = rest:vm:dlim
line = rest ; gosub parse.line ; rest = line
chng = 0 ; save = here ; savl = last
dnum = 1
gosub set.bounds
for here = dawn to dusk
gosub get.line
line = line:rest
if not(chng) then gosub savethis
memr(cell)<lnum> = line
chng += 1
if shew or dnum lt plen then gosub display.line
next here
here = dusk
if chng then
gosub reset.record
crt chng:' lines changed - now at ':here
end
case 1 ; gosub bad.command
end case
return
b: begin case
case comd eq 'B' and dlim eq '' ; * bottom
here = last ; gosub display.line
case index('\B\BD\BK\BR\BS\','\':comd:'\',1) ; * break line
if viewflag then gosub viewonly ; return
if rest eq '' then
crt 'The second field is empty.'
gosub bad.comd
return
end
chng = 0 ; save = here ; savl = last ; show = ''
gosub set.bounds
for here = dusk to dawn step -1
gosub get.line
posn = index(line,rest,1)
if posn then
left = line[1,posn-1]
temp = line[posn+len(rest),len(line)]
if temp ne '' or comd eq 'BS' then
begin case
case comd eq 'BD' ; line = left:rest
case comd eq 'BK' ; line = temp
case comd eq 'BR' ; line = temp:left:rest
case comd eq 'BS' ; line = temp:rest:left
case 1 ; line = left:rest
end case
memr(cell)<lnum> = line
show = insert(show,1,0,0,here)
numb += 1
chng += 1
if comd eq 'B' then
dusk += 1
last += 1
lnum += 1
line = temp
gosub insert.line
end
end
end
next here
if chng then
gosub savethis
gosub reset.record
zzno = dcount(show,am)
savl = 0 ; dnum = 1
for zz = 1 to zzno
here = show<zz> + savl
if shew or dnum lt plen then gosub display.line
if comd eq 'B' and zzno gt 1 then
here += 1
savl += 1
if shew or dnum lt plen then gosub display.line
end
next zz
show = ''
end
if comd eq 'B'
then here = dusk + numb - 2
else here = dusk
if here gt last then here = last
if chng then
crt 'Split ':numb:' records. Now at line ':here
end
gosub get.line
case index('\BC\BCD\BCK\BCR\BCS\','\':comd:'\',1) ; * Break @ Column
if viewflag then gosub viewonly ; return
posn = trim(field(rest,dlim,1))
if not(posn matches '1n0n') then
crt 'No column position given'
gosub bad.comd
return
end
chng = 0 ; save = here ; show = ''
gosub set.bounds
for here = dusk to dawn step -1
gosub get.line
if len(line) gt posn then
left = line[1,posn-1]
temp = line[posn+1,len(line)]
if temp ne '' or comd eq 'BCS' then
begin case
case comd eq 'BCD' ; line = left:rest
case comd eq 'BCK' ; line = temp
case comd eq 'BCR' ; line = temp:left:rest
case comd eq 'BCS' ; line = temp:rest:left
case 1 ; line = left:rest
end case
memr(cell)<lnum> = line
show = insert(show,1,0,0,here)
numb += 1
chng += 1
if comd eq 'BC' then
dusk += 1
last += 1
lnum += 1
line = temp
gosub insert.line
end
end
end
next here
if chng then
gosub savethis
gosub reset.record
zzno = dcount(show,am)
savl = 0 ; dnum = 1
for zz = 1 to zzno
here = show<zz> + savl
if shew or dnum lt plen then gosub display.line
if comd eq 'BC' and zzno gt 1 then
here += 1
savl += 1
if shew or dnum lt plen then gosub display.line
end
next zz
show = ''
end
if comd eq 'BC'
then here = dusk + numb - 2
else here = dusk
if here gt last then here = last
if chng then
crt 'Split ':numb:' records. Now at line ':here
end
gosub get.line
case comd eq 'BLEACH' ; * change BLEACH flag
rest = upcase(rest)
begin case
case rest eq 'ON' ; bleach = true
case rest eq 'OFF' ; bleach = false
case 1 ; bleach = not(bleach)
end case
if bleach
then crt 'Colours disabled'
else crt 'Colours enabled'
case comd eq 'BLOCK' ; * change BLOCK flag
rest = upcase(rest)
begin case
case rest eq 'ON' ; blockflag = true
case rest eq 'OFF' ; blockflag = false
case 1 ; blockflag = not(blockflag)
end case
if blockflag then
crt 'Verification of block actions enabled'
end else crt 'Verification of block actions disabled'
case 1 ; gosub bad.command
end case
return
c: begin case
case comd eq 'C' ; * change
if viewflag then gosub viewonly ; return
if numb eq '' and dlim eq '' then
comd = 'RA'
comi = 'RA1'
numb = 1
end
gosub change.command
case comd eq 'CAT' ; comd = 'J' ; redo = true
case comd eq 'CASE' ; * change casing flag for 'L'
rest = upcase(rest)
begin case
case rest eq 'ON' ; caseflag = true
case rest eq 'OFF' ; caseflag = false
case 1 ; caseflag = not(caseflag)
end case
if caseflag then
crt 'Searches are case-sensitive'
end else crt 'Searches are not case-sensitive'
case comd eq 'CD' ; * command delimiter display (change)
if dlim eq '' then
crt 'Command delimiter is ':
end else
temp = '`,;#$%&~|[]{}/"':"'"
if index(temp,dlim,1) then
comdmark = dlim
crt 'Command delimiter is ':
end else
crt dlim:' is not a valid command delimiter.'
crt 'Characters available for delimiters: ':temp
crt 'Characters reserved for other uses: \.*!?-+=^@<>_:'
crt 'Command delimiter is ':
end
end
if comdmark eq '"'
then crt "'":comdmark:"'"
else crt '"':comdmark:'"'
case comd eq 'CLEAR' ; * Clear the kept buffer
if kept eq ''
then crt 'Nothing in KEPT buffer'
else crt 'KEPT buffer cleared'
kept = ''
case comd = 'COPY' ; * copy to kept buffer
if comd eq upcase(comi) then
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd; return
end
rest = beg
numb = fin-beg+1
end
rest = trim(rest)
if numb eq '' then gosub parse.atts
if rest eq '' then rest = here
if not(rest matches '1N0N') or numb eq '' then
crt 'Formats are: "COPY" (from <> block) or "COPYn" or "COPYn/s" or "COPY/s/f".'
gosub bad.comd ; return
end
if numb lt 1 then
crt 'Nothing done - no lines selected.'
comi = ''; return
end
if numb gt last then
crt 'Nothing done - record does not have that many lines.'
comi = '' ; return
end
kept = field(this,am,rest,numb)
numb = dcount(kept,am)
if numb then crt numb:' lines copied to KEPT buffer starting at line ':rest
case comd eq 'CM' ; * changematch command
if viewflag then gosub viewonly ; return
if rest eq '' then
if cmat eq '' then
crt 'No previous ChangeMatch command to repeat.'
comi = ''
return
end else
dlim = cmat<1,1>
rest = cmat<1,2>
numb = cmat<1,3>
end
end
gosub changematch.command
case comd eq 'COL' ; * column display
temp = ''
for xx = 1 to 9
temp = temp:space(9):xx
next xx
if lfmt
then crt begn:space(llen+2):temp[1,span-llen-2]
else crt begn:temp[1,span]
temp = str('1234567890',10)
if lfmt
then crt begn:space(llen+2):temp[1,span-llen-2]
else crt begn:temp[1,span]
temp = ''
case comd eq 'COUNT' ; * show the count of a string
line = rest ; gosub parse.line ; rest = line
if rest eq '' then
crt 'No string given to count'
gosub bad.comd ; return
end
gosub set.bounds
if not(caseflag) then rest = upcase(rest)
temp = 0
for here = dawn to dusk
gosub get.line
if caseflag
then temp = temp + count(line,rest)
else temp = temp + count(upcase(line),rest)
next here
here = dusk
crt temp:' occurances of string.'
case comd eq 'CRT' ; * insert crt line for programmer
if viewflag then gosub viewonly ; return
if rest eq '' then
crt 'You have not said what to put on CRT line!'
comi = ''
return
end
gosub savethat
here += 1 ; last += 1 ; lnum += 1
if dlim ne '"' and dlim ne '\' then dlim = "'"
line = 'CRT ':dlim:rest:' = ':dlim:':':rest
gosub insert.line
gosub reset.record
gosub display.line
case comd eq 'CUT' ;* Move lines to kept buffer
if viewflag then gosub viewonly ; return
if comd eq upcase(comi) then
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd; return
end
rest = beg
numb = fin-beg+1
end
rest = trim(rest)
if numb eq '' then gosub parse.atts
if rest eq '' then rest = here
if not(rest matches '1N0N') or numb eq '' then
crt 'Formats are: "CUT" (from <> block) or "CUTn" or "CUTn/s" or "CUT/s/f".'
gosub bad.comd; return
end
if numb gt last then
crt 'Nothing done - record does not have that many lines.'
comi = '' ; return
end
kept = field(this,am,rest,numb)
numb = dcount(kept,am)
dawn = rest
dusk = rest+numb-1
gosub delete.lines
if numb then crt numb:' lines moved to KEPT buffer starting at line ':rest
case 1 ; gosub bad.command
end case
return
d: begin case
case comd eq 'D' ; * display current line
if here gt last then here = last
gosub display.line
case comd eq 'DE' ; * delete lines
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
if rest ne '' then
patt = rest
cto = ''
cfrom = 'DE'
gosub cm.del.entry
return
end
gosub set.bounds
gosub delete.lines
here = dawn
if here gt last then
here = last
crt 'Bottom. Line ':here:' was above the last delete.'
end else
crt 'At line ':here:'. Deleted ':chng:' lines.'
gosub display.line
end
$ifdef qm
case comd eq 'DISPLAY' ; * insert display line for programmer
if viewflag then gosub viewonly ; return
if rest eq '' then
crt 'You have not said what to put on DISPLAY line!'
comi = ''
return
end
gosub savethat
here += 1 ; last += 1 ; lnum += 1
if dlim ne '"' and dlim ne '\' then dlim = "'"
line = 'DISPLAY ':dlim:rest:' = ':dlim:':':rest
gosub insert.line
gosub reset.record
gosub display.line
$endif
case comd eq 'DROP' ; * remove the block
if viewflag then gosub viewonly ; return
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd ; return
end
if beg le 1 then
temp = 0
end else
temp = index(this,am,beg-1)
if not(temp) then
crt 'Error - Block start line not defined' ; *Cannot find beginning of block
gosub bad.comd ; return
end
end
if fin eq last then
temp -= 1
temp<2> = len(this)
end else
temp<2> = index(this,am,fin)
end
if not(temp<2>) then
crt 'Error - Block end line not defined' ; *Cannot find end of block
gosub bad.comd ; return
end
numb = fin - beg + 1
if blockflag then
if beg eq fin
then stub = 'Delete line ': beg:' '
else stub = 'Delete block from line ': beg:' to line ': fin:'? '
gosub get.answ
if answ ne yes[1,1] then
crt 'Block command cancelled.'
return
end
end
dawn = beg; dusk = fin
gosub delete.lines
crt 'Dropped (deleted) ':numb:' lines.'
gosub display.line
case comd eq 'DTX' ; * decimal to hex
if not(rest matches '1N0N') then
crt 'Numeric value required'
gosub bad.comd ; return
end
if len(rest) gt 9 then
crt 'Must be less than one billion (1,000,000,000)'
gosub bad.comd ; return
end
$ifdef universe
crt dtx(rest)
$else
crt oconv(rest,'MX')
$endif
case comd eq 'DUP' ; * duplicate previous line
if viewflag then gosub viewonly ; return
if here lt 1 then
crt 'No current line'
gosub bad.comd ; return
end
if numb eq '' and rest matches '1N0N' then numb = rest
if numb lt 1 then numb = 1
gosub savethat
gosub get.line
for xx = 1 to numb
gosub insert.line
last += 1
next xx
gosub reset.record
crt 'Inserted ':numb:' copies of line ':here:' after line ':here:'. Still at ':here:'.'
case 1 ; gosub bad.command
end case
return
e: begin case
case comd eq 'EC' ; * edit called program (in this file)
if here lt 1 then here = 1
gosub get.line
line = trim(line)
temp = upcase(line)
good = index(temp,'CALL ',1)
if good then line = trim(line[good+5,huge])
line = trim(field(line,'(',1))
if index(line,' ',1) then good = false
if line[1,1] eq '@' then
crt 'Leading "@" is logical pointer'
good = false
end
if not(good) then
crt 'The EC command requires lines in format "CALL ID" or "CALL ID(..."'
gosub bad.comd ; return
end
* readv temp from file, line, 1 else
* crt '"':line:'" is not in this file'
* gosub bad.comd ; return
* end
* execute verb:' ':fnam:' ':line
readv temp from file, line, 1 then
execute verb:' ':fnam:' ':line:options
end else
test = false
readv vlin from voc, line, 2 then
vcnt = dcount(vlin,'/')
vlin = field(vlin,'/',vcnt-1)
vlin = vlin[1,len(vlin)-2]
test = trans(vlin,line,-1,'X')
end
if test then
execute verb:' ':vlin:' ':line:options
end else
crt '"':line:'" is not in this file'
gosub bad.comd ; return
end
end
***
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
case comd = 'ECS' ; * edit command stack
ttid = whom:'_':levl:'_commands'
temp = raise(stak)
write temp on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing command stack'
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read temp from acom, ttid else temp = ''
temp = field(temp,am,1,staknumb-1)
stak = lower(temp)
delete acom, ttid
case comd eq 'EDITPAGE'
editpage = not(editpage)
*>
if editpage then
begn = @(0) ; goup = @(-10)
prmt = '*':str('-',llen-1)
end else
begn = char(13) ; goup = ''
prmt = str('-',llen)
end
crt 'editpage = ':editpage
*>
case comd eq 'EF' ; * edit fields
numb = numb + 0
if numb lt 0 or numb gt 255 then
crt numb:' is outside range 0-255'
comi = ''
return
end
vmrk = char(numb)
vals = 'char':numb
gosub edit.fields
vmrk = char(numb); gosub reset.fields
case comd eq 'EI' ; * edit included code
if here lt 1 then here = 1
gosub get.line
line = field(line,';',1)
line = trim(line)
good = true
temp = field(line,' ',1)
temp = upcase(temp)
if temp ne 'INCLUDE' and temp ne '$INCLUDE' then good = false
line = trim(line[len(temp)+1,len(line)])
begin case
case dcount(line,' ') gt 3 ; good = false
case dcount(line,' ') eq 3
if field(line,' ',1) ne 'DICT' then good = false
case dcount(line,' ') eq 1
readv test from file, line, 1 then
line = fnam:' ':line
end else
test = trans('SYSCOM',line,1,'X')
if test ne ''
then line = 'SYSCOM ':line
else line = fnam:' ':line
end
end case
if not(good) then
crt 'The EI command requires lines in format "$IN... {DICT} {FN} ID"'
gosub bad.comd ; return
end
execute verb:' ':line:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
case comd eq 'EIT' ; * edit i-types (@)
if dprt and here eq 2 and upcase(this[1,1]) else
crt 'EIT is only for line 2 of a dictionary I-type'
return
end
gosub get.line ; temp = line
gosub split.itype
ttid = whom:'_':levl:'_IType.in.line#':here
write bite on acom, ttid on error gosub writerr ; return
crt view:'ing IType as fields...':
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read line from acom, ttid else line = ''
delete acom, ttid
vmrk = ';'; gosub reset.fields
* case comd eq 'EM' ; * edit MESSAGES
* if numb eq '' and rest matches '1N0N' then numb = rest
* if numb then
* execute verb:' MESSAGES ':numb:options
* end else
* if here lt 1 then here = 1
* gosub get.line
* line = trim(line)
* temp = upcase(line)
* good = index(temp,'SYSMSG',1)
* if good then line = trim(line[good+6,huge])
* line = trim(field(line,'(',2))
* line = trim(field(field(line,')',1),',',1))
* if not(line matches '1N0N') then good = false
* if not(good) then
* crt 'The EM command requires lines in format "...sysmsg(1N0N..."'
* crt 'Or a command like EMnnnn (nnnn is a message number)'
* gosub bad.comd ; return
* end
* execute verb:' MESSAGES ':line:options
* end
* test = @(0,0)
* crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
case comd = 'EK' ; * edit kept buffer
ttid = whom:'_':levl:'_keptbuffer'
write kept on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing kept buffer':
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read kept from acom, ttid else kept = ''
delete acom, ttid
case comd = 'EPR' ; * edit prestores
numb = numb + 0
if numb lt 0 or numb gt presnumb then
crt 'PRestore must be in range 1-':presnumb:'.'
gosub bad.comd ; return
end
ttid = whom:'_':levl:'_prestores'
temp = raise(pres)
if numb then
bite = raise(temp<numb>)
write bite on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing prestore ':view:
end else
write temp on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing prestores':
end
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
if numb then
read bite from acom, ttid else bite = ''
temp<numb> = lower(bite)
end else
read temp from acom, ttid else temp = ''
end
pres = lower(temp)
delete acom, ttid
case comd = 'ESS' ; * edit search stack
ttid = whom:'_':levl:'_searches'
temp = raise(look)
write temp on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing search stack':
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read temp from acom, ttid else look = ''
look = lower(temp)
delete acom, ttid
case comd eq 'ESV' ; * edit subvalues
vmrk = sm ; vals = 'subvalues'
gosub edit.fields
vmrk = sm; gosub reset.fields
case comd eq 'ET' ; * edit tabs
ttid = whom:'_':levl:'_tabs'
xxno = dcount(krj<1>,@vm)
temp = ''
for xx = 1 to xxno
temp<xx> = krj<2,xx>:' ':krj<1,xx>
next xx
write temp on acom, ttid on error crt 'WRITE failure - file not updated' ; return
crt view:'ing line tabs':
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read temp from acom, ttid else temp = ''
xxno = dcount(temp,@am)
krj = @am:@am:krj<3>
yy = ''
for xx = 1 to xxno
bite = trim(temp<xx,1,1>)
left = field(bite,' ',1)
rest = field(bite,' ',2,99)
if left matches '1N0N' then left += 0 else left = 0
if left gt last then left = 0
if left then
yy += 1
if rest eq '' then rest = 'T':left
krj<1,yy> = rest
krj<2,yy> = left
end
next xxno
if krj<3> gt yy then krj<3> = yy
if krj<1> ne '' and krj<3> lt 1 then krj<3> = 1
delete acom, ttid
case comd eq 'EV' ; * edit values
vmrk = vm ; vals = 'values'
gosub edit.fields
vmrk = vm; gosub reset.fields
case comd eq 'EW' ; * edit words (as defined by wordmark)
vmrk = wordmark ; vals = 'words'
gosub edit.fields
vmrk = wordmark; gosub reset.fields
* Various forms for quitting
case comd eq 'EX' or comd = 'EXIT' ; comd = 'Q' ; redo = true
case comd eq 'EXK' or comd = 'EXITK' ; comd = 'QK' ; redo = true
case 1 ; gosub bad.command
end case
return
f: begin case
case comd eq 'FD' ; * delete item
if viewflag then gosub viewonly ; return
if not(sec.delete.flg) then
crt 'Delete disabled'
comi = ''
return
end
gosub write.record
case comd eq 'FILE' ; comd = 'SV' ; redo = true
case comd[1,2] eq 'FI' ; * file item
if viewflag then gosub viewonly ; return
if not(sec.write.flg) then
crt 'File disabled'
comi = ''
return
end
temp = comd[3,len(comd)]
convert 'BCRDL' to '' in temp
if temp eq '' then gosub write.record else gosub bad.command
case comd eq 'FL' or comd eq 'FLA' ; * find labels
if not(caseflag) then rest = upcase(rest)
if index(comd,'A',1) then
bump = -1
dawn = here - 1
if dawn lt 1 then return
if numb then dusk = here - numb else dusk = 1
if dusk lt 1 then dusk = 1
end else
bump = 1
dawn = here + 1
if dawn gt last then dawn = 1
if numb then dusk = dawn + numb else dusk = last
if dusk gt last then dusk = last
end
for here = dawn to dusk step bump
gosub get.line
gosub find.label
if not(caseflag) then temp = upcase(temp)
if temp ne '' then
if rest eq '' or temp matches rest then
gosub display.line
if not(numb) then return
end
end
next here
crt
gosub display.line
case comd eq 'FM' or comd eq 'FMA' ; * find match command
gosub get.line
* Get rid of any label
gosub find.label
thisline = trimf(line)
if temp ne '' then
thisline = thisline[len(temp)+1,huge]
if thisline[1,1] eq ':' then thisline = thisline[2,huge]
thisline = trimf(thisline)
end
* Get the first word on the line
word = field(trim(upcase(thisline)),' ',1)
begin case
case rest ne ''
seek = upcase(rest)
case word[1,1] eq '*' or word[1,1] eq '!'
seek = word[1,1]
case 1
locate(word,fm.words;posn) then
if index(comd,'A' ,1) then
seek = fm.finda<posn>
end else
seek = fm.findf<posn>
end
end else
locate(word,endwords;posn) then
seek = 'END'
end else
crt 'Starting word "':word:'" unknown'
gosub bad.comd ; return
end
end
end case
if seek eq '' then
crt word:' has no matching word for ':comd
gosub bad.comd ; return
end
posn = index(upcase(line),word,1)
xxno = dcount(seek,vm)
for xx = 1 to xxno
seek<1,xx> = space(posn-1):seek<1,xx>
next xx
if index(comd,'A',1) then
bump = -1
dawn = here - 1
if dawn lt 1 then return
dusk = 1
end else
bump = 1
dawn = here + 1
if dawn gt last then return
dusk = last
end
save = here
for here = dawn to dusk step bump
gosub get.line
line = upcase(line)
if line[1,1] ne '' then
temp = field(line,' ',1)
if num(temp) or temp[len(temp),1] eq ':' then
temp = len(temp)
line = space(temp):line[temp+1,len(line)]
end
end
for xx = 1 to xxno
slen = len(seek<1,xx>)
if line[1,slen] eq seek<1,xx> then
if trim(line[slen+1,1]) eq '' then
gosub display.line
return
end
end
next xx
next here
here = save
gosub get.line
case comd eq 'FOLD' ; * fold the line
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
if dlim ne '' then fold = ''
if rest eq '' then rest = fold
if rest eq '' then rest = span-llen-2
if not(rest matches '1N0N') then
crt 'Non-numeric length - try HELP FOLD.'
comi = ''
return
end
fold = rest
gosub get.line
crt 'FOLD line to length ':fold
bite = line
gosub parse.bite
gosub check.line
if chng then gosub reset.record
case comd eq 'FOR' or comd eq 'FORMAT' ; * format this item
rest = upcase(rest)
temp = index(rest,'-M',1)
if temp then fr(1) = field(rest[temp+2,huge],' ',1) ; fr(2) = ''
if not(fr(1) matches '1N0N') then fr(1) = ''
if fr(1) eq '' then
temp = this<1>
fr(1) = len(temp) - len(trimf(temp))
end
temp = index(rest,'-I',1)
if temp then fr(2) = field(rest[temp+2,huge],' ',1)
if not(fr(2) matches '1N0N') then fr(2) = ''
if fr(2) eq '' then
fr(2) = int((fr(1)+1)/2)
if fr(2) lt 2 then fr(2) = 2
end
if index(rest,'-A',1) then fr(9) = true else fr(9) = ''
if index(rest,'-N',1) then fr(10) = true else fr(10) = ''
if index(rest,'-C',1) then
fr(1) = 0
fr(2) = 1
fr(9) = true
fr(10) = true
end
if last lt 1 then return
gosub savethat
crt 'Margin=':fr(1):', Indentation=':fr(2)
gosub indenter
gosub set.record
case 1 ; gosub bad.command
end case
return
g: begin case
case comd eq 'G' ; * Go to line
if numb eq '' then
if dlim eq '<' and beg ne '' then here = beg
if dlim eq '>' and fin ne '' then here = fin
end else here = numb
if here gt last then here = last
gosub display.line
case 1 ; gosub bad.command
end case
return
h: begin case
case comd eq 'H' or comd eq 'HELP'
gosub show.help
case comd eq 'HEX' ; * show this line in hexadecimal
if not(here) then return
gosub get.line
temp = ''
xxno = len(line)
for xx = 1 to xxno
bit = line[xx,1]
$ifdef universe
bit = dtx(seq(bit))
$else
bit = oconv(seq(bit),'MX')
$endif
$ifdef unidata
bit = fmt(bit,'2/0R')
$else
bit = fmt(bit,'R%2')
$endif
temp<1> = temp<1>:bit[1,1]
temp<2> = temp<2>:bit[2,1]
next xx
if lfmt then crt fmt(here,lfmt):': ':
crt temp<1>
if lfmt then crt space(llen+2):
crt temp<2>
temp = ''
case 1 ; gosub bad.command
end case
return
i: begin case
case comd eq 'I' ; * insert lines
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
if rest ne '' then
if numb lt 1 then numb = 1
inum = numb
gosub get.line
if not(chng) then gosub savethis
if here gt 0 then
memr(cell)<lnum> := str(am:rest,inum)
end else memr(1)<1> = str(rest:am,inum):memr(1)<1>
if here le beg then beg += inum
if here le fin then fin += inum
yyno = dcount(krj<1>,vm)
for yy = 1 to yyno
if krj<2,yy> gt here then krj<2,yy> += inum
next yy
here = here + inum
gosub reset.record
gosub get.line
gosub display.line
crt 'At line ':here:'. ':inum:' lines inserted, bottom now at line ':last:'.'
end else
if nill ne '' then
crt 'Terminate input with "':nill:'"'
end
!&&&
! if nick then gosub get.line
!&&&
loop
!&&&
! if nick
! then pill = space(len(line)-len(trimf(line)))
! else pill = ''
! pick = pill
! pill := nill
!&&&
new1 = here + 1
stub = new1:'='
if lfmt then stub = fmt(new1,lfmt):'='
gosub get.rope; line = rope
!&&&
until line eq nill do
! until line eq nill or line eq pill do
!&&&
gosub parse.line
last += 1
here += 1
lnum += 1
if not(chng) then gosub savethis
chng += 1
gosub insert.line
temp = len(last)
if lfmt then
if temp gt 3 and temp ne llen then gosub get.lfmt
end
if line eq nill then
crt begn:
if lfmt then crt fmt(new1,lfmt):'= ':
end
crt
numb -= 1
if numb eq 0 then exit
repeat
crt begn:ceol:
end
if chng then gosub reset.record
case comd eq 'IC' ; * iconv
if viewflag then gosub viewonly ; return
if rest eq '' then
crt 'No conversion given'
gosub bad.comd ; return
end
ccom = '*':rest ; gosub conv.command
case comd eq 'IN' ; * insert from execute
if viewflag then gosub viewonly ; return
if trim(rest) eq '' then
crt 'No external command given'
comi = '' ; return
end
execute rest capturing bite
test = @(0,0)
numb = dcount(bite,am)
if numb then
gosub savethat
this = insert(this,here+1,0,0,bite)
gosub set.record
crt 'Inserted ':numb:' lines; still at line ':here:'.'
end else
crt 'Nothing done - no output from command.'
comi = '' ; return
end
case 1 ; gosub bad.command
end case
return
j: begin case
case comd eq 'J' ; * join lines
if viewflag then gosub viewonly ; return
if dlim ne '' then
line = rest ; gosub parse.line ; join = line
end
if here and here lt last then
chng = 0 ; save = here ; savl = last
gosub get.line
test = line
here += 1
gosub set.bounds
for here = dawn to dusk
gosub get.line
test = test:join:line
next here
gosub delete.lines
if chng eq 0 then return
here = save
oopl = here
gosub get.line
memr(cell)<lnum> = test
gosub reset.record
end
gosub display.line
case 1 ; gosub bad.command
end case
return
k: begin case
case comd eq 'KEEP' or comd eq 'KEEPA'
gosub get.load
if temp eq '' then return
if comd[len(comd),1] ne 'A' then
gosub get.lines
if not(temp) then return
end
kept = temp
temp = dcount(temp,am)
crt 'At line ':here:', ':temp:' lines loaded into kept buffer.'
temp = ''
case comd eq 'KEPT' or comd eq 'K' ; * display kept
xxno = dcount(kept,am)
if xxno lt 1 then
crt 'Nothing in KEPT buffer'
return
end
bit = len(xxno)
disp = '***** Contents of KEPT buffer (':xxno:' lines) *****'
stub = 'Press return to continue showing KEPT buffer, Q to quit'
for xx = 1 to xxno
temp = oconv(kept<xx>,'MCP')[1,wide-bit-1]
disp<-1> = fmt(xx,'R#':bit):':':temp
next xx
gosub show.disp
case 1 ; gosub bad.command
end case
return
l: begin case
case index('\L\LN\LA\LNA\LAN\','\':comd:'\',1) ; * list or locate
if upcase(comi) eq 'L' then
if look<1,1> eq '' then
crt 'No previous locate command to repeat.'
comi = ''
return
end
comi = look<1,1>
gosub parse.command
if comd eq '' then comd = 'L' ; numb = huge
redo = true
return
end
finder = ''
seeker = dlim
if seeker eq '!' or seeker eq '&' then
finder = rest
convert dlim to am in finder
if finder<2> eq '' then finder = '' else rest = finder<1>
end
looper = dcount(finder,am)
if rest ne '' then
gosub parse.cols
if not(good) then return
end else
if dlim ne '' then
crt 'The second field is empty.'
gosub bad.comd ; return
end
cols = ''
end
if index(comd,'A',1) then
bump = -1
dawn = here - 1
if dawn lt 1 then dawn = 1
if numb then dusk = here - numb + 1 else dusk = 1
if dusk lt 1 then dusk = 1
end else
bump = 1
dawn = here + 1
if dawn gt last then dawn = 1
if numb then dusk = dawn + numb - 1 else dusk = last
if dusk gt last then dusk = last
end
if looper then rest = finder else looper = 1
line = rest ; gosub parse.line ; rest = line
lastfind = rest<1>
if not(caseflag) then rest = upcase(rest)
if spaceflag else convert ' ':char(9) to '' in rest
for here = dawn to dusk step bump
gosub get.line
if cols then line = line[cols,colf]
if caseflag then temp = line else temp = upcase(line)
if spaceflag else convert ' ':char(9) to '' in temp
badder = false ; gooder = false
for xx = 1 to looper
if index(temp,rest<xx>,1)
then gooder = true
else badder = true
next xx
if seeker eq '&' then gooder = not(badder)
if gooder then
if not(index(comd,'N',1)) then
gosub display.line
if not(numb) then exit
end
end else
if index(comd,'N',1) then
gosub display.line
if not(numb) then exit
end
end
next here
if numb then here = dusk
crt 'Now at line ':here:
if here eq last then crt ' (bottom)':
crt '.'
if rest ne '' and comi ne '' and comi ne look<1,1> then
look = insert(look,1,1,0,comi)
look = field(look,vm,1,looknumb)
end
case comd eq 'LC' ; * lower case (make line in)
if viewflag then gosub viewonly ; return
if rest eq '' then ccom = 'MCL' else ccom = 'QMCL'
gosub conv.command
* Various forms for loading stuff
case comd eq 'LD' or comd eq 'LOAD' or comd eq 'LDA' or comd eq 'LOADA'
if viewflag then gosub viewonly ; return
if not(sec.load.flg) then
crt 'LOAD disabled'
comi = ''
return
end
gosub get.load
if temp eq '' then return
if prepflag then
sec.call2.type = 1
sec.fn2 = ofpt
sec.id2 = oipt
sec.dict2.flg = (odpt = 'DICT')
call @prepprog(mat security)
if sec.stop.flg then stop
if not(sec.ok2.flg) then
gosub bad.comd ; return
end
end
if comd[len(comd),1] ne 'A' then
gosub get.lines
if not(temp) then return
end
gosub savethat
this = insert(this,here+1,0,0,temp)
temp = dcount(temp,am)
here = here + temp
crt 'At line ':here:', ':temp:' lines loaded.'
temp = ''
gosub set.record
case comd eq 'LL' ; * long lines
if not(rest matches '1N0N') then
rest = span-llen-2
crt 'LL':numb:'/':rest
end
dawn = here + 1
if dawn gt last then dawn = 1
if numb then dusk = here + numb else dusk = last
if dusk gt last then dusk = last
for here = dawn to dusk
gosub get.line
temp = trim(line[rest,huge])
if temp ne '' then
gosub display.line
if not(numb) then return
end
next here
crt
gosub display.line
case 1 ; gosub bad.command
end case
return
m: begin case
case comd eq 'M' ; * pattern matching
rest = field(rest,dlim,1)
if rest eq '' and mmat ne '' then
dlim = mmat<1,1>
rest = mmat<1,2>
end
if rest eq '' then
crt 'No pattern given to match'
return
end
gosub changematch.command
case comd eq 'MACRO'
if macn then
temp = dcount(macc<1,1>,sm)
macc = delete(macc,1,1,temp)
macc = delete(macc,1,1,temp)
if macc ne '' then
pres<1,macn> = macc<1,1>
crt 'Macro saved to PRestore ':macn
end else
crt 'Macro empty - not saved'
end
macc = ''
macn = 0
end else
if numb eq '' then numb = 1
if numb gt presnumb or numb lt 1 then
crt 'PRestore must be in range 1-':presnumb:'.'
comi = ''
return
end
crt 'Macro being recorded for PRestore ':numb
macn = numb
end
case comd eq 'MERGE' or comd eq 'ME' ; * merge stuff
if viewflag then gosub viewonly ; return
if rest eq '' and numb eq '' then
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd
return
end
numb = fin - beg + 1
if blockflag then
if beg eq fin
then stub = 'Copy line ':beg:' to under line ':here:'? '
else stub = 'Copy lines ':beg:'-':fin:' to under line ':here:'? '
gosub get.answ
if answ ne yes[1,1] then
crt 'Block command cancelled.'
return
end
end
dlim = ' '
rest = beg:' ':fin
numb = ''
end
rest = trim(rest)
if numb eq '' then gosub parse.atts
if numb ne '' and rest eq '' then rest = here
if not(rest matches '1N0N') or numb eq '' then
crt 'Format of MErge command is: "MEn/s"; eg: "ME10/15" or "ME/s/f"; eg: "ME/15/24"'
gosub bad.comd ; return
end
* if numb gt last then
* crt 'Nothing done - record does not have that many lines.'
* comi = '' ; return
* end
bite = field(this,am,rest,numb)
if numb ne 1 or bite ne '' then numb = dcount(bite,am)
if numb then
gosub savethat
this = insert(this,here+1,0,0,bite)
gosub set.record
if beg gt here then beg = beg + numb
if fin gt here then fin = fin + numb
xxno = dcount(krj<1>,vm)
for xx = 1 to xxno
if krj<2,xx> gt here then krj<2,xx> += numb
next xx
crt 'Merged ':numb:' lines starting at line ':rest:'; still at line ':here:'.'
end else
crt 'Nothing done - this line is within the range.'
comi = '' ; return
end
case comd eq 'MOVE' or comd eq 'MV' ; * move stuff
if viewflag then gosub viewonly ; return
if rest eq '' then
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd
return
end
if here le fin and here ge beg then
crt 'A block may not be moved into itself. MERGE will work.'
comi = ''
return
end
numb = fin - beg + 1
if blockflag then
if beg eq fin then
stub = 'Move line ':beg:' to after line ':here:' OK? ':ny
end else
stub = 'Move lines ':beg:'-':fin:' to after line ':here:' OK? ':ny
end
gosub get.answ
if answ ne yes[1,1] then
crt 'Block command cancelled.'
return
end
end
dlim = ' '
rest = beg:' ':fin
numb = ''
end
rest = trim(rest)
if numb eq '' then gosub parse.atts
if not(rest matches '1N0N') or numb eq '' then
crt 'Format of MoVe command is: "MVn/s"; eg: "MV10/15" or "MV/s/f"; eg: "MV/15/24"'
gosub bad.comd ; return
end
dusk = rest + numb - 1
if dusk gt last then dusk = last
if here ge rest and here le dusk then
crt 'Nothing done - this line is within the range.'
comi = '' ; return
end
bite = field(this,am,rest,numb)
numb = dcount(bite,am)
if numb then
gosub savethat
if here gt dusk then
this = insert(this,here+1,0,0,bite)
if rest gt 1
then this = this[1,col1()-1]:this[col2(),len(this)]
else this = this[col2()+1,len(this)]
end else
this = this[1,col1()-1]:this[col2(),len(this)]
this = insert(this,here+1,0,0,bite)
end
gosub set.record
if here gt dusk then
here = here - numb
crt 'Moved ':numb:' lines starting at line ':rest:'; now at line ':here:'.'
end else
crt 'Moved ':numb:' lines starting at line ':rest:'; still at line ':here:'.'
end
!##############
posn = beg; gosub recalc.posn; beg = posn
posn = fin; gosub recalc.posn; fin = posn
xxno = dcount(krj<1>,vm)
for xx = 1 to xxno
posn = krj<2,xx>; gosub recalc.posn; krj<2,xx> = posn
next xx
end else
crt 'Nothing done - no lines selected.'
comi = '' ; return
end
case 1 ; gosub bad.command
end case
return
n: begin case
case comd eq 'N' ; * same as "+"
if numb eq '' then numb = 1
here = here + numb
if here gt last then here = last
gosub display.line
case comd eq 'NULL' ; * null line input definition
dlim = trim(dlim):trim(rest)
dlim = dlim[1,1]
nill = dlim
if nill eq '"' then
bit = "'":nill:"'"
end else bit = '"':nill:'"'
crt 'NULL character to terminate INSERT is ':bit:'.'
comi = ''
case comd eq 'NUM' ; * toggle the line numbering
if lfmt eq '' then
crt 'Line Numbering is ON'
gosub get.lfmt
end else
crt 'Line Numbering is OFF'
lfmt = ''
end
case 1 ; gosub bad.command
end case
return
o: begin case
case comd eq 'OC' ; * oconv
if viewflag then gosub viewonly ; return
if rest eq '' then
crt 'No conversion given'
gosub bad.comd ; return
end
ccom = rest ; gosub conv.command
case comd[1,2] eq 'OO' ; * undo last change
if oopc ne '' then
this = oops
here = oopl
last = oopf
beg = oopb<1>
fin = oopb<2>
krj = oopk
gosub set.record
crt '"':oopc:'" undone - now at line ':here:'.'
oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = '' ; oopk = ''
gosub display.line
end else
crt 'last change already "undone" or nothing to undo'
end
comi = ''
case comd eq 'OUT'
gosub outline
case 1 ; gosub bad.command
end case
return
p: begin case
case comd eq 'P' ; * page on
if numb else numb = plen
if here ge last then here = 0
here += 1
gosub set.bounds
for here = dawn to dusk
gosub display.line
next here
here = dusk
case comd eq 'PA' ; * print window up to here
if numb else numb = pwin
save = here
here = here - numb
gosub set.bounds
for here = dawn to dusk
gosub display.line
next here
here = save
crt 'Still at line ':here:'.'
case comd = 'PASTE' and rest eq '' ; * paste from kept
if viewflag then gosub viewonly ; return
if kept eq '' then
crt 'Nothing in KEPT buffer'
comi = '' ; return
end
gosub savethat
numb = dcount(kept,am)
this = insert(this,here+1,0,0,kept)
gosub set.record
crt 'Pasted ':numb:' lines from KEPT buffer; still at line ':here:'.'
if beg gt here then beg += numb
if fin gt here then fin += numb
xxno = dcount(krj<1>,vm)
for xx = 1 to xxno
if krj<2,xx> gt here then krj<2,xx> += numb
next xx
case comd eq 'PASTE' ; * save the kept buffer
if viewflag then gosub viewonly ; return
if kept eq '' then
crt 'Nothing in KEPT buffer'
comi = '' ; return
end
gosub save.stuff
case comd eq 'PE' ; * page editor mode
if not(editpage) then
crt 'Page editing not possible at this terminal'
comi = ''
return
end
that = this ; savl = here:am:last
if this eq '' then this = am
if here lt 1 then here = 1
ptop = here
mode = 'PAGE':am:'View'
if sec.write.flg then mode<2> = 'Ins'
pchr = 1
chng = '' ; show = ''
gosub display.page
*>
gosub get.line
*>
temp = line
case comd eq 'PL' ; * print window from here
if numb else numb = pwin
save = here
gosub set.bounds
for here = dawn to dusk
gosub display.line
next here
here = save
crt 'Still at line ':here:'.'
case comd eq 'PP' ; * print window bracketing here
if numb else numb = pwin
save = here
here = here - int(numb/2)
gosub set.bounds
for here = dawn to dusk
gosub display.line
next here
here = save
crt 'Still at line ':here:'.'
case comd eq 'PR' ; * prestore processing
if numb eq '' then
crt 'Defined prestores (':presnumb:' Maximum)'
for xx = 1 to presnumb
temp = pres<1,xx>
convert sm to comdmark in temp
$ifdef unidata
crt fmt(xx,'2/0R'):' ':temp
$else
crt fmt(xx,'R%2'):' ':temp
$endif
next xx
return
end
if numb gt presnumb or numb lt 1 then
crt 'PRestore must be in range 1-':presnumb:'.'
comi = ''
return
end
if dlim ne '' then
if not(rest eq rest<1,1,1>) then
crt 'Invalid - delimiter in prestore'
comi = ''
return
end
pres<1,numb> = change(rest,dlim,sm)
end else
salt = pres<1,numb>
end
case 1 ; gosub bad.command
end case
return
q: begin case
* Various forms for quitting
case comd eq 'Q' or comd = 'QK' or comd = 'QUIT' or comd = 'QUITK'
if not(viewflag) and (orig ne this) then
stub = '***** Record changed --- OK to Quit? (N/Y)>'
gosub get.answ
if answ eq yes[1,1] then stopsign = true
end else stopsign = true
if stopsign then
if orig eq '' then
crt 'Quit "':item:'" in file "':fnam:'" not created.'
end else crt 'Quit "':item:'" in file "':fnam:'" unchanged.'
if index(comd,'K',1) then
killsign = true
if idcnt gt 1 then crt 'Select list cancelled.'
end
end
case 1 ; gosub bad.command
end case
return
r: begin case
case comd eq 'RA' ; * view or repeat change
if viewflag then gosub viewonly ; return
gosub change.command
case comd eq 'R' and dlim ne '' and index(rest,dlim,1) ; * change
if viewflag then gosub viewonly ; return
crt ; comd = 'C'
gosub change.command
case comd eq 'R' ; * replace lines
if viewflag then crt ; gosub viewonly ; return
if not(last) then
crt 'Empty record, use Insert (I) command.'
comi = ''
return
end
if here lt 1 then here = 1 ; gosub display.line
chng = 0 ; save = here ; savl = last
if numb lt 1 then numb = 1
if dlim ne '' and rest eq '' then rest = ' '
loop
crt begn:
if lfmt then crt fmt(here,lfmt):'=':
crt ceop:
if rest eq '' then
stub = here:'='
if lfmt then stub = fmt(here,lfmt):'='
gosub get.rope; line = rope
end else line = rest
gosub parse.line
until line eq '' do
crt goup:begn:ceol:
if lfmt then crt fmt(here,lfmt):': ':
crt line
if line eq comdmark then
line = ''
crt begn:
if lfmt then crt fmt(here,lfmt):': ':
end
if numb gt 1 then crt
if line eq ' ' then line = ''
if not(chng) then gosub savethis
chng += 1
memr(cell)<lnum> = line
here += 1 ; numb -= 1
gosub get.line
if numb eq 0 then exit
repeat
if here ne save then here -= 1
if chng then gosub reset.record; gosub get.line
crt begn:ceol:
case comd eq 'RELEASE' ; * release the item lock
release file,item
lock = false
case 1 ; gosub bad.command
end case
return
s: begin case
case comd eq 'S' ; * search processing
if numb eq '' then
crt 'Last ':looknumb:' searches (latest first)'
for xx = 1 to looknumb
$ifdef unidata
crt fmt(xx,'2/0R'):' ':look<1,xx>
$else
crt fmt(xx,'R%2'):' ':look<1,xx>
$endif
next xx
return
end
if numb gt looknumb or numb lt 1 then
crt 'Search must be in range 1-':looknumb:'.'
comi = ''
return
end
comi = look<1,numb>
if comi eq '' then
crt 'There is no search number ':numb:'.'
return
end
look = delete(look,1,numb,0)
look = insert(look,1,1,0,comi)
gosub parse.command
if comd eq '' then comd = 'L' ; numb = huge
comi = ''
redo = true
case comd eq 'SAVE' or comd eq 'SV' ; * save the item
if viewflag then gosub viewonly ; return
comd = 'SV'
if rest eq '' then
if not(sec.write.flg) then
crt 'File disabled'
comi = ''
return
end
gosub write.record
end else gosub save.stuff
case comd eq 'SEQ' ; * build a sequence
if viewflag then gosub viewonly ; return
if dlim eq '' then
crt 'Too few fields in this command.'
gosub bad.comd ; return
end
good = true
cfrom = field(rest,dlim,1)
cto = field(rest,dlim,2)
if cto eq '' then cto = 1
if not(num(cto)) then
crt 'Base for sequence command must be a number.'
good = false
end
bit = field(rest,dlim,3)
if bit eq '' then bit = 1
if not(num(bit)) then
crt 'Increment for sequence command must be a number.'
good = false
end else
if not(bit) then
crt 'Increment for sequence command must not be zero.'
good = false
end
end
if not(good) then gosub bad.comd ; return
rest = dlim:field(rest,dlim,4,2)
if rest ne dlim then
gosub parse.cols
if not(good) then return
end else cols = ''
chng = 0 ; save = here ; savl = last
gosub set.bounds
for here = dawn to dusk
gosub get.line ; temp = line
if cols then
bite = index(line[cols,colf],cfrom,1)
if bite then bite = bite + cols - 1
end else
bite = index(line,cfrom,1)
end
if bite then
temp = line[1,bite-1]:cto
temp = temp:line[bite+len(cfrom),len(line)]
end
if '*':temp ne '*':line then
cto = cto + bit
if not(chng) then gosub savethis
chng += 1
memr(cell)<lnum> = temp
gosub display.line
end
next here
here = dusk
if chng then gosub reset.record
case comd eq 'SHOW' ; * show changes flag
rest = upcase(rest)
begin case
case rest eq 'ON' ; shew = true
case rest eq 'OFF' ; shew = false
case 1 ; shew = not(shew)
end case
if shew
then crt 'Show changes flag is ON'
else crt 'Show changes flag is OFF'
case comd eq 'SORT' or comd eq 'SORTU' ; * sort the block
if viewflag then gosub viewonly ; return
test = index(comd,'U',1)
if not(beg) and not(fin) then
crt 'Command requests a block operation, but no block is defined.'
gosub bad.comd
return
end
if beg le 1 then
temp = 0
end else
temp = index(this,am,beg-1)
if not(temp) then
crt 'Cannot find beginning of block'
gosub bad.comd ; return
end
end
rest = upcase(rest)
if rest eq '' then rest = 'AL'
if not(index('*AR*AL*DR*DL*','*':rest:'*',1)) then
crt 'Invalid sort sequence - use "AL" "AR" "DL" or "DR"'
gosub bad.comd ; return
end
temp<2> = index(this,am,fin)
if fin eq last then temp<2> = len(this)+1
if not(temp<2>) then
crt 'Cannot find end of block'
gosub bad.comd ; return
end
if blockflag then
stub = 'Sort block beginning at ': beg:' and ending at ': fin:'?'
gosub get.answ
if answ ne yes[1,1] then
crt 'Block command cancelled.'
return
end
end
gosub savethat
bits = ''
for here = beg to fin
gosub get.line
locate(line,bits;posn;rest) then
if test then good = false else good = true
end else good = true
if good then bits = insert(bits,posn;line)
next here
here = oopl
if fin ne last
then this = this[1,temp<1>]:bits:am:this[temp<2>+1,len(this)]
else this = this[1,temp<1>]:bits
bits = ''
gosub set.record
* If any tags are in the sorted block then clear the tags,
* as it really makes no sense to try and sort them.
good = true
xxno = dcount(krj<1>,vm)
for xx = 1 to xxno
posn = krj<2,xx>
if posn ge beg and posn le fin then good = false
next xx
if not(good) then
krj = ''
crt 'Tags cleared'
end
gosub display.line
case comd eq 'SPACE' ; * change spacing flag for 'L'
rest = upcase(rest)
begin case
case rest eq 'ON' ; spaceflag = true
case rest eq 'OFF' ; spaceflag = false
case 1 ; spaceflag = not(spaceflag)
end case
if spaceflag then
crt 'SPACE flag is ON'
end else crt 'SPACE flag is OFF'
case comd eq 'SPOOL' ; * print
save = here
if numb eq '' and rest matches '1N0N' then numb = rest
if numb eq '' then here = 1 ; numb = last
gosub set.bounds
head = 'Record - ':item:' File - ':fnam:' Account - ':acct:' '
head = head:timedate():"'LL'"
temp = span
printer on
temp = temp - llen - 2
heading head
for here = dawn to dusk
gosub get.line
convert badc to gudc in line
print fmt(here,lfmt):': ':line[1,temp]
loop
line = line[temp+1,len(line)]
until line eq '' do
print space(llen+2):line[1,temp]
repeat
next here
printer close
if dawn ne 1 or dusk ne last then
crt 'Lines ':dawn:' to ':dusk:' of ':
end
crt '"':item:'" spooled to the printer.'
here = save
case comd eq 'SPOOLHELP' ; * print the help
rest = am
gosub show.help
case comd eq 'STAMP' ; * stamp it
if viewflag then gosub viewonly ; return
gosub savethat
last += 1 ; here += 1 ; lnum += 1
line = '* Last updated by ':name:' in account ':acct:' at ':timedate()
gosub insert.line
gosub reset.record
gosub display.line
case 1 ; gosub bad.command
end case
return
t: begin case
case comd eq 'T' ; * top
here = 0
gosub display.line
case comd eq 'TC' ; * text case (make line in)
if viewflag then gosub viewonly ; return
if rest eq '' then ccom = 'MCT' else ccom = 'QMCT'
gosub conv.command
* Various ways to TRIM the line
case comd eq 'TRIM' or comd = 'TRIMF' or comd = 'TRIMB'
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
if rest and comd eq 'TRIM' then
seek = field(rest,dlim,1)
if seek matches '3n' then seek = char(seek)
mark = field(rest,dlim,2)
mark = upcase(trim(mark))[1,1]
if index('ABCDEFLRT',mark,1) else
crt 'Invalid TRIM argument - must be one of "ABCDEFLRT"'
gosub bad.comd
return
end
end else seek = ''
show = shew ; dnum = 1
if numb eq '' and rest matches '1N0N' then numb = rest
gosub set.bounds
for here = dawn to dusk
gosub get.line
begin case
case comd eq 'TRIM'
if seek eq ''
then temp = trim(line)
else temp = trim(line,seek,mark)
case comd eq 'TRIMF' ; temp = trimf(line)
case comd eq 'TRIMB' ; temp = trimb(line)
end case
gosub check.line
next here
here = dusk
if chng then
gosub reset.record
crt chng:' lines changed - now at ':here
end
case comd eq 'TWIN' or comd eq 'TRIPLE' ; * sideways cloning of line
if viewflag then gosub viewonly ; return
if dlim ne '' then
line = rest ; gosub parse.line ; join = line
end
if here and here le last else return
chng = 0 ; save = here
gosub set.bounds
for here = dawn to dusk
gosub get.line
if comd eq 'TWIN'
then test = line:join:line
else test = line:join:line:join:line
if test ne line then
chng += 1
memr(cell)<lnum> = test
end
next here
if chng eq 0 then return
temp = 'Split ':chng:' lines'
if join ne '' then temp := ' and joined the parts with "':join:'"'
crt temp
here = save
gosub savethat
gosub reset.record
gosub display.line
case 1 ; gosub bad.command
end case
return
u: begin case
case comd eq 'U' ; * same as "-"
if numb eq '' then numb = 1
here = here - numb
if here lt 0 then here = 0
if here gt last then here = last
gosub display.line
case comd eq 'UC' ; * upper case (make line in)
if viewflag then gosub viewonly ; return
if rest eq '' then ccom = 'MCU' else ccom = 'QMCU'
gosub conv.command
case comd eq 'UNLOAD' ; comd = 'SV' ; redo = true
if viewflag then gosub viewonly ; return
case 1 ; gosub bad.command
end case
return
v: begin case
case comd eq 'V' ; * version information
crt (upcase(verb):' = ') 'R#20':help.def
$ifdef qm
temp = trans('NEWVOC','$RELEASE',2,'X')
if temp eq '' then
temp = trans('VOC','$RELEASE',2,'X')
end
if temp eq '' then temp = '?'
crt ('QM = ') 'R#20':temp
*>
crt ('Licence = ') 'R#20':system(31)
*>
$endif
$ifdef unidata
crt ' UniData version ':oconv('version','TVOC;X;;1')
$endif
$ifdef universe
temp = oconv('RELLEVEL','TNEWACC;X;;2')
if temp eq '' then
temp = oconv('RELLEVEL','TVOC;X;;2')
end
if temp eq '' then temp = 'not known'
crt ' UniVerse version ':temp
case comd eq 'VLIST'
execute comi capturing disp
stub = "Press return to continue showing VLIST 'T'op '-'back 'Q'uit"
gosub show.disp
$endif
case 1 ; gosub bad.command
end case
return
w: begin case
case comd eq 'W' or comd eq 'WHERE' ; * what we are editing
crt
if viewflag
then crt 'Viewing "':item:'" in file "':fnam:'"'
else crt 'Editing "':item:'" in file "':fnam:'"'
if idcnt gt 1 then crt ' [':id:'/':idcnt:']':
crt
if here gt last then here = last
gosub display.line
case comd eq 'WM' ; * word marker display (change)
if dlim ne '' then wordmark = dlim
if wordmark eq '"'
then crt 'WordMark is ':"'":wordmark:"'"
else crt 'WordMark is ':'"':wordmark:'"'
case 1 ; gosub bad.command
end case
return
x: begin case
* Another way of quitting
case comd eq 'X' ; comd = 'QK' ; redo = true
case comd eq 'XEQ' ; * execute a command
if viewflag then gosub viewonly ; return
if not(sec.xeq.flg) then
crt 'XEQ disabled'
comi = ''
return
end
loop
if rest ne '' then execute rest
test = @(0,0)
stub = '<RETURN> or command :'
gosub get.rope; rest = rope
if rest eq '' then
crt; crt 'Returned - ':
crt 'Editing "':item:'" in file "':fnam:'"'
end
until rest eq '' do
*>
crt
*>
repeat
gosub display.line
case comd eq 'XTD' ; * hex to decimal
$ifdef universe
crt xtd(rest)
$else
crt iconv(rest,'MX')
$endif
case 1 ; gosub bad.command
end case
return
y: begin case
case 1 ; gosub bad.command
end case
return
z: begin case
case 1 ; gosub bad.command
end case
return
set.bounds:
if numb eq '' then numb = 1
dawn = here
if dawn lt 1 then dawn = 1
dusk = dawn + numb - 1
if dusk gt last then dusk = last
numb = 0
return
null.command:
if dlim eq ':' then comd = 'XEQ' ; return
if dlim eq '/' then
comd = 'L'
if numb eq '' then numb = huge
return
end
if dlim eq '-' or dlim eq '+' then
if rest eq '' then rest = 1
end
if numb ne '' then comd = numb ; return
if dlim eq '' and rest eq '' then
here += 1
if here gt last then here = 1
gosub display.line
return
end
crt
begin case
case dlim eq '+' and rest matches '1N0N'
here = here + rest
if here gt last then here = last
gosub display.line
case dlim eq '-' and rest matches '1N0N'
here = here - rest
if here lt 0 then here = 0
if here gt last then here = last
gosub display.line
case dlim eq '^'
wild = not(wild)
if wild
then crt 'Expansion of non-printing characters enabled'
else crt 'Expansion of non-printing characters disabled'
case dlim eq '='
crt 'UNIDATA prestore is not implemented - Use "PR"'
case dlim eq '.'
gosub dot.command
case dlim eq '$'
if not(sec.xcom.flg) then
crt '$ external commands disabled'
comi = ''
return
end
save = comi ; comi = rest
gosub parse.command
comi = save
comd = '$':comd
xcom = oconv(comd,'TAE_XCOMS;X;2;2')
begin case
case xcom eq ''
crt 'Record "':comd:'" does not exist in "AE_XCOMS".'
case xcom[len(xcom)-2,3] ne '_AE'
disp = ''
disp<-1> = "Line 2 of record '":rest:"' in file 'AE_XCOMS'"
disp<-1> = "contains '":xcom:"'."
disp<-1> = ''
disp<-1> = 'This line should contain the name of a Basic subroutine that'
disp<-1> = "has been written to implement the external command '":rest:"'."
disp<-1> = "The program name must end in '_AE'."
stub = 'Press RETURN to continue'
gosub show.disp
case 1
that = this ; savl = here:am:last:beg:am:fin:am:krj
save = comi:am:comd:am:item:am:fnam
comd = comd:' ':rest
call @xcom(mat junk)
item = save<3>
fnam = save<4>
if here lt 0 then here = 0
gosub set.record
if here gt last then here = last
comd = ''
if that ne this then
crt save<2>:' - CHANGES HAVE BEEN MADE'
oops = that ; oopc = save<1>
oopl = savl<1> ; oopf = savl<2>
oopb = savl<3>:am:savl<4> ; oopk = field(savl,am,5,3)
end
that = ''
end case
case comi eq '?'
disp = ' Login name = ':name:' (':term:', userno ':whom:')'
disp<-1> = ' Account = ':acct
if path ne '' then disp<-1> = ' VOC path = ':path
disp<-1> = ' Level = ':levl
disp<-1> = ' File name = ':fnam
disp<-1> = ' Record id = ':item
disp<-1> = ' Current line = ':here
disp<-1> = ' Lines = ':last
disp<-1> = ' Characters = ':len(this)
if chan ne '' then
disp<-1> = 'Last Change command = ':chan<1,1>
end
if cmat ne '' then
temp = 'CM':cmat<1,3>:cmat<1,1>:cmat<1,2>
disp<-1> = 'Last CMatch command = ':temp
end
if olda then
temp = 'A':olda<1,2>:olda<1,1>
disp<-1> = 'Last Append command = ':temp
end
if beg or fin then
disp<-1> = ' Block = ':beg:'-':fin
end
if comdmark eq '"' then
temp = "'":comdmark:"'"
end else temp = '"':comdmark:'"'
disp<-1> = 'Command Delimiter is ':temp:', '
if nill eq '"' then
temp = "'":nill:"'"
end else temp = '"':nill:'"'
disp := 'character to end inserting is ':temp:', '
if wordmark eq '"' then
temp = "'":wordmark:"'"
end else temp = '"':wordmark:'"'
disp := 'WordMark is ':temp
disp<-1> = 'Page: window for PA/PL/PP is ':pwin:', length for P is ':plen
if wild
then disp<-1> = 'Expansion of non-printing characters enabled'
else disp<-1> = 'Expansion of non-printing characters disabled'
if caseflag then
disp<-1> = 'CASE':' flag ON':', '
end else disp<-1> = 'CASE':' flag OFF':', '
if spaceflag then
disp := 'SPACE':' flag ON':', '
end else disp := 'SPACE':' flag OFF':', '
if shew then
disp := 'SHOW':' flag ON':', '
end else disp := 'SHOW':' flag OFF':', '
if blockflag then
disp := 'BLOCK':' flag ON'
end else disp := 'BLOCK':' flag OFF'
if oopc ne '' then
disp<-1> = 'OOPS will restore record prior to command: ':oopc
end else
disp<-1> = 'OOPS already executed, or no changes in effect.'
end
gosub show.disp
case comi[1,2] eq '<>' ; gosub botharr
case comi[1,1] eq '<' ; gosub leftarr
case comi[1,1] eq '>' ; gosub rightarr
case dlim eq '\' and rest[1,1] eq '\' ;* clear the tag pointers
krj = ''
crt 'Tags cleared'
case dlim eq '\' ;* set a tag pointer
locate(here,krj,2;posn) then
crt 'There is already a Tag on line ':here
return
end
if rest eq '' then rest = 'T':here
rest = upcase(rest)
locate(rest,krj,1;posn) then
crt 'There is already a Tag labelled ':rest
return
end
posn = krj<3>
krj<1> = field(krj<1>,vm,1,posn)
posn += 1
krj<1,posn> = rest
krj<2,posn> = here
krj<3> = posn
crt 'Setting Tag labelled ':rest:' at line ':here
case (dlim eq '[' or dlim eq ']') and (rest[1,1] eq '[' or rest[1,1] eq ']')
if krj<3> eq ''
then disp = 'No Tag found'
else disp = 'Tags at line-Labelled'
posn = krj<3>
xxno = dcount(krj<1>,vm)
for xx = 1 to xxno
disp<-1> = krj<2,xx> 'r#12'
if xx eq posn then disp := '>' else disp := ' '
disp := krj<1,xx>
next xx
convert badc to gudc in disp
gosub show.disp
case dlim eq '[' and rest eq ''
posn = krj<3>-1
if posn gt 0 then
comd = krj<2,posn>
krj<3> = posn
crt 'Moved to line ':comd:' labelled ':krj<1
end else comd = ''
if comd eq '' then crt 'No Tag found'
case dlim eq ']' and rest eq ''
posn = krj<3>+1
comd = krj<2,posn>
if comd eq '' then
crt 'No Tag found'
end else
krj<3> = posn
crt 'Moved to line ':comd:' labelled ':krj<1
end
case dlim eq '[' or dlim eq ']'
locate(upcase(rest),krj,1;posn) then comd = krj<2,posn> else comd = ''
if comd ne '' then
krj<3> = posn
crt 'Moved to line ':comd:' labelled ':krj<1
return
end else crt 'No Tag found'
case 1
gosub bad.command
end case
return
parse.cols:
good = true
cols = field(rest,dlim,2)
convert ',.' to '--' in cols
rest = field(rest,dlim,1)
colf = field(cols,'-',2)
cols = field(cols,'-',1)
if colf eq '' then colf = cols
if cols ne '' then
if not(cols matches '1N0N') or not(colf matches '1N0N') then
crt 'Column specifications must be positive whole numbers.'
gosub bad.comd
good = false
return
end
end
if colf lt cols then
crt 'Ending column # must exceed or equal starting column #.'
gosub bad.comd
good = false
return
end
colf = colf - cols + 1
return
parse.atts:
convert '-' to dlim in rest
if dlim eq '"' then temp = "'" else temp = '"'
temp = '1N0N':temp:dlim:temp:'1N0N'
if rest matches temp then
numb = field(rest,dlim,2) - field(rest,dlim,1) + 1
rest = field(rest,dlim,1)
end
return
change.command:
if comd eq 'RA' then
if numb eq '' then
crt 'Last ':channumb:' changes (latest first)'
for xx = 1 to channumb
$ifdef unidata
crt fmt(xx,'2/0R'):' ':chan<1,xx>
$else
crt fmt(xx,'R%2'):' ':chan<1,xx>
$endif
next xx
return
end
if numb gt channumb or numb lt 1 then
crt 'Change must be in range 1-':channumb:'.'
comi = ''
return
end
comi = chan<1,numb>
if comi eq '' then
crt 'There is no change number ':numb:'.'
return
end
chan = delete(chan,1,numb,0)
chan = insert(chan,1,1,0,comi)
gosub parse.command
comi = 'RA'
end
save = upcase(field(rest,dlim,3,2))
if save ne '' then rest = rest[1,col1()]
gosub get.fromto
temp = save
if comi eq '' then return
chng = 0 ; save = here ; savl = last
glob = index(temp,'G',1)
show = shew or index(temp,'S',1)
convert dlim:'GS' to '-' in temp
rest = dlim:temp
gosub parse.cols
if not(good) then return
if numb lt plen then show = true
dnum = 1
gosub set.bounds
for here = dawn to dusk
gosub get.line
gosub change.line
gosub check.line
next here
here = dusk
if comi ne '' and upcase(comi) ne 'RA' then
chan = insert(chan,1,1,0,comi)
chan = delete(chan,1,channumb,0)
end
if chng then
gosub reset.record
if not(show) and dnum gt plen then
crt chng:' lines changed - now at ':here
end
end
return
get.fromto:
if count(rest,dlim) gt 2 then
crt 'Too many delimiters (3 max.).'
comi = ''
return
end
line = field(rest,dlim,1)
gosub parse.line
cfrom = line
line = field(rest,dlim,2)
gosub parse.line
cto = line
if cto eq '' and count(rest,dlim) lt 2 then
crt 'Missing required TO field (for "CHANGE/FROM/TO").'
comi = ''
return
end
return
change.line:
if cfrom eq '' then
temp = cto:line
end else
if glob then
temp = change(line,cfrom,cto)
end else
temp = index(line,cfrom,1)
if temp then
temp = line[1,temp-1]:cto:line[temp+len(cfrom),len(line)]
end else temp = line
end
end
return
conv.command:
chng = 0 ; save = here ; savl = last
show = shew or index(rest,'S',1) or index(rest,'s',1)
dnum = 1
if numb lt plen then show = true
if numb eq '' and rest matches '1N0N' then numb = rest
gosub set.bounds
ctyp = ccom[1,1]
begin case
* ICONV
case ctyp eq '*' ; ccom = ccom[2,huge]
* Text conversion LC, TC, or UC command
case ctyp eq 'Q' ; ccom = ccom[2,huge]
end case
for here = dawn to dusk
gosub get.line
begin case
case ctyp eq '*'
temp = iconv(line,ccom)
case ctyp eq 'Q'
temp = field(trim(line),' ',1)
flag = false
if temp ne 'REMOVE' then
if temp[1,3] eq 'REM' then flag = true
if temp[1,1] eq '*' then flag = true
if temp[1,1] eq '!' then flag = true
end
if flag then
temp = line
end else
xxno = len(line)
temp = ''
flag = ''
for xx = 1 to xxno
bit = line[xx,1]
begin case
case bit eq flag ; flag = ''
case flag ne ''
case index(qt,bit,1) ; flag = bit
*>
case bit eq ';'
test = trim(line[xx+1,huge])[1,1]
if test eq '*' or test eq '!' then flag = am
*>
case 1 ; bit = oconv(bit,ccom)
end case
temp = temp:bit
next xx
end
case 1
temp = oconv(line,ccom)
end case
if temp eq '' then temp = line
gosub check.line
next here
here = dusk
if chng then
gosub reset.record
if not(show) and dnum gt plen then
crt chng:' lines changed - now at ':here
end
end
return
dot.command:
if trim(comi) eq '.' then comi = '.L1'
save = comi
comi = field(comi,dlim,2,huge)
gosub parse.command
begin case
case comd eq 'A' ; * append to line
if numb eq '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
stak<1,numb> := rest
$ifdef unidata
crt fmt(numb,'3/0R'):'. ':stak<1,numb>
$else
crt fmt(numb,'R%3'):'. ':stak<1,numb>
$endif
end
case comd eq 'C' ; * change lines
if numb eq '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
gosub get.fromto
if comi eq '' then comd = '' ; return
glob = index(field(rest,dlim,3),'G',1)
glob = glob + index(field(rest,dlim,3),'g',1)
line = stak<1,numb>
gosub change.line
stak<1,numb> = temp
$ifdef unidata
crt fmt(numb,'3/0R'):'. ':temp
$else
crt fmt(numb,'R%3'):'. ':temp
$endif
end
case comd eq 'D' ; * delete lines
if numb eq '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
stak = delete(stak,1,numb,0)
crt 'History #':numb:' DELETEd.'
end
case comd eq 'I' ; * insert a new line
if numb eq '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
if rest ne '' then
stak = insert(stak,1,numb,0,rest)
stak = delete(stak,1,staknumb,0)
$ifdef unidata
crt fmt(numb,'3/0R'):'. ':stak<1,numb>
$else
crt fmt(numb,'R%3'):'. ':stak<1,numb>
$endif
end
end
case comd eq 'L' ; * list lines
if numb eq '' then numb = plen
if numb gt dcount(stak,vm) then numb = dcount(stak,vm)
temp = rem(numb+1,plen)
for xx = numb to 1 step -1
$ifdef unidata
crt fmt(xx,'3/0R'):'. ':stak<1,xx>
$else
crt fmt(xx,'R%3'):'. ':stak<1,xx>
$endif
if xx gt 1 and rem(xx,plen) eq temp then
stub = 'Press return to continue, Q to quit'
rlen = 1
gosub get.rope; crt begn:ceol:
wait = trim(upcase(rope))[1,1]
if wait eq 'Q' then exit
end
next xx
case comd eq 'R' ; * restore a line to latest
if numb eq '' then numb = 1
if numb le dcount(stak,vm) then
temp = stak<1,numb>
stak = insert(stak,1,1,0,temp)
stak = delete(stak,1,staknumb,0)
end
case comd eq 'S'
if numb eq '' then numb = 1
if numb gt presnumb then
crt numb:' is greater than pre-store limit of ':presnumb
return
end
rest = trim(rest)
dawn = field(rest,dlim,1) ; if dawn eq '' then dawn = 1
dusk = field(rest,dlim,2) ; if dusk eq '' then dusk = 1
if not(dawn matches '1N0N' and dusk matches '1N0N') then
crt 'One of the values was not a number'
return
end
if dawn gt dusk then temp = dawn ; dawn = dusk ; dusk = temp
temp = ''
for xx = dusk to dawn step -1
temp<1,1,-1> = stak<1,xx>
next xx
pres<1,numb> = temp
case comd eq 'U' ; * upcase line
if numb eq '' then numb = 1
if numb gt dcount(stak,vm)
then crt 'History command ':numb:' does not exist.'
else stak<1,numb> = upcase(stak<1,numb>)
case comd eq 'UL' ; * downcase line
if numb eq '' then numb = 1
if numb gt dcount(stak,vm)
then crt 'History command ':numb:' does not exist.'
else stak<1,numb> = downcase(stak<1,numb>)
case comd eq 'UT' ; * mixed case line
if numb eq '' then numb = 1
if numb gt dcount(stak,vm)
then crt 'History command ':numb:' does not exist.'
else stak<1,numb> = oconv(stak<1,numb>,'mct')
case comd eq 'X' ; * re-execute an editor command
if numb eq '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
salt = stak<1,numb>
stak = delete(stak,1,numb,0)
end
case 1
comi = save
gosub bad.command
end case
comi = '' ; comd = ''
return
viewonly:
crt 'That command is not allowed in VIEW mode':bell
comi = ''
return
bad.command:
crt 'Command not understood - try "H" for help.'
bad.comd:
xxno = len(comi)
temp = ''
for xx = 1 to xxno
bite = comi[xx,1]
bite = seq(bite)
if bite ge 127 or bite lt 32 then
$ifdef unidata
bite = '^':fmt(bite,'3/0R')
$else
bite = '^':fmt(bite,'R%3')
$endif
end else bite = char(bite)
temp = temp:bite
next xx
crt 'Command was: "':temp:'"'
temp = ''
comi = ''
return
save.stuff:
if not(sec.unload.flg) then
crt 'Unload disabled'
comi = ''
return
end
keepquot = false
gosub parse.rest
odpt = '' ; ofpt = bite<1> ; oipt = bite<2>
onam = ofpt
if ofpt eq 'DICT' then
odpt = ofpt ; ofpt = oipt ; oipt = bite<3>
onam = onam:' ':ofpt
end
if oipt eq '' then
if odpt ne '' then
crt 'Cannot save to null item.'
gosub bad.comd ; return
end
oipt = ofpt ; odpt = dprt ; ofpt = fprt ; onam = fnam
end
if dprt eq odpt and fprt eq ofpt then
ofil = file
end else
open odpt, ofpt to ofil else
crt 'Cannot open ':'"':fnam:'"'
gosub bad.comd ; return
end
end
if prepflag then
sec.call2.type = 2
sec.fn2 = ofpt
sec.id2 = oipt
sec.dict2.flg = (odpt = 'DICT')
call @prepprog(mat security)
if sec.stop.flg then stop
if not(sec.ok2.flg) then
gosub bad.comd ; return
end
end
if source.control then
dict.flag = odpt
file.name = ofpt
record.name = oipt
record.data = this
caller = '3'
write.allowed = '1'
updated = '0'
call source.control(dict.flag,file.name,
record.name,record.data,caller,write.allowed,updated)
if write.allowed ne '1' then
crt 'WRITE NOT ALLOWED'
return
end
end
readv test from ofil, oipt, 1 then
stub = 'Record already exists. Overwrite (y/n)? '
gosub get.answ
if answ ne yes[1,1] then return
end
if comd eq 'PASTE' then
write kept on ofil, oipt on error gosub writerr ; return
end else
write this on ofil, oipt on error gosub writerr ; return
end
crt 'Record "':oipt:'" saved in "':onam:'".'
return
write.record:
if rest ne '' then
if comd eq 'FD' then
crt '"FD" operates only on the current record & file.'
end else
crt '"FI" only for current record & file. Use SAVE.'
end
gosub bad.comd ; return
end
if source.control then
dict.flag = dprt
file.name = fprt
record.name = item
if comd eq 'FD' then record.data = '' else record.data = this
caller = '3'
write.allowed = '1'
updated = '0'
call source.control(dict.flag,file.name,
record.name,record.data,caller,write.allowed,updated)
if write.allowed ne '1' then
crt 'WRITE NOT ALLOWED'
return
end
end
if not(lock) then
crt 'Record lock has been released! Write not allowed.'
comi = ''
return
end
if comd eq 'FD' then
stub = '***** You are about to DELETE the record! OK? ':ny
gosub get.answ
if answ ne yes[1,1] then return
delete file, item on error gosub writerr ; return
crt 'Deleted "':item:'" from file "':fnam:'".'
end else
if comd eq 'SV' then
writeu this on file, item on error gosub writerr ; return
orig = this ; oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = '' ; oopk = ''
crt 'Saved "':item:'" in "':fnam:'" - now at line ':here:'.'
return
end else
write this on file, item on error gosub writerr ; return
if orig eq this then
crt 'Filed "':item:'" in file "':fnam:'" UNCHANGED.'
end else crt 'Filed "':item:'" in file "':fnam:'".'
oops = '' ; oopc = '' ; oopl = '' ; oopf = '' ; * ewd
end
end
stopsign = true
if index(comd,'B',1) then
temp = 'BASIC'
$ifdef qm
if index(comd,'D',1) then temp<2> = ' DEBUGGING'
$endif
gosub exec.that
end
if index(comd,'C',1) then
temp = 'CATALOG'
begin case
case index(comd,'L',1) ; temp<2> = ' LOCAL'
* case index(comd,'G',1) ; temp<2> = ' GLOBAL'
end case
gosub exec.that
end
if index(comd,'R',1) then temp = 'RUN' ; gosub exec.that
return
edit.fields:
if here lt 1 then here = 1
gosub get.line ; temp = line
convert vmrk to am in line
ttid = whom:'_':levl:'_':vals:'.in.line#':here
write line on acom, ttid on error gosub writerr ; return
crt view:'ing ':vals:' as fields...':
execute verb:' AE_COMS ':ttid:options
test = @(0,0)
crt 'Back ':view:'ing the record "':item:'" in file "':fnam:'"'
read line from acom, ttid else line = ''
delete acom, ttid
return
reset.fields:
convert am to vmrk in line
if temp ne line then
gosub savethat
memr(cell)<lnum> = line
gosub reset.record
end
return
get.load:
temp = ''
if trim(rest) eq '' then
stub = 'Record name, or file name and record name >'
gosub get.rope; rest = rope; crt
if trim(rest) eq '' then temp = ''; return
end
keepquot = false
gosub parse.rest
onam = bite<1>
onid = bite<2>
if onam eq 'DICT' then
onam = onam:' ':onid
onid = bite<3>
if onid eq '' then onid = item
end
if onid eq '' then onid = onam ; onam = ''
if onid eq '' then return
if onam eq '' then
onam = fnam
odpt = dprt
ofpt = fprt
ofil = file
end else
odpt = field(onam,' ',1)
ofpt = field(onam,' ',2)
if ofpt eq '' then ofpt = odpt ; odpt = ''
open odpt, ofpt to ofil else
crt 'Cannot open ':onam
gosub bad.comd ; return
end
end
read temp from ofil, onid else
if dcount(bite,am) eq 1 then
open onid to ofil then
read temp from ofil, item then return
end
end
crt 'Record "':onid:'" was not found on file "':onam:'".'
gosub bad.comd ; return
end
return
changematch.command:
patt = field(rest,dlim,1)
gosub parse.pattern
if not(good) then
crt 'Pattern: character "':bit:'" is not allowed unless quoted.'
comi = ''
return
end
if comd eq 'CM' then cmat = dlim:vm:rest:vm:numb
cto = field(rest,dlim,3,huge)
line = cto ; gosub parse.line ; cto = line
cfrom = upcase(field(rest,dlim,2))
if cfrom eq '' then cfrom = 'L'
if cfrom eq 'L' then mmat = dlim:vm:rest
if numb eq '' and cto eq '' and (cfrom eq 'L' or cfrom eq 'N') then
numb = last
flag = true
end else flag = false
if len(cfrom) eq 1 and index('ADLNPR',cfrom,1) then
end else
gosub parse.cols
if not(good) then return
cfrom = ''
colf = cols + colf - 1
end
cm.del.entry:
gosub set.bounds
show = shew ; dnum = 1
chng = 0 ; save = here ; savl = last ; dnum = 2
test = ''
for here = dawn to dusk
gosub get.line
if cfrom eq 'DE'
then good = index(line,patt,1)
else good = (line matches patt)
if not(good) then
if cfrom eq 'N' then
numb += 1
if show or numb lt plen then gosub display.line
if flag then dusk = here
end
continue
end
numb += 1
temp = line
begin case
case cfrom eq 'A'
temp = line:cto
case cfrom[1,1] eq 'D'
if show or numb lt plen then crt fmt((here + chng),lfmt):'+ ':line
test<-1> = here
case cfrom eq 'L'
gosub display.line
if flag then dusk = here
case cfrom eq 'P'
temp = cto:line
case cfrom eq 'R'
temp = cto
case cfrom eq 'N'
numb -= 1
case 1
gosub parse.temp
end case
if not(index('DL',cfrom,1)) or cfrom eq '' then
gosub check.line
end
next here
if cfrom[1,1] eq 'D' and numb then
gosub savethis
for here = numb to 1 step -1
temp = test<here>
cell = int((temp-1)/cellsize) + 1
coff = rem(temp,cellsize)
if coff eq 0 then coff = cellsize
del memr(cell)<coff>
if beg eq temp then beg = 0
if beg gt temp then beg -= 1
if fin eq temp then fin = 0
if fin gt temp then fin -= 1
for xx = dcount(krj<1>,vm) to 1 step -1
begin case
case krj<2,xx> gt temp ; krj<2,xx> -= 1
case krj<2,xx> eq temp
del krj<1,xx> ; del krj<2,xx> ; krj<3> -= 1
end case
next xx
next here
test = ''
gosub reset.record
here = dusk - numb
end else
here = dusk
end
if dawn ne dusk then
if here lt last
then crt 'At line ':here:'.'
else crt 'Bottom at ':here:'.'
end
if not(numb) then
if cfrom eq 'N' then
crt 'No lines (in ':dawn:'-':dusk:') NOT matching pattern "':patt:'"'
end else crt 'No lines (in ':dawn:'-':dusk:') matching pattern "':patt:'"'
end else
begin case
case cfrom[1,1] eq 'D'
crt 'Deleted ':numb:' lines matching "':patt:'"'
case cfrom eq 'L'
crt 'Found ':numb:' lines matching "':patt:'"'
case cfrom eq 'N'
crt 'Found ':numb:' lines NOT matching "':patt:'"'
end case
end
if chng then
gosub reset.record
begin case
case dawn eq dusk
return
case cfrom eq 'A'
crt '"':cto:'" appended to ':
case cfrom[1,1] eq 'D'
crt 'Deleted ':
case cfrom eq 'P'
crt '"':cto:'" prefixed to ':
case cfrom eq 'R'
crt 'Replaced with "%", ':
case cfrom eq 'L' or cfrom eq 'N'
case cols eq colf
crt 'Element ':cols:' changed to "':cto:'" in ':
case cols
crt 'Element ':cols:'-':colf:' changed to "':cto:'" in ':
end case
if chng eq 1
then crt '1 line matching "':patt:'"'
else crt chng:' lines matching "':patt:'"'
end
return
parse.pattern:
* bits<1> are the pattern pieces
* <2> quote or 'p'attern flag
* <3> partial patterns
cntr = 1
bits = ''
flag = ''
good = true
first = true
xxno = len(patt)
gosub quote.pattern
for xx = 1 to xxno
bit = patt[xx,1]
begin case
case bit = flag
flag = ''
first = true
cntr = cntr + 1
case flag ne ''
bits<1,cntr> = bits<1,cntr>:bit
case index(qt,bit,1)
bits<2,cntr> = bit
flag = bit
case first
if not(bit matches '1n') then
good = false
return
end
first = false
bits<2,cntr> = 'p'
bits<1,cntr> = bits<1,cntr>:bit
if bit eq '0' then bits<3,cntr> = patt[xx+2,xxno]
case 1
if not(index('AaNnXx',bit,1)) then
good = false
return
end
bits<1,cntr> = bits<1,cntr>:oconv(bit,'mcu')
first = true
cntr = cntr + 1
end case
next xx
cntr = cntr - 1
return
quote.pattern:
* Adds quotes to the pattern if required
* If they use any quotes at all, we don't do a thing
if index(patt,'"',1) then return
if index(patt,'\',1) then return
if index(patt,"'",1) then return
xx = 1
temp = ''
test = ''
loop
left = patt[xx,2]:'*'
if index('0123456789',left[1,1],1) and index('AaNnXx',left[2,1],1) then
if test ne '' then temp := "'":test:"'"
temp := patt[xx,2]
test = ''
xx += 1
end else test := patt[xx,1]
until xx gt xxno do
xx += 1
repeat
patt = temp
if test ne '' then patt := "'":test:"'"
return
parse.temp:
temp = ''
posn = 1
xxno = len(line)
for xx = 1 to cntr
what = bits<1,xx>
type = bits<2,xx>
nmbr = what[1,1]
begin case
case xx gt colf
temp<xx> = line[posn,xxno]
xx = cntr
case type ne 'p'
temp<xx> = line[posn,len(what)]
posn = posn + len(what)
case xx = cntr
temp<xx> = line[posn,xxno]
case nmbr = '0'
* look to match the rest of the line with the partial pattern
test = bits<3,xx>
yy = posn
bit = ''
loop
until yy gt xxno do
chit = line[yy,xxno]
until chit matches test do
bit := chit[1,1]
yy += 1
repeat
posn += len(bit)
temp<xx> = bit
case 1
bit = line[posn,nmbr]
posn += len(bit)
temp<xx> = bit
end case
next xx
temp<cols> = cto
for xx = cols+1 to colf
temp = delete(temp,cols+1)
next xx
convert am to '' in temp
return
get.lines:
stub = '"Q"uit, or starting line > '
pick = 1
gosub get.rope; dawn = rope
dawn = upcase(trim(dawn))
if dawn eq '' then dawn = 'Q'
if dawn[1,1] eq 'Q' then temp = false ; crt ; return
if not(dawn matches '1N0N') then
crt
crt 'Nothing done - starting and ending lines must be numeric.'
gosub bad.comd ; return
end
if dawn gt dcount(temp,am) then
crt
crt 'Nothing done - record does not have that many lines.'
gosub bad.comd ; return
end
stub = stub:dawn:' ':', ending line > '
pick = dcount(temp,am)
gosub get.rope; dusk = rope
dusk = upcase(trim(dusk))
if dusk eq '' then dusk = 'Q'
if dusk[1,1] eq 'Q' then temp = false ; crt ; return
if not(dusk matches '1N0N') then
crt
crt 'Nothing done - starting and ending lines must be numeric.'
gosub bad.comd ; return
end
if dusk gt dcount(temp,am) then
dusk = dcount(temp,am)
crt begn:'File is ':onam:': "Q"uit, or starting line > ':dawn:', ':dusk:
end
temp = field(temp,am,dawn,dusk-dawn+1)
crt
return
parse.bite:
temp = ''
loop
while bite ne '' do
bite = trimf(bite)
xx = fold
if count(bite[1,xx],' ') and trim(bite[xx+1,1]) ne '' then
loop
until trim(bite[xx,1]) eq '' do
xx -=1
repeat
temp<-1> = bite[1,xx-1]
end else
temp<-1> = bite[1,xx]
end
bite = bite[xx+1,len(bite)]
repeat
return
show.help:
crt
if help eq '' then
help = ''
help<-1> = ' ':verb:' version ':help.def
help<-1> = ' This program can be called with the following formats:'
help<-1> = " ":verb:" file and record id's are prompted for"
help<-1> = " ":verb:" file record id's are prompted for"
help<-1> = " ":verb:" file id ":view:" the record 'id' in 'file'"
help<-1> = " ":verb:" file id id... ":view:" multiple records in 'file'"
help<-1> = " ":verb:" file * ":view:" all records in 'file'"
help<-1> = " SELECT may precede '":verb:" file' command"
help<-1> = ' Special ASCII characters may be entered as:'
help<-1> = ' ^nnn where nnn is the decimal character code (like ^027)'
help<-1> = ' ^ will enter a single UP ARROW character.'
help<-1> = ' The following commands may be used in the Editor:'
help<-1> = 'A# - Do the last Append command again for # lines.'
help<-1> = "A# any - Append 'any' to # lines (default 1)."
help<-1> = 'B + Set the current line pointer to the BOTTOM line.'
help<-1> = "B# any - BREAK # lines (default 1) after string 'any' into two lines."
help<-1> = 'BC# posn = Break Column - Break # lines (default 1) after posn into two.'
help<-1> = 'BCD# posn = Break Column and Discard the second part.'
help<-1> = 'BCK# posn = Break Column and Keep only the second part.'
help<-1> = 'BCR# posn = Break Column and Reverse the order of the two parts.'
help<-1> = 'BCS# posn = Break Column and Swap the parts about the character at posn.'
help<-1> = "BD# any - BREAK after string 'any' and Discard the second part."
help<-1> = "BK# any - BREAK after string 'any' and Keep only the second part."
help<-1> = "BR# any - BREAK after string 'any' and Reverse the order of the two parts."
help<-1> = "BS# any - BREAK after string 'any' and Swap the parts about 'any'."
help<-1> = 'BLEACH ON/OFF# Switch colourisation flag.'
help<-1> = 'BLOCK ON/OFF + Switch block operation confirmation flag.'
help<-1> = ' If neither ON nor OFF is used, then toggle BLOCK flag.'
help<-1> = "C - Do the last 'CHANGE' command again."
help<-1> = 'C/// - CHANGE one or more lines. Full formats is:'
help<-1> = ' C[#]/from/to/[G][S]'
help<-1> = ' where / - is any delimiter character.'
help<-1> = ' # - number of lines to CHANGE (default 1).'
help<-1> = ' from - is the character string to be replaced.'
help<-1> = ' to - is the character string to substitute.'
help<-1> = " G - 'G'lobal flag - CHANGE all instances in line."
help<-1> = " S - 'S'how flag - display all changes made."
help<-1> = 'CASE ON/OFF + Switch CASE flag for FL, FLA, L, LA, LN, LNA commands.'
help<-1> = ' If neither ON nor OFF is used, then toggle CASE flag.'
help<-1> = ' OFF means that the commands are not case sensitive.'
help<-1> = "CAT - Synonym for 'J'oin."
help<-1> = 'CD + Show or change the command delimiter.'
help<-1> = ' (this is the input for a blank line).'
help<-1> = 'CLEAR # Clear the kept buffer.'
help<-1> = 'CM/// - ChangeMatch one or more lines. Full formats is:'
help<-1> = ' CM[#]/pattern[/range/to]'
help<-1> = ' where / - is any delimiter character.'
help<-1> = ' # - number of lines to CHANGE (default 1).'
help<-1> = ' pattern - is the pattern match for the line.'
help<-1> = ' to - is the character string to substitute/add.'
help<-1> = ' range - Can be numeric, which field(s) to change,'
help<-1> = " or 'A'ppend or 'P'refix to the line,"
help<-1> = " or 'D'elete, 'R'eplace, 'L'ocate (default) the line."
help<-1> = " EG 'CM/6X' will scan to the line matching '6X'."
help<-1> = " Also; 'N'ot - locate the next non-matching line."
help<-1> = 'COL + Display relative COLUMN POSITIONS on the Terminal.'
help<-1> = 'COPY # Copy the predefined block to the kept buffer.'
help<-1> = 'COPY# # Copy the next # lines to the kept buffer.'
help<-1> = 'COPYx/y # Copy x lines starting at line y to the kept buffer.'
help<-1> = 'COPY/x/y # Copy lines from x to y inclusive to the kept buffer.'
help<-1> = "COUNT#/any + Count of 'any' in next # lines (default 1)."
help<-1> = "CRT xxxx - Inserts a line CRT 'xxxx = ':xxxx"
help<-1> = ' Use double quote or backslash as delimiter to change quotes.'
help<-1> = 'CUT = Move the predefined block to the kept buffer.'
help<-1> = 'CUT# = Move the next # lines to the kept buffer.'
help<-1> = 'CUTx/y = Move x lines starting at line y to kept buffer.'
help<-1> = 'CUT/x/y = Move lines from x to y inclusive to kept buffer.'
help<-1> = 'D + Display the current line.'
help<-1> = 'DE - DELETE the current line.'
help<-1> = "DE# - DELETE '#' lines (default 1)."
help<-1> = "DE#/any - DELETE as above, but only if the line contains 'any'."
help<-1> = "DISPLAY xxxx - Inserts a line DISPLAY 'xxxx = ':xxxx"
help<-1> = ' Just like CRT, handy to distinguish debug code.'
help<-1> = 'DROP - Remove the predefined block.'
help<-1> = "DTX any + Convert decimal string 'any' to hexadecimal and display it."
help<-1> = 'DUP - DUPLICATE the current line.'
help<-1> = "DUP# - DUPLICATE the current line '#' times."
help<-1> = 'EC + Edit a called subroutine in this file.'
help<-1> = 'ECS # Edit the command stack.'
help<-1> = 'EF# + Edit fields delimited by CHAR(#) as lines.'
help<-1> = 'EI + Edit the included code.'
help<-1> = 'EIT + Edit I-type (not just a split on semi-colon).'
help<-1> = 'EK # Edit the kept buffer.'
help<-1> = 'EPR + Edit the prestored commands.'
help<-1> = 'EPR# # Edit prestored commqnd #.'
help<-1> = 'ESS # Edit Search Stack.'
help<-1> = 'ESV + Edit subvalues as 1ines.'
help<-1> = 'ET # Edit the line tabs.'
help<-1> = 'EV + Edit multivalues as lines.'
help<-1> = 'EW + Edit words as lines.'
help<-1> = 'EXIT (EX) + QUIT - EXIT the program.'
help<-1> = 'EXITK (EXK) + QUITKill - EXIT the program, abandon any active SELECT list.'
help<-1> = 'FD - DELETE the entire record from the file.'
help<-1> = 'FI - FILE the record. You can also process it.'
help<-1> = ' FIB = BASIC, FIC = CATALOG, FIR = RUN'
help<-1> = ' You can have up to three processes (EG. FIBCR).'
help<-1> = ' You can modify BASIC with D for DEBUGGING (EG. FIBD).'
help<-1> = ' You can modify CATALOG with L for LOCAL (EG. FICL).'
help<-1> = 'FILE - Synonym for SAVE.'
help<-1> = 'FL + Find the next Label.'
help<-1> = "FL any + Find the label 'any' or matching pattern 'any'."
help<-1> = 'FL# + Find (display) the labels in next # lines.'
help<-1> = 'FLA + Find label above this line.'
help<-1> = 'FM + Find Matching logic by position.'
help<-1> = 'FMA + Find Matching logic by position above this line.'
help<-1> = 'FOLD/length - Split current line (on blanks if possible) to fit width.'
help<-1> = 'FORMAT (FOR) + FORMAT a BASIC program to show logical structure by'
help<-1> = ' indenting. This has the following keywords;'
help<-1> = " '-Mx' = Set margin to x."
help<-1> = " '-Iy' = Set Indentation to y."
help<-1> = " '-A' = Align comments with code."
help<-1> = " '-N' = No CASE indentation."
help<-1> = " '-C' = Compress - same as '-M0 -I1 -A -N'."
help<-1> = "G# + GO TO line '#' ('G' is optional)."
help<-1> = 'HELP (H) + Prompt user to display HELP information on the Terminal.'
help<-1> = "HELP any + Display HELP information on Terminal for 'any'."
help<-1> = 'HELP NEW + Display HELP information on new features.'
help<-1> = 'HEX + Displays the current line in hexadecimal.'
help<-1> = 'I - INSERT new lines AFTER the current line. Prompt for'
help<-1> = ' successive lines. INPUT until NULL input. An INPUT line'
help<-1> = ' of a single space will store an empty line.'
help<-1> = "I any - INSERT (INPUT) the line 'any' AFTER the current line."
help<-1> = "I#/any - INSERT # lines of 'any' AFTER the current line."
help<-1> = "IC any - IConv the line using the conversion 'any'."
help<-1> = 'IN command - Insert the results of the command AFTER the current line.'
help<-1> = ' It is not a good idea to use a command requiring input.'
help<-1> = "J#/any - Join next '#' lines (default 1), separated by 'any'."
help<-1> = "KEEP name # Copy the record 'name' into the kept buffer."
help<-1> = " line #'s will be prompted."
help<-1> = "KEEP f name # Copy the record 'name' from file 'f' into the kept buffer,"
help<-1> = " line #'s will be prompted."
help<-1> = 'KEEPA # KEEPAll - KEEP without line # prompting.'
help<-1> = 'KEPT (K) # Display the kept buffer.'
help<-1> = "L + Repeat the last 'LOCATE' command (L, LA, LN, or LNA)."
help<-1> = "L any + LOCATE the next line that contains the string 'any'."
help<-1> = "L#/any/10-20 + LOCATE in next # lines those with 'any' in columns 10 to 20."
help<-1> = " So 'L#' effectively lists # lines."
help<-1> = "L#!any!THING # LOCATE in next # lines those with 'any' OR 'THING'."
help<-1> = "L#&any&THING # LOCATE in next # lines those with 'any' AND 'THING'."
help<-1> = ' ! and & work this way for LA, LN, and LNA commands too.'
help<-1> = 'LA#/any/1-20 + Locate lines above this one (reverse order).'
help<-1> = "LC# - Change '#' lines to lower case (default 1)."
help<-1> = 'LC# any Comments and quoted strings are unchanged.'
help<-1> = "LL#/length + Show lines 'length' or longer (null '#' is a search)."
help<-1> = "LN#/any/1-20 + LOCATE NOT - line without 'any' in columns 10 to 20."
help<-1> = "LNA#/an/1-20 + LOCATE line above this without 'an' in columns 1 to 20."
help<-1> = "LOAD name - LOAD the record 'name' from the current FILE,"
help<-1> = " line #'s will be prompted."
help<-1> = "LOAD f name - LOAD the record 'name' from file 'f',"
help<-1> = " line #'s will be prompted."
help<-1> = 'LOADA - LOADAll - LOAD without line # prompting.'
help<-1> = 'LD - Synonym for LOAD.'
help<-1> = 'LDA - Synonym for LOADA.'
help<-1> = 'M pattern + Search for a line matching the pattern.'
help<-1> = 'MACRO# + Toggle macro recording into #th PRESTORE command.'
help<-1> = 'MERGE (ME) = Merge a copy of the predefined block after the current line.'
help<-1> = 'MERGEx/y = Merge x lines starting at line y.'
help<-1> = 'MERGE/x/y = Merge lines starting at x to line y inclusive.'
help<-1> = 'MOVE (MV) - Move the predefined block to after the current line.'
help<-1> = 'MOVEx/y = Move the x lines starting at line y.'
help<-1> = 'MOVE/x/y = Move the lines starting at x to line y inclusive.'
help<-1> = 'NUM + Toggle the line numbering.'
help<-1> = "NULL/symbol + Change the null line input for 'I' to 'symbol'."
help<-1> = "OC# any - OConv '#' lines using the conversion 'any'."
help<-1> = 'OOPS - RESTORE the record to the condition prior to last change.'
help<-1> = "OUT# # Outline (labels, gotos, gosubs) for '#' lines (default all)."
help<-1> = 'OUT# CEPS Show Calls, Executes, Performs, and caSe also (* for all).'
help<-1> = 'P + PRINT on Terminal one page worth of lines.'
help<-1> = "P# + PRINT on Terminal '#' lines starting with the current line."
help<-1> = "PA# + PRINT the current line and the prior '#' lines,"
help<-1> = ' do not change the current line pointer.'
help<-1> = "PASTE = Paste the kept buffer after the current line'."
help<-1> = "PASTE name = Copy the kept buffer under the specified 'name'."
help<-1> = "PASTE f name = Copy the kept buffer as record 'name' in file 'f'."
help<-1> = 'PE + Page Edit mode.'
help<-1> = "PL# + PRINT the current line and the next '#' lines,"
help<-1> = ' do not change the current line pointer.'
help<-1> = "PP# + PAGE.PRINT a window of '#' lines around the current line,"
help<-1> = ' do not change the current line pointer.'
help<-1> = 'PR + Show the PRESTORE commands.'
help<-1> = 'PR# + Run the #th PRESTORE command.'
help<-1> = 'PR#/any + Change the #th PRESTORE command.'
help<-1> = ' where / - is any delimiter character which will also be'
help<-1> = ' used as the command separator.'
help<-1> = 'QUIT (Q) + QUIT - EXIT the program.'
help<-1> = 'QUITK (QK) + QuitKill - EXIT the program, abandon any active SELECT list.'
help<-1> = 'R - Replace the line with prompted for text.'
help<-1> = "R any - REPLACE this line with 'any'."
help<-1> = "R#/any - REPLACE # lines with 'any'."
help<-1> = 'R/// - CHANGE one or more lines (same as C/// command).'
help<-1> = "RA = Show last 20 'CHANGE' commands."
help<-1> = "RA# = Repeat #th 'CHANGE' command."
help<-1> = 'RELEASE + RELEASE the update record LOCK for this file.'
help<-1> = "S - Show last 20 'LOCATE' commands."
help<-1> = "S# - Repeat #th 'LOCATE' command."
help<-1> = 'SAVE - SAVE a copy of this record under the original name.'
help<-1> = "SAVE name - SAVE a copy of this record under the specified 'name'."
help<-1> = "SAVE f name - SAVE a copy of this record as record 'name' in file 'f'."
help<-1> = 'SEQ#//// - Build a sequence. Format is:'
help<-1> = ' SEQ#/from/base/inc/cols'
help<-1> = ' where / - is any delimiter character.'
help<-1> = ' # - number of lines to CHANGE (default 1).'
help<-1> = ' from - is the character string to be replaced.'
help<-1> = ' base - is the start number (defaults to 1).'
help<-1> = ' inc - is the increment (defaults to 1).'
help<-1> = ' cols - restricts the change to a column range.'
help<-1> = "SHOW ON/OFF + toggle overriding 'S'how flag for 'C' command."
help<-1> = " OFF won't show more than a page of changes."
help<-1> = ' If neither ON nor OFF is used, then toggle SHOW flag.'
help<-1> = "SORT seq - Sort the predefined block (seq defaults to 'AL')."
help<-1> = "SORTU seq # Sort unique predefined block ('AL' default seq)."
help<-1> = 'SPACE ON/OFF + Switch SPACE flag for L, LA, LN, LNA commands.'
help<-1> = ' If neither ON nor OFF is used, then toggle SPACE flag.'
help<-1> = ' OFF means that the commands will ignore spaces and tabs.'
help<-1> = 'SPOOL + SPOOL entire record to PRINTER.'
help<-1> = "SPOOL# + SPOOL '#' lines to the PRINTER."
help<-1> = 'SPOOLHELP + SPOOL the HELP listing to the default PRINTER.'
help<-1> = "SPOUT# # SPOO outline (labels, gotos, gosubs) for '#' lines (default all)."
help<-1> = 'SPOUT# CEPS Show Calls, Executes, Performs, and caSe also (* for all).'
help<-1> = "STAMP - INSERT a 'last modified' stamp into the record, which"
help<-1> = " begins with a '*' (for BASIC 'comment'), and contains the"
help<-1> = ' account name, LOGIN name (if different from account name),'
help<-1> = ' date and time. Used to mark when record was last changed.'
help<-1> = 'SV - Synonym for SAVE.'
help<-1> = 'T + Set current line to the TOP (before first line).'
help<-1> = "TC# - Change '#' lines to text or mixed case (default 1)."
help<-1> = 'TC# any Comments and quoted strings are unchanged.'
help<-1> = "TRIM# - TRIM '#' lines (default 1)."
help<-1> = "TRIM# a b = TRIM '#' lines of character 'a' with argument 'b'."
help<-1> = "TRIMB# - TRIMB '#' lines (default 1)."
help<-1> = "TRIMF# - TRIMF '#' lines (default 1)."
help<-1> = "TRIPLE#/any = Copy '#' lines (default 1) into three clones, joined by 'any'."
help<-1> = "TWIN#/any = Copy '#' lines (default 1) into two clones, joined by 'any'."
help<-1> = "UC# - Change '#' lines to upper case (default 1)."
help<-1> = 'UC# any Comments and quoted strings are unchanged.'
help<-1> = 'UNLOAD - Synonym for SAVE.'
help<-1> = 'V + Version information.'
help<-1> = 'WHERE (W) + Show the item and file being ':view:'ed.'
help<-1> = 'WM + Show or change the word marker.'
help<-1> = 'X + QuitKill - EXIT the program, abandon any active SELECT list.'
help<-1> = 'XEQ - The XEQ command allows a user to execute any legal PERFORM'
help<-1> = ' command from within the program. Upon completion of the'
help<-1> = ' command, control will be returned back to the program.'
help<-1> = "XTD any + Convert hexadecimal string 'any' to decimal and display it."
help<-1> = '/any + Same as L99999999/any - NOTE you are left at the bottom.'
help<-1> = ".A# any + APPEND 'any' to command '#' (default 1)."
help<-1> = ".C#/// + CHANGE stack command '#' (default 1). Syntax is like 'C'."
help<-1> = ".D# + DELETE stack command '#' (default 1)."
help<-1> = ".I# any + INSERT 'any' at stack position '#' (default 1)."
help<-1> = ".L# + LIST on the Terminal the last '#' stack commands."
help<-1> = ".R# + RECALL (copy) command '#' to stack position 1."
help<-1> = ".S# n m + SAVE stack n to m as prestore '#' (all default to 1)."
help<-1> = ".U# # UPCASE stack command '#' (default 1)."
help<-1> = ".UL# # lower case stack command '#' (default 1)."
help<-1> = ".UT# # text case stack command '#' (default 1)."
help<-1> = ".X# + EXECUTE stack command '#' (default 1)."
help<-1> = ' The command will be put in stack position 1.'
help<-1> = "+# + Advance current line pointer by '#' lines (default 1)."
help<-1> = "-# + Back up current line pointer by '#' lines (default 1)."
help<-1> = "\ # Set a line tag with default label like 'T#'."
help<-1> = "\any # Set a line tag labelled 'any'."
help<-1> = '\\ # Clear the line tags.'
help<-1> = "]any # Go to the line tag 'any'."
help<-1> = "[any # Go to the line tag 'any'."
help<-1> = '] # Go to the next line tag.'
help<-1> = '[ # Go to the previous line tag.'
help<-1> = ']] # Display the line tags.'
help<-1> = '[[ # Display the line tags.'
help<-1> = "# + Set the current line pointer to the '#' line."
help<-1> = '<# + Sets the starting block pointer to # (current line default).'
help<-1> = '># + Sets the ending block pointer to # (current line default).'
help<-1> = '<># # + Set both block pointers at the same time.'
help<-1> = '^ + Switch UP ARROW on/off to show non-printing characters as'
help<-1> = ' ^nnn where nnn is the decimal equivalent of ASCII code.'
help<-1> = '? + Show various parameters - easier to use than explain.'
end
rest = trim(upcase(rest))
if rest eq am then
hard = true
rest = ''
end else hard = false
disp = ''
stub = ''
if rest eq '' then flag = true else flag = false
if rest eq 'NEW' then disp = 'New Features':am
good = false
xxno = dcount(help,am)
for xx = 1 to xxno
temp = help<xx>
bite = temp[1,len(rest)]
bit = temp[14,1]
if index('-+=#',bit,1)
then temp = temp[1,13]:'-':temp[15,huge]
else bit = ''
if bit ne '' then
flag = false
if bit eq '#' and rest eq 'NEW' then flag = true
if (bit eq '#' or bit eq '+') and rest eq '' then flag = true
if not(viewflag) then
if bit eq 'eq' and rest eq 'NEW' then flag = true
if bit eq '=' or bit eq '-' and rest eq '' then flag = true
end
end
if not(flag) and rest ne '' and bite eq rest then
if bit eq '#' or bit eq '+' then flag = true
if not(viewflag) then
if bit eq '=' or bit eq '-' then flag = true
end
end
if flag then
disp<-1> = temp
good = true
end
next xx
if not(good) then
disp := am
disp<-1> = 'No explanation of "':rest:'" is available.'
disp<-1> = 'For a list of words that have explanations, type "HELP".'
disp := am
end
if hard then gosub print.disp else gosub show.disp
return
show.disp:
write disp on voc,'&DISP.':whom
if stub eq '' then stub = 'Press return to continue showing explanation, Q to quit'
xxno = dcount(disp,am)
pg = 0
for xx = 1 to xxno
pg += 1
if pg ge system(3) then
loop
rlen = 1
gosub get.rope; answ = rope
crt begn:ceol:
answ = trim(upcase(answ))[1,1]
until index('QT-',answ,1) do
repeat
if answ eq 'Q' then return
if answ eq 'T' then xx = 1
if answ eq '-' then
xx -= 2*(system(3)-1)
if xx lt 1 then xx = 1
end
pg = 1
end
crt disp<xx>
next xx
disp = ''
return
print.disp:
printer on
heading upcase(verb):" help file ":timedate():"'LL'"
xxno = dcount(disp,am)
for xx = 1 to xxno
print disp<xx>
next xx
printer close
return
get.page.comd:
gosub get.keyc
do.page.comd:
locate(keyc,keys;cpos) then cpos = acts<cpos> else cpos = 0
begin case
case cpos eq uarr ;* up key
if here le 1 then crt bell:; return
gosub check.page
here -= 1
if prow le 1 then
ptop = ptop - botl
if ptop lt 1 then ptop = 1
gosub disp.page
end
gosub get.line; temp = line
case cpos eq darr ;* down key
if here ge last then crt bell:; return
gosub check.page
here += 1
if prow ge botl then
ptop = ptop + botl
if ptop ge last then ptop = last - botl + 1
if ptop le 1 then ptop = 1
gosub display.page
end
gosub get.line; temp = line
case cpos eq larr ;* left key
if pchr le 1 then crt bell:; return
pchr -= 1
if pchr lt ppos then
gosub check.page
gosub disp.page
end
case cpos eq rarr ;* right key
pchr += 1
if pchr-ppos ge span then
gosub check.page
gosub disp.page
end
case cpos eq upag ;* page up key
gosub check.page
ptop -= botl
if ptop lt 1 then ptop = 1
here -= botl
if here lt 1 then here = 1
pchr = 1
gosub get.line; temp = line
gosub disp.page
case cpos eq dpag ;* page down key
gosub check.page
ptop = ptop + botl
if ptop ge last then ptop = last - botl + 1
here = here + botl
if here gt last then here = last
pchr = 1
gosub get.line; temp = line
gosub disp.page
case cpos eq lpag ;* start of line key
pchr = 1
if pchr lt ppos then gosub check.page; gosub disp.page
case cpos eq rpag ;* end of line key
pchr = len(temp)+1
if pchr lt ppos then gosub check.page; gosub disp.page
if pchr-ppos ge span then
gosub check.page
gosub disp.page
end
case cpos eq tpag ;* top page key
gosub check.page
here = 1
ptop = 1
pchr = 1
gosub disp.page
gosub get.line; temp = line
case cpos eq bpag ;* bottom page key
gosub check.page
here = last
ptop = last - botl + 1
gosub get.line
pchr = len(line)+1
gosub disp.page
gosub get.line; temp = line
case cpos eq escp ;* escape key
if this ne that then
crt @(0,botl):ceol:revb:'ABANDONING CHANGES':revf
end
this = that
here = savl<1>
gosub set.record
mode = 'LINE'
case cpos eq phlp ;* help key
gosub check.page
gosub page.help
case cpos eq zoom ;* Go to line key
crt bott:
stub = 'Go to line :'
stay = pchr
gosub get.rope; numb = trim(rope)
pchr = stay
crt bott:revb:'Press <F1> for help.':revf:
if not(numb matches '1N0N') then numb = here
if numb gt last then numb = last
if numb eq here then return
gosub check.page
here = numb
ptop = here
pchr = 1
gosub disp.page
gosub get.line; temp = line
case cpos eq skey ;* forward search
crt bott:
stub = 'Search: ':'> '
stay = pchr
pick = lastfind; gosub get.rope; lastfind = rope
pchr = stay
crt bott:revb:'Press <F1> for help.':revf:
if lastfind eq '' then return
* is it in this line or the rest of the item?
test = index(temp[pchr+1,huge],lastfind,1)
save = here
gosub check.page
if test then
test += pchr
end else
dawn = here+1
dusk = last
for here = dawn to dusk until test
gosub get.line
test = index(line,lastfind,1)
if test then save = here
next here
end
if test then
if save lt ptop or save ge (ptop+botl) then ptop = save
here = save
pchr = test
gosub disp.page
end else here = save
gosub get.line; temp = line
case cpos eq rkey ;* reverse search
crt bott:
stub = 'Search: ':'< '
stay = pchr
pick = lastfind; gosub get.rope; lastfind = rope
pchr = stay
crt bott:revb:'Press <F1> for help.':revf:
if lastfind eq '' then return
* is it in this line before the cursor position or the rest of the item above?
test = index(temp[1,pchr-1],lastfind,1)
save = here
gosub check.page
if not(test) then
dawn = 1
dusk = here-1
for here = dusk to dawn step -1 until test
gosub get.line
what = count(line,lastfind)
if what then
test = index(line,lastfind,what)
save = here
end
next here
end
if test then
if save lt ptop or save ge (ptop+botl) then ptop = save
here = save
pchr = test
gosub disp.page
end else here = save
gosub get.line; temp = line
case not(sec.write.flg)
crt bell:
case cpos eq delc ;* delete character key
if temp eq '' then return
if pchr eq 1 then
temp = temp[2,len(temp)]
end else
temp = temp[1,pchr-1]:temp[pchr+1,len(temp)]
end
crap = temp[pchr,span-pcol]
convert badc to gudc in crap
crt @(pcol,prow):ceol:crap:
case cpos eq dell ;* delete line key
del this<here>
gosub set.record
gosub disp.page
gosub get.line; temp = line
case cpos eq delr ;* delete to end of line key
if pchr gt len(temp) then
if here ge last then crt bell:; return
line = fmt(temp,'l#':pchr-1):this<here+1>
del this<here>
this<here> = line
gosub set.record
gosub disp.page
gosub get.line; temp = line
end else
temp = temp[1,pchr-1]
this<here> = temp
memr(cell)<lnum> = temp
line = temp
crt @(pcol,prow):ceol:
end
case cpos eq back ;* backspace key
if pchr eq 1 then crt bell:; return
pchr -= 1
temp = temp[1,pchr-1]:temp[pchr+1,len(temp)]
if pchr lt ppos then
gosub check.page
gosub disp.page
end else
pcol = rem(pchr-1,span)
crt @(pcol,prow):ceol:
crap = temp[pchr,span-pcol]
convert badc to gudc in crap
crt crap:
end
case cpos eq carr ;* carriage return key
if pchr eq 1 then
line = ''
end else
line = temp[1,pchr-1]
temp = temp[pchr,len(temp)]
end
if lnum eq 0 then lnum = 1
memr(cell)<lnum> = line
last += 1
lnum += 1
line = temp
gosub insert.line
gosub reset.record
here += 1
pchr = 1
if prow ge botl then
ptop = ptop + botl
if ptop ge last then ptop = last - botl + 1
if ptop le 1 then ptop = 1
gosub display.page
end else gosub disp.page
gosub get.line; temp = line
case cpos eq togg ;* toggle mode key
if mode<2> eq 'Ins' then
mode<2> = 'Rep'
end else mode<2> = 'Ins'
case cpos eq writ ;* write away data key
gosub check.page
mode = 'LINE'
case seq(keyc) lt 28 or seq(keyc) gt 127 or len(keyc) gt 1
crt bell:
case seq(keyc) eq 30 or seq(keyc) eq 31
crt bell:
case 1
if seq(keyc) eq 28 then keyc = char(252)
if seq(keyc) eq 29 then keyc = char(253)
if pchr and len(temp) lt (pchr-1) then
temp = temp:str(' ',pchr)
temp = temp[1,pchr-1]
end
if mode<2> eq 'Ins'
then offset = pchr
else offset = pchr+1
if pchr eq 1
then temp = keyc:temp[offset,len(temp)]
else temp = temp[1,pchr-1]:keyc:temp[offset,len(temp)]
if mode<2> eq 'Ins' then
crt @(pcol,prow):ceol:
crap = temp[pchr,span-pcol]
end else crap = keyc
convert badc to gudc in crap
crt @(pcol,prow):crap:
pchr += 1
if pchr-ppos ge span then
gosub check.page
gosub disp.page
end
end case
return
check.page:
if '*':temp ne '*':line then
memr(cell)<lnum> = temp
gosub reset.record
end
return
page.help:
gosub clear.page
if pagehelp eq '' then
if sec.write.flg then
pagehelp = ''
pagehelp<-1> = ' Page editing help'
pagehelp<-1> = ''
pagehelp<-1> = ' Cursor movement keys Line movement keys'
pagehelp<-1> = ''
pagehelp<-1> = ' UP = <UP arrow> or ^Z LEFT END = <Home> or ^A'
pagehelp<-1> = ' DOWN = <DOWN arrow> or ^J RIGHT END = <End> or ^E'
pagehelp<-1> = ' LEFT = <LEFT arrow> or ^U GO TO LINE = ^G'
pagehelp<-1> = ' RIGHT = <RIGHT arrow> or ^F (prompts for desired line)'
pagehelp<-1> = ''
pagehelp<-1> = ' Page movement keys Deleting keys'
pagehelp<-1> = ''
pagehelp<-1> = ' PREVIOUS = <Page Up> or ^P DELETE CHAR = <Delete> or ^D'
pagehelp<-1> = ' NEXT = <Page Down> or ^N DELETE LINE = <Ctrl-Home> or ^X'
pagehelp<-1> = ' TOP = <Ctrl-Page Up> or ^T DELETE TO EOL = <Ctrl-End> or ^K or ^R'
pagehelp<-1> = ' BOTTOM = <Ctrl-Page Down> or ^B'
pagehelp<-1> = ' <Ctrl-]> = Value Mark'
pagehelp<-1> = ' <Backspace> is destructive <Ctrl-\> = Sub-value Mark'
pagehelp<-1> = ' <Enter> splits the line'
pagehelp<-1> = ' <Insert> or <Tab> toggles between the insert and overwrite modes'
pagehelp<-1> = ''
pagehelp<-1> = ' <F2> or ^W Returns to line editor mode WITH changes'
pagehelp<-1> = ' <Esc> or ^Q Returns without changes'
end else
pagehelp = ''
pagehelp<-1> = ' Page viewing help'
pagehelp<-1> = ''
pagehelp<-1> = ' Cursor movement keys Line movement keys'
pagehelp<-1> = ''
pagehelp<-1> = ' UP = <UP arrow> or ^Z LEFT END = <Home> or ^A'
pagehelp<-1> = ' DOWN = <DOWN arrow> or ^J RIGHT END = <End> or ^E'
pagehelp<-1> = ' LEFT = <LEFT arrow> or ^U GO TO LINE = ^G'
pagehelp<-1> = ' RIGHT = <RIGHT arrow> or ^F (prompts for desired line)'
pagehelp<-1> = ''
pagehelp<-1> = ' Page movement keys '
pagehelp<-1> = ''
pagehelp<-1> = ' PREVIOUS = <Page Up> or ^P '
pagehelp<-1> = ' NEXT = <Page Down> or ^N '
pagehelp<-1> = ' TOP = <Ctrl-Page Up> or ^T'
pagehelp<-1> = ' BOTTOM = <Ctrl-Page Down> or ^B'
pagehelp<-1> = ''
pagehelp<-1> = ''
pagehelp<-1> = ' <Esc> or ^Q Returns without changes'
end
end
disp = pagehelp ; stub = ''
gosub show.disp
crt bott:
stub = 'Press RETURN to continue'
gosub get.rope
gosub display.page
return
get.line:
line = ''
if here eq 0 then
cell = 1
lnum = 0
return
end
if here gt last then return
cell = int((here-1)/cellsize) + 1
coff = rem(here,cellsize)
if ooff and ocel eq cell and ooff eq coff - 1 then
lnum = ooff ; ooff = coff
end else
tlin = memr(cell)
lnum = 0 ; ocel = cell ; ooff = coff
end
loop
remove bite from tlin setting dlim
line = line:bite
while dlim do
if dlim eq 2 then
lnum += 1
if lnum eq coff then exit
line = ''
end else
line = line:char(256-dlim)
end
repeat
if not(dlim) then lnum += 1
return
delete.lines:
chng = 0
if dawn gt dusk then
crt 'No deletion possible - ':dawn:' > ':dusk:'.'
return
end
gosub savethat
chng = dusk - dawn + 1
begin case
case dawn le 1 and dusk ge last
krj = ''
this = ''
beg = 0
fin = 0
case dusk ge last
temp = index(this,am,dawn-1)
this = this[1,temp-1]
if beg gt dawn then beg = 0
if fin gt dawn then fin = 0
for xx = dcount(krj<1>,vm) to 1 step -1
if krj<2,xx> gt dawn then
del krj<1,xx> ; del krj<2,xx> ; krj<3> -= 1
end
next xx
case dawn eq 1
temp = index(this,am,dusk)
this = this[temp+1,len(this)]
if beg le dusk then beg = 0 else beg = beg - chng
if fin le dusk then fin = 0 else fin = fin - chng
for xx = dcount(krj<1>,vm) to 1 step -1
if krj<2,xx> le dusk then
del krj<1,xx> ; del krj<2,xx> ; krj<3> -= 1
end
next xx
case 1
temp = index(this,am,dawn-1)
temp<2> = index(this,am,dusk)
this = this[1,temp<1>]:this[temp<2>+1,len(this)]
if beg ge dawn and beg le dusk then beg = 0 else
if beg gt dusk then beg -= chng
end
if fin ge dawn and fin le dusk then fin = 0 else
if fin gt dusk then fin -= chng
end
for xx = dcount(krj<1>,vm) to 1 step -1
begin case
case krj<2,xx> gt dusk ; krj<2,xx> -= chng
case krj<2,xx> ge dawn
del krj<1,xx> ; del krj<2,xx> ; krj<3> -= 1
end case
next xx
end case
begin case
case here gt dusk
here = here - dusk + dawn - 1
case here gt dawn
here = dawn
end case
gosub set.record
return
check.line:
if '*':temp ne '*':line then
if not(chng) then gosub savethis
chng += 1
memr(cell)<lnum> = temp
if shew or dnum lt plen then gosub display.line
end
return
insert.line:
if here le beg then beg += 1
if here le fin then fin += 1
yyno = dcount(krj<1>,vm)
for yy = 1 to yyno
if krj<2,yy> gt here then krj<2,yy> += 1
next yy
memr(cell) = insert(memr(cell),lnum,0,0,line)
if lfmt and len(last) gt 3 and len(last) ne llen then gosub get.lfmt
return
display.line:
begin case
case last eq 0
here = 0
gosub get.line
crt begn:'Top of empty record.'
case here eq 0
gosub get.line
crt 'Top.'
case here gt last
crt 'Bottom.'
case 1
gosub get.line
if wild then
xxno = len(line)
temp = ''
for xx = 1 to xxno
bite = line[xx,1]
bite = seq(bite)
if bite ge 127 or bite lt 32 then
$ifdef unidata
bite = '^':fmt(bite,'3/0R')
$else
bite = '^':fmt(bite,'R%3')
$endif
end else bite = char(bite)
temp = temp:bite
next xx
line = temp
end else convert badc to gudc in line
crt begn:ceol:
if lfmt then
blk = ': '
if here eq beg then blk = '< '
if here eq fin then blk = '> '
if here eq beg and here eq fin then blk = '<>'
if lfmt then crt (here lfmt):blk:
end
if bleach then
crt line
end else
if here ge beg and here le fin
then showline = @(-13):@(-5):line:@(-6):@(-14)
* else call SORT.LINE(showline,line,1,len(line),lastfind,caseflag)
else setoff = 1 ; width = len(line) ; gosub getshowline
crt showline
end
dnum += 1
if here eq last then crt 'Bottom at line ':last:'.'
end case
return
clear.page:
for xx = system(3)-1 to 0 step -1
crt @(00,xx):ceol:
next xx
return
display.page:
crt clpg
disp.page:
if pchr lt 1 then pchr = 1
gosub clear.page
gosub get.lfmt
crt bott:revb:'Press <F1> for help.':revf:
crt @(0,0):ceol:revb:
if viewflag
then crt 'Viewing "':item:'" in file "':fnam:'"':
else crt 'Editing "':item:'" in file "':fnam:'"':
crt revf:
if idcnt gt 1 then crt ' <':id:'/':idcnt:'> ':
crt
ppos = int((pchr-1)/span)
ppos = span*ppos+1
save = here:am:lnum:am:cell:am:line
for xx = 1 to botl
here = ptop + xx - 1
gosub get.line
if bleach then
disp = line[ppos,span]
convert badc to gudc in disp
end else
convert badc to gudc in line
disp = line
if here ge beg and here le fin
then showline = @(-13):@(-5):disp[ppos,span]:@(-6):@(-14)
* else call SORT.LINE(showline,disp,ppos,span,lastfind,caseflag)
else setoff = ppos ; width = span ; gosub getshowline
disp = showline
end
crt @(0,xx):disp:
next xx
here = save<1>; lnum = save<2>; cell = save<3>; line = save<4>
return
savethis:
oops = this ; oopc = comi ; oopl = save ; oopf = savl
oopb = beg:am:fin ; oopk = krj
* if level eq 0 then write oops on voc, '&LED.':whom
return
savethat:
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin ; oopk = krj
* if level eq 0 then write oops on voc, '&LED.':whom
return
reset.record:
matbuild this from memr using am
set.record:
gosub parse.record
gosub get.line
if len(last) gt 3 and len(last) ne llen then gosub get.lfmt
return
parse.record:
this = this
ocel = '' ; ooff = ''
last = dcount(this,am)
if last eq 0 then
dim memr(1)
mat memr = ''
cell = 1 ; lnum = 0
return
end
numcells = int((last-1)/cellsize)+1
dim memr(numcells)
mat memr = ''
cell = 1
lnum = 0
for cell = 1 to numcells
memr(cell) = field(this,@am,(cell-1)*cellsize+1,cellsize)
next cell
! line = ''
! loop
! remove bite from this setting mark
! line = line:bite
! begin case
! case mark eq 0
! if line ne '' then
! line = line[1,len(line)]
! end
! memr(cell) = line
! case mark eq 2
! lnum += 1
! if lnum ge cellsize then
! memr(cell) = line
! line = ''
! cell += 1
! lnum = 0
! end else
! line = line:char(256-mark)
! end
! case 1
! line = line:char(256-mark)
! end case
! while mark do
! repeat
cell = 1
lnum = 0
return
locked.record:
stub = 'Record is currently locked by another user. Try again? ':ny:' '
gosub get.rope; answ = rope
answ = upcase(trim(answ))
if answ eq 'PASSWORD' then
lock = false
read this from file, item then goto carry.on
end
if answ[1,1] eq yes[1,1] then goto edit.item
return
exec.that:
temp = temp<1>:' ':fnam:' ':item:temp<2>
if fileinfo(file,3) ne '4' then
crt 'Cannot ':temp:' - must be type 1 or 19'
return
end
execute temp
test = @(0,0)
return
parse.rest:
bite = ''
flag = ''
posn = 1
xxno = len(rest)
for xx = 1 to xxno
bit = rest[xx,1]
if flag eq '' then
if bit eq ' ' then
if bite<posn> ne '' then posn += 1
end else
if index(qt,bit,1) then
flag = bit
if keepquot then bite<posn> = bite<posn>:bit
end else
if bit eq '(' then
flag = ')'
if bite<posn> ne '' then posn += 1
bite<posn> = '('
end else bite<posn> = bite<posn>:bit
end
end
end else
if bit ne flag then
bite<posn> = bite<posn>:bit
end else
if keepquot or bit eq ')' then bite<posn> = bite<posn>:bit
posn += 1
flag = ''
end
end
next xx
return
split.itype:
bite = ''
flag = ''
posn = 1
xxno = len(line)
for xx = 1 to xxno
bit = line[xx,1]
if flag eq '' then
if bit eq ';' then
posn += 1
end else
if index(qt,bit,1) then flag = bit
if bit eq '(' then flag = ')'
bite<posn> = bite<posn>:bit
end
end else
if bit eq flag[1,1] then flag = flag[2,huge]
if bit eq '(' and flag[1,1] eq ')' then flag := ')'
bite<posn> = bite<posn>:bit
end
next xx
return
get.lfmt:
* set up the line format
llen = len(last)
if llen lt 3 then llen = 3
$ifdef unidata
lfmt = llen:'/0R'
$else
lfmt = 'R%':llen
if index(item,'_IType.',1) then lfmt = llen:'@R'
$endif
prmt = '*':str('-',llen-1)
return
leftarr: *
numb = oconv(trim(comi[2,len(comi)]),'MCN')
if numb eq '' then numb = here
if numb gt last then numb = ''
if numb ge 0 then
crt 'Block starts at line ':numb:
beg = numb
if fin and beg gt fin then
crt '; End moved from ':fin:' to ':beg
fin = beg
mov = 1
end else
if fin then mov = fin - beg + 1 else mov = last - beg
crt ' (':mov:' lines)'
end
if numb eq here then gosub display.line
end else crt 'Cannot mark line ':numb
return
rightarr: *
numb = oconv(trim(comi[2,len(comi)]),'MCN')
if numb eq '' then numb = here
if numb gt last then numb = ''
if numb ge 0 then
crt 'Block ends at line ':numb:
fin = numb
if beg gt fin then
crt '; Start moved from ':beg:' to ':fin
beg = fin
mov = 1
end else
if beg then mov = fin - beg + 1 else mov = fin
crt ' (':mov:' lines)'
end
if numb eq here then gosub display.line
end else crt 'Cannot mark line ':numb
return
botharr: *
numb = trim(comi[3,len(comi)])
begin case
case numb matches '1N0N'
numb = numb:am:numb
case numb matches '1N0N"-"1N0N'
numb = field(numb,'-',1):am:field(numb,'-',2)
case numb matches '1N0N" "1N0N'
numb = field(numb,' ',1):am:field(numb,' ',2)
case numb eq ''
numb = here:am:here
case 1
numb = ''
end case
if numb<2> gt last then numb<2> = last
if numb<1> gt last then numb = ''
if numb<2> lt numb<1> then
crt 'Block starts at ':numb<1>:' and ends at ':numb<2>:' => ':
numb = ''
end
if numb ne '' then
beg = numb<1>
fin = numb<2>
if beg eq fin then
crt 'Block starts and ends at line ':beg
end else
crt 'Block starts at ':beg:' and ends at ':fin
end
if here eq beg or here eq fin then
gosub display.line
end
end else crt 'Cannot mark Block'
return
recalc.posn:
begin case
case posn lt rest and posn le oopl
case posn lt rest and posn gt oopl
posn += numb
case posn ge rest and posn lt (rest+numb)
posn += (here+1-rest)
case posn ge (rest+numb) and posn le oopl
posn -= numb
end case
return
find.label:
temp = field(trimf(line),' ',1)
temp = trim(temp,char(13),'B')
chit = temp[1,1]
begin case
case chit eq '*' or chit eq '!' ; temp = ''
case chit matches '1N' or chit eq '.'
temp = field(temp,'*',1)
temp = field(temp,'!',1)
temp = field(temp,':',1)
test = convert('.0123456789','',temp)
if test ne '' then temp = ''
case chit matches '1A' and index(temp,':',1)
temp = field(temp,':',1)
test = oconv(oconv(temp,'MC/A'),'MC/N')
test = convert('._%$','',test)
if test ne '' then temp = ''
case 1
temp = ''
end case
return
get.answ:
loop
*>
rlen = 1
*>
gosub get.rope
answ = upcase(trim(rope)[1,1])
until answ eq yes[1,1] or answ eq no[1,1] do
crt 'Please answer Y or N'
repeat
crt
return
writerr:
$ifdef qm
if status() eq er$trigger then
crt 'Data validation error: ': @trigger.return.code
end else
crt 'Write error ': status():' (o/s error %2) - Data not saved. Original data will be lost if you leave the editor now.'
end
$else
crt 'Write error ': status():' (o/s error %2) - Data not saved. Original data will be lost if you leave the editor now.'
$endif
return
indenter:
marg = fr(1) ;* the margin
dent = fr(2) ;* the indentation
supp = fr(6) ;* flag - suppress '!' output
astx = not(fr(9)) ;* flag - keep '*' comments on page edge
suit = not(fr(10)) ;* flag - indent 'CASE' statements
dead = 'ACDGHIJKMPQSVXYZ'
push = 'LOOP\WHILE\UNTIL\FOR\THEN\ELSE\BEGIN\LOCKED\ON~ERROR'
pull = 'UNTIL\WHILE\REPEAT\NEXT\END'
convert '\' to am in push
convert '\' to am in pull
skip = ';:" (' : "'"
marx = '\"' : "'"
bang = false
xxno = dcount(this,am)
dim part(100)
matparse part from this, am
this = ''
bite = ''
first = true
for xx = 1 to xxno
there = rem(xx,100)
if not(there) then
if first then this = bite else this = this:am:bite
first = false
bite = ''
thisline = part(100)
temp = part(0)
matparse part from temp, am
if not(supp) then bang = true; crt '!':
end else thisline = part(there)
if trim(thisline) eq '' then
if first then bite<there> = '' else bite<there+1> = ''
continue
end
note = false
wcnt = 0; more = 0; less = 0
mark = ''; tags = ''; lastword = ''
zz = 1
thisline = trimf(thisline)
if thisline matches '1N0N"*"0X' then
temp = field(thisline,'*',1)
thisline = temp:' ':thisline[col2(),len(thisline)]
end
thatline = upcase(thisline)
thatline = change(thatline, 'ON ERROR', 'ON~ERROR')
left = field(thatline,' ',1)
if num(left) or left[len(left),1] eq ':' then
if not(index(left,'=',1)) then tags = thisline[1,len(left)]
end
if tags gt '' then
thisline = trimf(thisline[col2()+1,len(thisline)])
thatline = trimf(thatline[col2()+1,len(thatline)])
end
zzno = len(thisline)
loop
while zz lt zzno and not(note) do
loop
thisun = thatline[zz,1]
begin case
case mark eq '' and index(marx,thisun,1)
mark = thisun
case mark ne ''
if thisun eq mark then mark = ''
case wcnt and thisun eq ';'
that = field(trim(thatline[zz+1,zzno]),' ',1)
if that[1,3] eq 'REM' then that = ''
if that[1,1] eq '*' then that = ''
if that[1,1] eq '!' then that = ''
if that eq '' then zz = zzno
case wcnt
case thisun eq '!' or thisun eq '$'
note = true; zz = zzno
case thisun eq '*'
if astx then note = true
zz = zzno
case field(thatline,' ',1) eq 'REM'
note = true; zz = zzno
end case
while (index(skip,thisun,1) or mark) and zz lt zzno do
zz += 1
repeat
left = zz
loop
thisun = thatline[zz,1]
until index(skip,thisun,1) or zz gt zzno do
zz += 1
repeat
word = thatline[left,zz-left]
wcnt += 1
if wcnt ne 1 then
if word eq 'WHILE' or word eq 'UNTIL' then word = ' '
if word eq 'NEXT' or word eq 'REPEAT' then
word = ' '
more -= dent
end
if lastword eq 'LOCKED' then more -= dent
end else
if word eq 'LOCKED' or word eq 'THEN' then
if word eq trim(thatline) then less += dent
end
end
if word eq 'CASE' then
if lastword ne 'BEGIN' and lastword ne 'END' then
more += dent
less += dent
end
if suit and lastword eq 'BEGIN' then more += dent
if suit and lastword eq 'END' then less += dent
end
if not(index(dead,word[1,1],1)) then
locate(word,pull;rubbish) then less += dent
test = word ne 'THEN' & word ne 'ELSE' & word ne 'ON~ERROR'
that = trim(thisline[zz,zzno])
if that[1,1] eq ';' then
that = trim(that[2,zzno])[1,3]
if that[1,3] eq 'REM' then that = ''
if that[1,1] eq '*' then that = ''
if that[1,1] eq '!' then that = ''
end
if test or that eq '' then
locate(word,push;rubbish) then
more += dent
end
end
if word eq 'THEN' or word eq 'LOCKED' then
if that eq '' and lastword eq '' then less -= dent
end
if that ne '' and lastword eq '' then
if word eq 'THEN' or word eq 'ELSE' then
more -= dent
less -= dent
end
if word eq 'LOCKED' and trim(that)[1,1] ne '='
then more -= dent ; less -= dent
end
end
lastword = word
repeat
marg -= less
if tags eq '' then pict = '' else pict = 'L#':(len(tags)+1)
if marg gt len(tags) then pict = 'L#':marg
if thisline eq '!' or thisline eq '$' then note = true
if thatline eq 'REM' then note = true
if astx and thisline eq '*' then note = true
if note then
if tags eq '' then pict = '' else pict = 'L#':(len(tags)+1)
end
thisline = trimb(fmt(tags,pict):thisline)
if first then
bite<there> = thisline
end else bite<there+1> = thisline
marg += more
next xx
if bang then crt
if bite ne '' then
if first then this = bite else this = this:am:bite
end
that = ''
return
get.rope:
* If the terminal doesn't support screen addressing, do simple input
if not(editpage) then
crt begn:stub:
*> input rope:
if rlen then
input rope,rlen:
rlen = 0
end else input rope:
*>
return
end
*
* The following variables are used
*
* BARE - what you are going to reveal (the displayed part)
* CRAM - insert mode on (vs overwrite mode)
* PCOL - display position
* STEM - the prefix part of the display line
* ICON - a picture of what you last displayed
* PANS - the PAN increment
* PPOS - the PAN origin
* WIDE - the PAN width
* PULP - SEQ(COMI) - what you get from a key press
* PURE - untouched, a virgin
* POSN - the stack position
* PCHR - text position
pans = int(span/2)
posn = 0
rope = pick; pick = ''
loop
if heap then
stem = prmt:': '
if posn then stem = '*':fmt(posn, "3'0'R"):stem[5,huge]
end else stem = '*':stub
wide = span - len(stem) - 1
pans = int(wide/2)
ppos = 1
pchr = 1
cram = true
icon = space(span)
crt begn : ceol :
pure = true
!&&&
! if nick and trim(rope) = '' then pchr = len(rope)+1 ; pure = false
!&&&
loop
begin case
*> case pchr lt ppos ; ppos -= pans
case pchr lt ppos
loop while pchr lt ppos ; ppos -= pans ; repeat
case pchr ge (ppos+wide)
loop while pchr ge(ppos+wide) ; ppos += pans ; repeat
*> case pchr ge (ppos+wide) ; ppos += pans
end case
bare = stem : rope[ppos, wide]
pcol = 0
if icon ne bare then
yyno = 0
for yy = 1 to span until yyno
if bare[yy,1] ne icon[yy,1] then yyno = yy
next yy
crt @(yyno-1):bare[yyno,span-yyno]:ceol:@(pcol):
icon = bare[1,span]
end
pcol = len(stem) + pchr - ppos
crt @(pcol) :
gosub get.keyc
locate(keyc,keys;cpos) then cpos = acts<cpos> else cpos = 0
pulp = seq(keyc)
if pulp lt 32 or pulp gt 128 then keyc = ''
if pure then
if cpos eq 0 and keyc ne '' then
rope = ''
pchr = 1
end
crt @(0):
if cram then crt '>': else crt '#':
crt @(pcol):
pure = false
end
begin case
case heap and (cpos = uarr or cpos = upag)
if posn lt dcount(stak, vm) then
posn += 1
rope = stak<1,posn>
end
exit
case heap and (cpos = darr or cpos = dpag)
if posn gt 1 then
posn -= 1
rope = stak<1,posn>
end else
posn = 0
rope = ''
end
exit
case heap and cpos = skey
if rope eq '' then
if look<1> eq '' then continue
comi = look<1,1>
gosub parse.command
rope = 'L':dlim:rest
end else rope = 'L/':rope
if rope eq look<1> then rope = 'L'
return
case heap and cpos = rkey
if rope eq '' then
if look<1> eq '' then continue
comi = look<1,1>
gosub parse.command
rope = 'LA':dlim:rest
end else rope = 'LA/':rope
if rope eq look<1> then rope = 'L'
return
case heap and cpos = writ and pulp ne 23
rope = 'PE'
return
case heap and cpos = phlp
stub = '' ; heap = false ; rest = ''
gosub show.help
rope = 'D'
return
case cpos = larr
if pchr gt 1 then pchr -= 1
case cpos = rarr
if pchr le len(rope) then pchr += 1
case cpos = lpag
pchr = 1
case cpos = rpag
pchr = len(rope) + 1
case cpos = escp
posn = 0
rope = ''
exit
case cpos = delc
rope = rope[1, pchr-1] : rope[pchr+1, huge]
case cpos = delr
rope = rope[1, pchr-1]
case cpos = back
if pchr gt 1 then
pchr -= 1
rope = rope[1, pchr-1] : rope[pchr+1, huge]
end
case cpos = carr
if heap then
crt begn : ceol : ':' : rope:
if posn then
if rope eq stak<1,posn> then del stak<1,posn>
end
end
return
case cpos = togg
cram = not(cram)
crt @(0):
if cram then crt '>': else crt '#':
crt @(pcol):
case pulp eq 23 ;* ctrl-w
dope = downcase(rope)
mope = upcase(rope)
tope = oconv(rope,'MCT')
begin case
case rope eq tope and dope eq tope ; rope = mope
case rope eq tope ; rope = dope
case rope eq mope ; rope = tope
case 1 ; rope = mope
end case
case pulp ge 32 and pulp lt 128
if cram then
rope = rope[1, pchr-1] : keyc : rope[pchr, huge]
end else
if pchr le len(rope)
then rope[pchr, 1] = keyc
else rope := keyc
end
pchr += 1
case 1
crt bell:
end case
if rlen and len(rope) ge rlen then
crt keyc:
rlen = 0
return
end
repeat
repeat
return
get.keyc:
$ifdef qm
if not(index(upcase(system(7)),'EEEPC',1)) then
keyc = keycode()
return
end
$endif
common /keys$krj/ termtype,eseq,keyd,base,full
if not(assigned(termtype)) then termtype = ''
if termtype ne oconv(system(7),'MCU') then gosub setup.keys
keyc = ''
loop
$ifdef unidata
mine = in()
$else
mine = keyin()
$endif
locate(mine,base;post) then gosub get.rest
locate(mine,eseq;cmd)
then keyc = char(keyd<cmd>)
else if len(mine) eq 1 then keyc = mine
while keyc eq '' do repeat
return
get.rest:
loop
$ifdef unidata
a = system(12)
loop
until system(12) ge (a+5) do
repeat
$else
nap 5
$endif
input your,-1
while your do
$ifdef unidata
mine := in()
$else
mine := upcase(keyin())
$endif
locate(mine,full,post;your) then return
repeat
return
setup.keys:
* Define the key numbers - these are based on QM keycode()
*======================================================================
* Arrow keys
equ lark to 203, rark to 204, uark to 205, dark to 206
* Page up and down, home and end
equ upak to 207, dpak to 208, homk to 209, endk to 210
* Insert, delete, backtab, delete line, backspace
equ insk to 211, deck to 212, btbk to 213, delk to 127, bspk to 8
* Control - Page up and down, homk and end
equ cupk to 214, cdpk to 215, chok to 216, cenk to 217
* Function, Control+Function, Alt+Function, Shift+Function
equ f1 to 128, cf1 to 140, af1 to 152, sf1 to 164
equ f2 to 129, cf2 to 141, af2 to 153, sf2 to 165
equ f3 to 130, cf3 to 142, af3 to 154, sf3 to 166
equ f4 to 131, cf4 to 143, af4 to 155, sf4 to 167
equ f5 to 132, cf5 to 144, af5 to 156, sf5 to 168
equ f6 to 133, cf6 to 145, af6 to 157, sf6 to 169
equ f7 to 134, cf7 to 146, af7 to 158, sf7 to 170
equ f8 to 135, cf8 to 147, af8 to 159, sf8 to 171
equ f9 to 136, cf9 to 148, af9 to 160, sf9 to 172
equ f10 to 137, cf10 to 149, af10 to 161, sf10 to 173
equ f11 to 138, cf11 to 150, af11 to 162, sf11 to 174
equ f12 to 139, cf12 to 151, af12 to 163, sf12 to 175
*======================================================================
* Stash the escape sequences and key codes in labelled common
termtype = oconv(system(7),'MCU')
* Set up keys good for many terminals and as defaults
eseq = '' ; keyd = ''
keyd<-1> = lark; eseq<-1> = char(21)
keyd<-1> = rark; eseq<-1> = char(6)
keyd<-1> = uark; eseq<-1> = char(26)
keyd<-1> = dark; eseq<-1> = char(10)
keyd<-1> = homk; eseq<-1> = char(1)
keyd<-1> = endk; eseq<-1> = char(5)
keyd<-1> = deck; eseq<-1> = char(4)
keyd<-1> = upak; eseq<-1> = char(27):'[5~'
keyd<-1> = dpak; eseq<-1> = char(27):'[6~'
* Now do settings that don't interfere between terminals
* VT-type terminals - cater for alternative arrow sequences
keyd<-1> = rark; eseq<-1> = char(27):'[C'
keyd<-1> = rark; eseq<-1> = char(27):'OC'
keyd<-1> = uark; eseq<-1> = char(27):'[A'
keyd<-1> = uark; eseq<-1> = char(27):'OA'
keyd<-1> = dark; eseq<-1> = char(27):'[B'
keyd<-1> = dark; eseq<-1> = char(27):'OB'
keyd<-1> = insk; eseq<-1> = char(27):'[1~'
keyd<-1> = deck; eseq<-1> = char(27):'[4~'
keyd<-1> = btbk; eseq<-1> = char(27):'[Z'
keyd<-1> = f1 ; eseq<-1> = char(27):'OP'
keyd<-1> = f2 ; eseq<-1> = char(27):'OQ'
keyd<-1> = f3 ; eseq<-1> = char(27):'OR'
keyd<-1> = f4 ; eseq<-1> = char(27):'OS'
keyd<-1> = f5 ; eseq<-1> = char(27):'OT'
keyd<-1> = f6 ; eseq<-1> = char(27):'[17~'
keyd<-1> = f7 ; eseq<-1> = char(27):'[18~'
keyd<-1> = f8 ; eseq<-1> = char(27):'[19~'
keyd<-1> = f9 ; eseq<-1> = char(27):'[20~'
keyd<-1> = f10 ; eseq<-1> = char(27):'[21~'
keyd<-1> = f11 ; eseq<-1> = char(27):'[23~'
keyd<-1> = f12 ; eseq<-1> = char(27):'[24~'
* Wyse-type terminals
keyd<-1> = insk; eseq<-1> = char(27):'Q'
keyd<-1> = deck; eseq<-1> = char(27):'W'
keyd<-1> = btbk; eseq<-1> = char(27):'I'
keyd<-1> = f1 ; eseq<-1> = char(1):'@':char(13)
keyd<-1> = f2 ; eseq<-1> = char(1):'A':char(13)
keyd<-1> = f3 ; eseq<-1> = char(1):'B':char(13)
keyd<-1> = f4 ; eseq<-1> = char(1):'C':char(13)
keyd<-1> = f5 ; eseq<-1> = char(1):'D':char(13)
keyd<-1> = f6 ; eseq<-1> = char(1):'E':char(13)
keyd<-1> = f7 ; eseq<-1> = char(1):'F':char(13)
keyd<-1> = f8 ; eseq<-1> = char(1):'G':char(13)
keyd<-1> = f9 ; eseq<-1> = char(1):'H':char(13)
keyd<-1> = f10 ; eseq<-1> = char(1):'I':char(13)
keyd<-1> = f11 ; eseq<-1> = char(1):'J':char(13)
keyd<-1> = f12 ; eseq<-1> = char(1):'K':char(13)
* ADDS-type terminals
keyd<-1> = f1 ; eseq<-1> = char(2):'1':char(13)
keyd<-1> = f2 ; eseq<-1> = char(2):'2':char(13)
keyd<-1> = f3 ; eseq<-1> = char(2):'3':char(13)
keyd<-1> = f4 ; eseq<-1> = char(2):'4':char(13)
keyd<-1> = f5 ; eseq<-1> = char(2):'5':char(13)
keyd<-1> = f6 ; eseq<-1> = char(2):'6':char(13)
keyd<-1> = f7 ; eseq<-1> = char(2):'7':char(13)
keyd<-1> = f8 ; eseq<-1> = char(2):'8':char(13)
keyd<-1> = f9 ; eseq<-1> = char(2):'9':char(13)
keyd<-1> = f10 ; eseq<-1> = char(2):':':char(13)
keyd<-1> = f11 ; eseq<-1> = char(2):';':char(13)
keyd<-1> = f12 ; eseq<-1> = char(2):'<':char(13)
* xterm type - like my ASUS eeePC
keyd<-1> = bspk ; eseq<-1> = char(127)
keyd<-1> = delk ; eseq<-1> = char(27):'[3;2~'
keyd<-1> = f5 ; eseq<-1> = char(27):'[15~'
keyd<-1> = sf1 ; eseq<-1> = char(27):'O2P'
keyd<-1> = sf2 ; eseq<-1> = char(27):'O2Q'
keyd<-1> = sf3 ; eseq<-1> = char(27):'O2R'
keyd<-1> = sf4 ; eseq<-1> = char(27):'O2S'
keyd<-1> = sf5 ; eseq<-1> = char(27):'[15;2~'
keyd<-1> = sf6 ; eseq<-1> = char(27):'[17;2~'
keyd<-1> = sf7 ; eseq<-1> = char(27):'[18;2~'
keyd<-1> = sf8 ; eseq<-1> = char(27):'[19;2~'
keyd<-1> = sf9 ; eseq<-1> = char(27):'[20;2~'
keyd<-1> = sf10 ; eseq<-1> = char(27):'[21;2~'
keyd<-1> = sf11 ; eseq<-1> = char(27):'[23;2~'
keyd<-1> = sf12 ; eseq<-1> = char(27):'[24;2~'
* Now do terminal-specific settings
* VT-type terminals
if termtype[1,2] eq 'VT' or termtype[1,5] eq 'XTERM' then
keyd<-1> = lark; eseq<-1> = char(27):'[D'
keyd<-1> = lark; eseq<-1> = char(27):'OD'
end else
keyd<-1> = insk; eseq<-1> = char(27):'[D'
keyd<-1> = deck; eseq<-1> = char(27):'OD'
end
* Wyse-type terminals
if termtype[1,2] eq 'WY' then
keyd<-1> = lark; eseq<-1> = char(8)
keyd<-1> = rark; eseq<-1> = char(12)
keyd<-1> = uark; eseq<-1> = char(11)
keyd<-1> = btbk; eseq<-1> = char(27):'O' ;* !
end
* for my lttle ASUS eeePC & Linux - What a cool thing it is!
if index(termtype,'EEEPC',1) then
keyd<-1> = chok; eseq<-1> = char(27):'[2H' ;* Shift-Home actually
keyd<-1> = homk; eseq<-1> = char(27):'[H'
keyd<-1> = endk; eseq<-1> = char(27):'[F'
keyd<-1> = insk; eseq<-1> = char(27):'[2~'
keyd<-1> = deck; eseq<-1> = char(27):'[3~'
end else
keyd<-1> = homk; eseq<-1> = char(27):'[2~'
keyd<-1> = endk; eseq<-1> = char(27):'[3~'
end
* Populate the escape sequence test variables
base = ''; full = ''
amax = dcount(eseq,am)
for anum = 1 to amax
temp = eseq<anum>
if len(temp) le 1 then continue
locate(temp[1,1],base;post) else
post = dcount(base,am)+1
end
base<post> = temp[1,1]
full<post,-1> = temp
next anum
return
outline:
* to display logic simplisticly
rest = oconv(rest,'MCU')
if index(rest,'*',1) then rest = 'CEPS'
bot = here + 1
if bot gt last then bot = 1
if numb then msup = here + numb else msup = last
if msup gt last then msup = last
for here = bot to msup
gosub get.line
gosub find.label
line = ' ':upcase(line)
begin case
case chit eq '*' or chit eq '!' ; line = ''
case index(line,' GOTO ',1)
case index(line,' GO ',1)
case index(line,' GOSUB ',1)
case rest eq '' ; line = ''
case index(rest,'C',1) and index(line,' ':'CALL',1)
case index(rest,'E',1) and index(line,' ':'EXECUTE',1)
case index(rest,'P',1) and index(line,' ':'PERFORM',1)
case index(rest,'S',1) and index(line,' ':'CASE',1)
case 1 ; line = ''
end case
if temp ne '' or line ne '' then gosub display.line
next here
return
getshowline:
if unassigned(puncs) then
puncs = ', []()<>=+-/*:#!'
funcs = 'ABS\ABSS\ACOS\ADDS\ALPHA\ANDS\ASCII\ASIN\ASSIGNED\'
funcs := 'ATAN\BITAND\BITNOT\BITOR\BITRESET\BITSET\BITTEST\'
funcs := 'BITXOR\CATS\CHANGE\CHAR\CHARS\CHECKSUM\COL1\COL2\'
funcs := 'CONTINUE\CONVERT\COS\COSH\COUNT\COUNTS\DATE\DCOUNT\'
funcs := 'DELETE\DIV\DIVS\DOWNCASE\DQUOTE\DTX\EBCDIC\EQS\'
funcs := 'EREPLACE\EXCHANGE\EXP\EXTRACT\FADD\FDIV\FFIX\FFLT\'
funcs := 'FIELD\FIELDS\FIELDSTORE\FILEINFO\FIX\FMT\FMTDP\'
funcs := 'FMTS\FMTSDP\FMUL\FOLD\FOLDDP\FSUB\GES\GET\'
funcs := 'GETLOCALE\GETREM\GROUP\GTS\ICHECK\ICONV\ICONVS\'
funcs := 'IFS\ILPROMPT\INDEX\INDEXS\INDICES\INMAT\INSERT\INT\'
funcs := 'ISNULL\ISNULLS\ITYPE\KEYIN\LEFT\LEN\LENDP\LENS\'
funcs := 'LENSDP\LES\LN\LOWER\LTS\MATCHFIELD\MAXIMUM\MINIMUM\'
funcs := 'MOD\MODS\MULS\NEG\NEGS\NES\NOT\NOTS\NUM\NUMS\OCONV\'
funcs := 'OCONVS\ORS\PWR\QUOTE\RAISE\REAL\RECORDLOCKED\REM\'
funcs := 'REMOVE\REPLACE\REUSE\RIGHT\RND\RPC.CALL\RPC.CONNECT\'
funcs := 'RPC.DISCONNECT\SADD\SCMP\SDIV\SEEK\SELECTINFO\SEND\'
funcs := 'SENTENCE\SEQ\SEQS\SETLOCALE\SIN\SINH\SLEEP\SMUL\'
funcs := 'SOUNDEX\SPACE\SPACES\SPLICE\SQRT\SQUOTE\SSUB\STATUS\'
funcs := 'STR\STRS\SUBR\SUBS\SUBSTRINGS\SUM\SUMMATION\SYSTEM\'
funcs := 'TAN\TANH\TERMINFO\TIME\TIMEDATE\TPARM\TRANS\TRIM\'
funcs := 'TRIMB\TRIMBS\TRIMF\TRIMFS\TRIMS\UNASSIGNED\'
funcs := 'UNICHAR\UPCASE\XLATE\XTD'
convert '\' to @am in funcs
keywords = 'ABORT\AUTHORIZATION\AUXMAP\BEGIN\BREAK\BSCAN\'
keywords := 'BYTE\BYTELEN\BYTETYPE\BYTEVAL\CALL\CASE\CHAIN\'
keywords := 'CLEAR\CLEARDATA\CLEARFILE\CLEARPROMPTS\CLEARSELECT\'
keywords := 'CLOSE\CLOSESEQ\COMMIT\COMMON\COMPARE\CONSTANTS\'
keywords := 'CONVERT\CREATE\CRT\DATA\DEBUG\DEFFUN\DEL\DELETE\'
keywords := 'DELETELIST\DELETEU\DIM\DIMENSION\DISPLAY\DO\ECHO\ELSE\'
keywords := 'END\ENTER\EQU\EQUATE\ERRMSG\EXECUTE\EXIT\FILELOCK\'
keywords := 'FILEUNLOCK\FIND\FINDSTR\FLUSH\FOOTING\FOR\FORMLIST\'
keywords := 'FUNCTION\GET\GETLIST\GETX\GO\GOSUB\GOTO\GROUPSTORE\'
keywords := 'HEADING\HUSH\IF\INCLUDE\INPUT\INPUTCLEAR\INPUTDISP\'
keywords := 'INPUTDP\INPUTERR\INPUTIF\INPUTNULL\INPUTTRAP\INS\'
keywords := 'KEYEDIT\KEYEXIT\KEYTRAP\LET\LOCALEINFO\LOCATE\LOCK\'
keywords := 'LOOP\MAT\MATBUILD\MATCH\MATCHES\MATPARSE\MATREAD\MATREADL\'
keywords := 'MATREADU\MATWRITE\MATWRITEU\NAP\NEXT\NOBUF\NULL\'
keywords := 'NUMERIC.DATA\ON\OPEN\OPENCHECK\OPENDEV\OPENPATH\'
keywords := 'OPENSEQ\PAGE\PERFORM\PRECISION\PRINT\PRINTER\'
keywords := 'PRINTERR\PROCREAD\PROCWRITE\PROGRAM\PROMPT\'
keywords := 'RANDOMIZE\READ\READBLK\READL\READLIST\READNEXT\'
keywords := 'READSEQ\READT\READU\READV\READVL\READVU\RECORDLOCK\'
keywords := 'RELEASE\REM\REMOVE\REPEAT\RETURN\REVREMOVE\REWIND\'
keywords := 'ROLLBACK\SEEK\SELECT\SELECTE\SELECTINDEX\SETREM\'
keywords := 'SSELECT\START\STATUS\STOP\STORAGE\SUBROUTINE\'
keywords := 'TABSTOP\THEN\TIMEOUT\TO\TPRINT\TRANSACTION\TTYCTL\'
keywords := 'TTYGET\TTYSET\UNICHARS\UNISEQ\UNISEQS\UNLOCK\UNTIL\'
keywords := 'UPRINT\WEOF\WEOFSEQ\WRITE\WRITEBLK\WRITELIST\'
keywords := 'WRITESEQ\WRITESEQF\WRITET\WRITEU\WRITEV\WRITEVU'
convert '\' to @am in keywords
si.label = 1
si.comment = 2
si.string = 3
si.key = 4
si.operator = 5
si.function = 6
si.directive = 7
si.highlight = 8
si.doc = 9
bi.hiword = 10
* Highlights for HostAccess
bo = @(-58) ; bf = @(-59)
wo = @(-5) ; wf = @(-6)
ro = @(-13) ; rf = @(-12)
uo = @(-15) ; uf = @(-12)
hi.commenton = uo:bo
hi.commentoff = uf:bf
hi.labelon = bo
hi.labeloff = bf
hi.selecton = ro:wo
hi.selectoff = wf:rf
hi.stringon = wo
hi.stringoff = wf
hi.keyon = uo
hi.keyoff = uf
hi.opon = ''
hi.opoff = ''
hi.funcon = bo
hi.funcoff = bf
hi.diron = wo
hi.diroff = wf
hi.docon = ro:bo
hi.docoff = rf:bf
end
l = len(line)
* If the line is too long, don't colourise it
if l gt 2000 then
showline = line[setoff,width]
return
end
myline = line
oldmyline = myline
myline = trimf(myline)
mask = space(l - len(myline))
word = myline[' ',1,1]
if word[' ',1,1] match '1N0N' or word match '1A0X":"' then
mask := str(si.label,len(word)):' '
myline = myline[' ',2,999]
word = myline[' ',1,1]
end
begin case
case word[1,1] eq '*' or word[1,1] eq '!'
if count(myline,'@@') then
mask := str(si.doc, l)
end else
mask := str(si.comment, l)
end
case word[1,1] eq '$' or word[1,1] eq '#'
mask := str(si.directive, l)
case 1
dc = count(myline,';')
if not(dc) then
mask := space(l)
end else
foundcomment = false
for z = 1 to dc until foundcomment
word = trimf(myline[';',z+1,1])
if word[1,1] eq '*' or word[1,1] eq '!' then
foundcomment = z
end
next
if foundcomment then
mask := space(len(myline[';',1, foundcomment])):str(si.comment, l)
end else
mask := space(l)
end
end
end case
lin = convert(puncs,str(@fm,len(puncs)), upcase(oldmyline))
dc3 = dcount(lin,@fm)
for q = 1 to dc3
word = lin[@fm,q,1]
st = col1()+ 1
if st gt 1 then
if mask[st-1,1] eq ' ' and oldmyline[st-1,1] ne ' ' then
mask[st-1,1] = si.operator ; * operators too
end
end
begin case
case word[1,1] eq '"'
ix = index(lin[st+1,huge],'"',1)
if ix then
if mask[st,1] eq ' ' then
q = dcount(lin[1, ix+st],@fm)
mask[st, ix+1] = str(si.string, ix+1)
end
end
case word[1,1] eq "'"
ix = index(lin[st+1,huge],"'",1)
if ix then
if mask[st,1] eq ' ' then
q = dcount(lin[1, ix+st],@fm)
mask[st, ix+1] = str(si.string, ix+1)
end
end
case 1
locate(word,keywords;dpos;'AL') then
if mask[st,1] eq ' ' then
mask[st, len(word)] = str(si.key, len(word))
end
end else
locate(word,funcs;dpos;'AL') then
* Functions are followed by a bracket
brak = ''
fpos = len(lin[@fm,1,q])+1
if fpos then brak = trim(oldmyline[fpos,999])[1,1]
if brak eq '(' and mask[st,1] eq ' ' then
mask[st,len(word)] = str(si.function, len(word))
end
end
end
end case
next
word = lastfind
if word ne '' then
oc = 1
loop
if caseflag
then ix = index(oldmyline,word,oc)
else ix = index(upcase(oldmyline),upcase(word),oc)
while ix do
oc += 1
mask[ix, len(word)] = str(si.highlight, len(word))
repeat
end
myline = oldmyline[setoff,width]
mask = mask[setoff,width]
showline = ''
old = ''
l = len(myline)
for k = 1 to l
c = mask[k,1]
if c ne old then
begin case
case old eq si.label
showline := hi.labeloff
case old eq si.comment
showline := hi.commentoff
case old eq si.key
showline := hi.keyoff
case old eq si.string
showline := hi.stringoff
case old eq si.key
showline := hi.keyoff
case old eq si.operator
showline := hi.opoff
case old eq si.function
showline := hi.funcoff
case old eq si.directive
showline := hi.diroff
case old eq si.highlight
showline := hi.selectoff
end case
begin case
case c eq si.label
showline := hi.labelon
case c eq si.comment
showline := hi.commenton
case c eq si.key
showline := hi.keyon
case c eq si.string
showline := hi.stringon
case c eq si.operator
showline := hi.opon
case c eq si.function
showline := hi.funcon
case c eq si.directive
showline := hi.diron
case c eq si.highlight
showline := hi.selecton
case c eq si.doc
showline := hi.docon
end case
old = mask[k,1]
end
showline := myline[k,1]
next
begin case
case old eq si.label
showline := hi.labeloff
case old eq si.comment
showline := hi.commentoff
case old eq si.key
showline := hi.keyoff
case old eq si.string
showline := hi.stringoff
case old eq si.function
showline := hi.funcoff
case old eq si.operator
showline := hi.opoff
case old eq si.directive
showline := hi.diroff
case old eq si.highlight
showline := hi.selectoff
case old eq si.doc
showline := hi.docoff
end case
return
