This version adds command line editing and fixes a slight bug in DELR processing in full screen editing.
LED_6.TXT is the previous version
program led
* ECL - KRJ - Line Editor (Replicating Unidata's AE)
* VERSION: 01.07
* This editor reproduces the UniData Alternate Editor under UniVerse.
* The code is supplied on an as-is basis as a source-code resource.
* No representation whatever is made as to the operation of the program.
* I have made use of $IFDEF to switch in and out particular features.
* This method means that it should be obvious where to edit/comment out
* lines that are not available for any particular environment (like R83).
* NEWDIMWORKS Can change the size of a dimensioned array, but I can't see
* a performance difference. This does NOT work in R83.
* REMOVEWORKS Allows the use of REMOVE to build cells. This is a real
* speed up. This does NOT work in R83.
* CHANGEWORKS Allows CHANGE and CONVERT. This does NOT work in R83.
* TRIMFBWORKS Allows TRIMF & TRIMB. This does NOT work in R83
* WERRORWORKS Has ON ERROR for WRITE & DELETE. This does NOT work in R83
* LABCOMWORKS Allows labelled COMMON. This does NOT work in R83
* It also assumes that ASSIGNED() or UNASSIGNED() will work
* SECUREWORKS is the flag for your AE-style security (SEC... variables)
* which is a PREPROG program - haven't done POSTPROG
* FILINFWORKS Means that we can use FILEINFO(). This does NOT work in R83
* USEATVALUES Means we use @ variables. This does NOT work in R83
$define newdimworks
$define removeworks
$define changeworks
$define trimfbworks
$define werrorworks
$define labcomworks
$define secureworks
$define filinfworks
$define useatvalues
* Note that a QM system has QM automatically defined
* On QM you must comment out the next two lines ($UNDEFINE won't work)
$define universe
$undefine unidata
*===
* Version information
* 01.07 - Added command line editing (if the terminal supports screen
* addressing) and so all input can use editing keys.
* 01.06 - Changed delete-to-end-of-line to delete line feed when at
* or after the end-of-line.
* Made to work in terminal independant mode (like FINP program)
* Single dot shows last command only.
* Fixed subtle bug when inserting by using .C then .X commands
* 01.05 - Changed RA to work like S and made both move command to top
* Changed non-print to display differently
* Changed page editing commands slightly, abandons changes
* 01.04A- Added command SPACE for whitespace insensitive search
* Extend CASE to cover FL and FLA, and save it in EDKEEP
* Add the VIEW capability (IE a command to browse files)
* 01.04 - Added commands
* CASE DISPLAY EIT FLA M .A .I .S .U
* Changed TRIMBIT to use CHIT, not TEMP
* Amended 'I' for multiline insert to fix bug
* Fixed KMUL input and clarified its operation
* Changed EC to work with more awkwardly written lines
* Changed TTID to use WHOM, not TERM, at the start
* Changed STAMP to show @WHO, not @PATH
* Fixed bug when deleting to end of line in page edit mode
* 01.03 - Added commands
* CUT MACRO
* Added patterm matching to FL command
* Reset OOPS after write of record
* Added GOSUB GET.LINE; TEMP = LINE a couple of times in PED.COMD
* Rewritten as a monolithic program for portability. If you
* want to break out the help data and/or the indenter logic
* it's reasonably clear where you should do so as old code is
* just commented out.
* 01.03UD UniData doesn't have screen addressing on NT "Console"
* AND doesn't support "R%n" formatting in BASICTYPE "U"
* 01.03QM Note that FOR NEXT loop numbers increment differently so
* a lot of HERE = HERE - 1 change to HERE = MSUP even though
* these are not needed for QM - means it still works for U2.
* Changed ASSIGNED back to UNASSIGNED for QM.
* Put in TEST = @(0,0) to stop pagination prompting for QM.
* Amended DTX and XTD - only UNIVERSE has the functions, and
* DTX conversion is wrong if input is too large (crashes QM!)
* Added logic to cater for QM use of SOURCE.CONTROL program
* Amended page editor keys for "qmterm" terminal
* 01.03UV Added test for "console" as UV on NT does not have screen
* addressing and @(-4) will insert a line feed.
* 01.02 - Added commands
* < > <> COPY DROP FM FMA LA LNA MOVE SORT
* Changed "SHOW = FALSE" to "SHOW = SHEW" for Change Match
* Can see new features in old versions like "HELP VER01_01 NEW"
* 01.01 - Added Commands
* BK CM COUNT DTX EPR FL HEX IC LL LN MV NULL OC PE SEQ SHOW V XTD
* Added Synonyms CAT and FILE
* Tidy up, add CHANGE.MADE, add change commands to '?'
* Help logic put in line
* Used ASSIGNED rather than UNASSIGNED (Possible UniVerse Bug)
* Added speed-up code when deleting to end of file
* 01.00 - First production version - Doesn't line-wrap!
* Many and varied changes, notably use of $IFDEF
* 00.01 - Pre-production version (released to MaVerick)
*===
* Easier to see than MCP display conversion
badc = char(255)
for xx = 0 to 31 ; badc := char(xx) ; next xx
for xx = 128 to 250 ; badc := char(xx) ; next xx
gudc = str('~',len(badc))
$ifdef universe
$options information
$endif
* Special subtlety for Unidata not supporting 'R%3' form
$ifdef unidata
$basictype "U"
prfx = ''; sufx = '\0R'
$else
prfx = 'R%'; sufx = ''
$endif
*===
* INITIALISE
prompt ''
$ifdef useatvalues
am = @am; vm = @vm; sm = @sm
$else
am = char(254); vm = char(253); sm = char(252)
$endif
true = 1 = 1; false = not(true); qt = '"\':"'"
$ifdef labcomworks
common /led$data/ edkeep,safe
$endif
$ifdef newdimworks
equ cellsize to 50
dim memr(1)
$else
equ numcells to 100
dim memr(numcells)
$endif
* List of verbs for viewing data only
viewverb = 'VIEW':am:'BROWSE':am:'LOOK'
* XCOM data
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)
editpage = true ; pageedit = true
caseflag = true
spaceflag = true
heap = false ; salt = ''
* This next bit is to cope with U2 on NT at console
$ifndef qm
if oconv(system(7),'MCU') eq 'CONSOLE' then
editpage = false ; pageedit = false
begn = char(13); ceop = ''; ceol = ''; goup = ''
end
$endif
plen = 23 ; pwin = 17
dim fr(10) ; mat fr = '' ; fr(3) = 'MCU'
oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = ''
join = '' ; nill = '' ; fold = ''
macn = 0; macc = ''
scrset = false
$ifdef qm
scrset = true
$endif
if scrset then test = @(0,0)
* Find Match words
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'
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>
endwords = 'IF\OPEN\OPENSEQ\READNEXT\READ\READU\READV\READVU\'
endwords = endwords:'MATREAD\MATREADU\LOCATE'
$ifdef changeworks
convert '\' to am in endwords
$else
chit = endwords ; old1 = '\' ; new1 = am
gosub changeit ; endwords = chit
$endif
* page editor stuff
* Define page limits
wide = system(2)
botl = system(3) - 2; clpg = @(-1)
bell = str(char(7),3)
botp = @(0,system(3)-1):ceol
* Define key activity numbers
equ uarr to 1; equ darr to 2; equ larr to 3; equ rarr to 4
equ upag to 5; equ dpag to 6; equ lpag to 7; equ rpag to 8
equ tpag to 9; equ bpag to 10
equ escp to 11; equ phlp to 12; equ zoom to 13
equ delc to 14; equ dell to 15; equ delr to 16
equ back to 17; equ carr to 18; equ togg to 19
equ writ to 20; equ doit to 21
* Define key caps for help
* Note Ctrl-B is left arrow in EMACS-like, but Ctrl-U works for ADDS and Wyse
* and I wanted to have Top and Bottom, so...
dim kcap(21)
mat kcap = ''
kcap(uarr) = ' or '
kcap(darr) = ' or '
kcap(larr) = ' or '
kcap(rarr) = ' or '
kcap(upag) = ' or '
kcap(dpag) = ' or '
kcap(lpag) = ' or '
kcap(rpag) = ' or '
kcap(tpag) = ''
kcap(bpag) = ''
kcap(escp) = ''
kcap(phlp) = ''
kcap(zoom) = ''
kcap(delc) = ' or '
kcap(dell) = ''
kcap(delr) = ''
kcap(back) = ''
kcap(carr) = ''
kcap(togg) = ' or '
kcap(writ) = ''
* Define activity/key combinations
* Standard keys
acts = '' ; keys = ''
acts<-1> = carr ; keys<-1> = char(13)
acts<-1> = back ; keys<-1> = char(8)
acts<-1> = escp ; keys<-1> = char(27)
acts<-1> = upag ; keys<-1> = char(16)
acts<-1> = dpag ; keys<-1> = char(14)
acts<-1> = rpag ; keys<-1> = char(05)
acts<-1> = tpag ; keys<-1> = char(20)
acts<-1> = bpag ; keys<-1> = char(02)
acts<-1> = zoom ; keys<-1> = char(07)
acts<-1> = delc ; keys<-1> = char(04)
acts<-1> = dell ; keys<-1> = char(24)
acts<-1> = delr ; keys<-1> = char(11)
acts<-1> = togg ; keys<-1> = char(09)
* VT Keys (Note two arrow possibilities)
acts<-1> = uarr; keys<-1> = char(27):'[A'
acts<-1> = darr; keys<-1> = char(27):'[B'
acts<-1> = larr; keys<-1> = char(27):'[D'
acts<-1> = rarr; keys<-1> = char(27):'[C'
acts<-1> = uarr; keys<-1> = char(27):'OA'
acts<-1> = darr; keys<-1> = char(27):'OB'
acts<-1> = larr; keys<-1> = char(27):'OD'
acts<-1> = rarr; keys<-1> = char(27):'OC'
acts<-1> = upag; keys<-1> = char(27):'[5~'
acts<-1> = dpag; keys<-1> = char(27):'[6~'
* Following 4 are per docs but don't work in HOSTACCESS (?)
! ACTS<-1> = LPAG; KEYS<-1> = CHAR(27):'[H'
! ACTS<-1> = RPAG; KEYS<-1> = CHAR(27):'[1~'
! ACTS<-1> = DELC; KEYS<-1> = CHAR(27):'[3~'
! ACTS<-1> = TOGG; KEYS<-1> = CHAR(27):'[2~'
acts<-1> = lpag; keys<-1> = char(27):'[2~'
acts<-1> = rpag; keys<-1> = char(27):'[3~'
acts<-1> = delc; keys<-1> = char(27):'[4~'
acts<-1> = togg; keys<-1> = char(27):'[1~'
acts<-1> = phlp; keys<-1> = char(27):'OP'
acts<-1> = writ; keys<-1> = char(27):'OQ'
* ADDS keys - Arrow keys are simple defaults
acts<-1> = uarr; keys<-1> = char(26)
acts<-1> = darr; keys<-1> = char(10)
acts<-1> = larr; keys<-1> = char(21)
acts<-1> = rarr; keys<-1> = char(06)
acts<-1> = upag; keys<-1> = char(27):'J'
acts<-1> = dpag; keys<-1> = char(27):'|'
acts<-1> = lpag; keys<-1> = char(01)
acts<-1> = rpag; keys<-1> = char(27):'T'
acts<-1> = delc; keys<-1> = char(27):'W'
acts<-1> = togg; keys<-1> = char(27):'Q'
acts<-1> = phlp; keys<-1> = char(02):'B1':char(13)
acts<-1> = writ; keys<-1> = char(02):'B2':char(13)
* Wyse Keys
! ACTS<-1> = UARR; KEYS<-1> = CHAR(11) ;* want this for DELR
! ACTS<-1> = DARR; KEYS<-1> = CHAR(10) ;* same as ADDS
! ACTS<-1> = LARR; KEYS<-1> = CHAR(21) ;* same as ADDS
acts<-1> = rarr; keys<-1> = char(12)
acts<-1> = dpag; keys<-1> = char(27):'K'
acts<-1> = lpag; keys<-1> = char(30)
acts<-1> = rpag; keys<-1> = char(27):'T'
acts<-1> = delc; keys<-1> = char(27):'W'
acts<-1> = togg; keys<-1> = char(27):'Q'
acts<-1> = togg; keys<-1> = char(27):'q'
acts<-1> = phlp; keys<-1> = char(01):'@':char(13)
acts<-1> = writ; keys<-1> = char(01):'A':char(13)
* Set up the multi-part keys
kmul = ''; kini = ''
xxno = dcount(keys,am)
for xx = 1 to xxno
temp = keys
if len(temp) le 1 then continue
locate(temp[1,1],kini;kpos) else
kpos = dcount(kini,am)+1
end
kini = temp[1,1]
kmul = temp
next xx
modesave = 'LINE'
mode = modesave
* HELP location
help.def = 'VER01_06'
* OPEN 'LED.HELP' TO LED.HELP ELSE HELP.DEF = ''
gosub setup.help
* These things aren't used yet
bort = false ; blok = false ; atta = false
brigchar = '>'
* The saved stuff
pres = '' ; look = '' ; stak = ''
wild = false ; shew = false
chan = '' ; olda = '' ; cmat = ''
$ifdef labcomworks
$ifdef universe
test = not(assigned(edkeep))
$else
test = unassigned(edkeep)
$endif
if test then
edkeep = pres:am:look:am:stak:am:wild:am:chan:am:olda:am:shew
edkeep = edkeep:am:cmat:am:not(caseflag)
end else
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>
caseflag = not(edkeep<9>)
end
$ifdef universe
test = not(assigned(safe))
$else
test = unassigned(safe)
$endif
if test then safe = ''
$else
safe = ''
$endif
prepprog = '' ; prepflag = false
postprog = '' ; postflag = false
*********** UniData AE-style security start
$ifdef secureworks
$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
if field(line,'=',1) = 'PREPROG_AE_UDT' then
prepprog = field(line,'=',2)
xxno = xx
end
next xx
$endif
* QM doesn't allow underscores in environmental variables, so
* this is the closest I can get to AE environmental variable name
* and there is a bug when it hasn't been defined so the name
* requested is returned.
$ifdef qm
call !atvar(prepprog,'@PREPROG.AE.UDT')
if prepprog[1,1] = '@' then prepprog = ''
$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] = 'AE_' THEN PREPPROG = ''
* IF PREPPROG[LEN(PREPPROG)-2,3] NE '_AE' THEN PREPPROG = ''
if prepprog ne '' then prepflag = true
$endif
*** end of SECUREWORKS section
* 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 or 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) ;* 4 preprog, 1 if fn is dict ...
equ sec.dict2.flg to security(24) ;* 4 preprog, 1 if fn2 is dict ...
* field 25 is specific to AE, this and all other fields unused
* WARNING: preprog & postprog should not use the STOP/ABORT UniBasic
* statements because files will be left open. Use the SEC.STOP.FLG
* to stop AE.
*********** 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
* Could UniVerse use !EXIST to implement the same thing?
* No matter, we can always use PREPPROG to flag it
if prepprog = 'SOURCE.CONTROL' then source.control = true
$endif
if source.control then prepflag = false ; prepprog = ''
$ifdef useatvalues
name = @logname
levl = @level
path = @path
term = @tty
whom = @userno
acct = @who
* the following line is strictly PTO
* CALL GETWHO(WHOM)
$else
name = field(oconv(0,'U50BB'),' ',2)
levl = system(16)
acct = field(oconv(0,'U50BB'),' ',3)
if acct = '' then acct = name
path = ''
term = field(oconv(0,'U50BB'),' ',1)
whom = term + 1
$endif
* IF NAME EQ 'your name here' THEN DBUG = TRUE ELSE DBUG = FALSE
equ presnumb to 20; equ looknumb to 20; equ staknumb to 99
equ channumb to 20
* Parse the command line - long way in before work starts, eh?
* VERB is how this was called so it should work to call again
verb = ''
rest = @sentence
keepquot = false
gosub parse.rest
temp = dcount(bite,am)
options = bite
if options[1,1] = '(' then
options = field(field(options,'(',2),')',1)
bite = delete(bite,temp,0,0)
end else options = ''
if oconv(bite<1>,'MCU') = 'RUN' then
verb = bite<1>:' ':bite<2>:' '
bite = delete(bite,1,0,0)
bite = delete(bite,1,0,0)
end
verb = verb:bite<1>
bite = delete(bite,1,0,0)
* Check if a viewing verb has been used
* If so, we can turn off both security systems (I hope 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
locate(oconv(verb,'MCU'),viewverb;posn) then
viewflag = true
source.control = false
prepflag = false
end
*
fnam = bite<1>
bite = delete(bite,1,0,0)
if oconv(fnam,'MCU') = 'DICT' then
fnam = 'DICT ':bite<1>
bite = delete(bite,1,0,0)
end
idlist = bite
bite = '' ; rest = '' ; ncel = ''
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 '----------------------------'
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 file AE_COMS'
if scrset then test = @(0,0)
end
* Get file
loop
got.file = false
if fnam = '' then
stub = 'File >'; gosub get.rope; fnam = rope; crt
end
if fnam = '' then stop
dprt = field(fnam,' ',1)
fprt = field(fnam,' ',2)
if fprt = '' then fprt = dprt ; dprt = ''
open dprt, fprt to file then
got.file = true
end else
open dprt,oconv(fprt,'MCU') to file then
got.file = true
end else
crt 'Unable to find file "':fnam:'".'
fnam = ''
end
end
until got.file do
repeat
* Get the record
if idlist = '*' then
idlist = ''
execute 'SELECT ':dprt:' ':fprt
if scrset then test = @(0,0)
end
if system(11) then
eof = false
loop
readnext id else eof = true
until eof do
idlist<-1> = id
repeat
end
get.idlist:
killsign = false
if idlist = '' then
stub = 'Record ids >'; 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
item = idlist
gosub edit.item
if killsign then idlist = '' ; go get.idlist
next id
$ifdef labcomworks
edkeep = pres:am:look:am:stak:am:wild:am:chan:am:olda:am:shew
edkeep = edkeep:am:cmat:am:not(caseflag)
$endif
stop
*===
* SUBROUTINES
edit.item:
stopsign = false
here = 0
beg = 0 ; fin = 0
nb = 'Command requests a block operation,'
nb = nb:' but no block is defined.'
crt
if idcnt gt 1 then crt '< ':id:' > ':
if prepflag then
if safe = '' then
mat security = ''
sec.set = ''
call @prepprog(mat security)
if sec.set = 'NONE' then stop
if sec.stop.flg then stop
safe = sec.set
end
mat security = ''
sec.set = safe
if sec.set then
sec.fn = fprt
sec.id = item
$ifdef filinfworks
sec.dir.flg = fileinfo(file,3) = '4'
$endif
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 go locked.record then
lock = true
carry.on:
gosub parse.record
crt 'Top of "':item:'" in "':fnam:'", ':last:
crt ' lines, ':len(this):' characters.'
end else
lock = true
this = ''
gosub parse.record
crt 'Top of new "':item:'" in "':fnam:'".'
end
!! LOCK = TRUE
orig = this
gosub get.lfmt
* Edit the record
if mode<1> = 'PAGE' then
ptop = 1
pchr = 1
page.editor:
gosub get.line ; temp = line
loop
pcol = rem(pchr-1,wide)
prow = here+1-ptop
$ifdef universe
input bite,-1;* universe specific
if not(bite) then
$endif
crt @(60,0):ceol:mode<2>:' ':fmt(here,'R#4'):
crt ',':fmt(pchr,'L#4'):
bite = seq(temp[pchr,1])
if bite ne '255' then crt ' (':bite:')':
$ifdef universe
end
$endif
crt @(pcol,prow):
gosub get.page.comd
if mode = 'LINE' then
crt botp:'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
end
crt
that = ''
gosub display.line
go line.editor
end
repeat
return
end
line.editor:
loop
* 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> = 'PAGE' then go page.editor
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 = '' or numb matches '1N0N') then
crt ; gosub bad.command
continue
end
if comd = '' then
gosub null.command
if comd = '' then continue
end
* Save command to list
if comi ne '' then
stak = insert(stak,1,1,0,comi)
loop
while dcount(stak,vm) gt staknumb do
stak = delete(stak,1,staknumb,0)
repeat
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
first = comd[1,1]
posn = index('ABCDEFGHIJKLMNOPQRSTUVWXYZ',first,1)
if not(posn) then gosub bad.command ; continue
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
if stopsign then release file, item ; lock = false ; return
repeat
return
parse.command:
$ifdef trimfbworks
comi = trimf(comi)
$else
chit = comi ; gosub trimfit ; comi = chit
$endif
dlim = oconv(oconv(comi,'MC/A'),'MC/N')[1,1]
if dlim = '' then
rest = ''
comd = oconv(comi,'MCU')
end else
posn = index(comi,dlim,1)
rest = comi[posn+1,999999]
comd = oconv(comi[1,posn-1],'MCU')
end
temp = oconv(comd,'MCN')[1,1]
if temp matches '1N' then
temp = index(comd,temp,1)
numb = comd[temp,999]
comd = comd[1,temp-1]
end else numb = ''
return
parse.line:
if line = 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 = 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 = xx + 1
end
repeat
return
a: begin case
case comd = 'A' ; * append
if viewflag then gosub viewonly ; return
if rest = '' then rest = olda<1,1>
if rest = '' 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
gosub set.bounds
for here = bot to msup
gosub get.line
line = line:rest
memr(cell) = line
chng = chng + 1
gosub display.line
next here
here = msup
if chng then gosub change.made
case 1 ; gosub bad.command
end case
return
b: begin case
case comd = 'B' and dlim = '' ; * bottom
here = last ; gosub display.line
case comd = 'B' or comd = 'BD' or comd = 'BK' ; * break line
if viewflag then gosub viewonly ; return
if rest = '' then
crt 'The second field is empty.'
gosub bad.comd
return
end
chng = 0 ; save = here ; savl = last ; show = ''
gosub set.bounds
for here = msup to bot step -1
gosub get.line
posn = index(line,rest,1)
if posn then
posn = posn + len(rest)
temp = line[posn,len(line)]
if temp ne '' then
line = line[1,posn-1]
if comd = 'BK' then line = temp
memr(cell) = line
show = insert(show,1,0,0,here)
numb = numb + 1
chng = chng + 1
if comd = 'B' then
msup = msup + 1
last = last + 1
lnum = lnum + 1
line = temp
gosub insert.line
end
end
end
next here
if chng then
gosub change.made
xxno = dcount(show,am)
savl = 0
for xx = 1 to xxno
here = show + savl
gosub display.line
if comd = 'B' and xxno gt 1 then
here = here + 1
savl = savl + 1
gosub display.line
end
next xx
end
here = msup + numb - 2
if comd = 'BD' or comd = 'BK'then here = msup
if here gt last then here = last
if xxno gt 1 then
crt 'Split ':numb:' records. Now at line ':here
end
gosub get.line
case comd = 'BC' ; * bridge character display (change)
dlim = trim(dlim):trim(rest)
dlim = dlim[1,1]
if dlim ne '' then brigchar = dlim
crt 'BridgeChar is ':brigchar
comi = ''
case 1 ; gosub bad.command
end case
return
c: begin case
case comd = 'C' ; * change
if viewflag then gosub viewonly ; return
if numb = '' and dlim = '' then
comd = 'RA'
comi = 'RA1'
numb = 1
end
gosub change.command
case comd = 'CAT' ; comd = 'J' ; go j
case comd = 'CASE' ; * change casing flag for 'L'
rest = oconv(rest,'MCU')
begin case
case rest = 'ON' ; caseflag = true
case rest = 'OFF' ; caseflag = false
case 1 ; caseflag = not(caseflag)
end case
crt 'CASE flag is ':
if caseflag then crt 'ON' else crt 'OFF'
case comd = 'CD' ; * command delimiter display (change)
if dlim = '' then
crt 'Command delimiter is ':
end else
temp = '`,;#$%&~|[]{}/"':"'"
if index(temp,dlim,1) then
comdmark = dlim
crt 'Command delimiter is now ':
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 remains ':
end
end
if comdmark = '"' then
crt "'":comdmark:"'"
end else crt '"':comdmark:'"'
case comd = 'CM' ; * changematch command
if viewflag then gosub viewonly ; return
if rest = '' then
if cmat = '' 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 = '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,wide-llen-2]
end else crt begn:temp[1,wide]
temp = str('1234567890',10)
if lfmt then
crt begn:space(llen+2):temp[1,wide-llen-2]
end else crt begn:temp[1,wide]
temp = ''
case comd = 'COPY' ; * copy (merge) the block
if viewflag then gosub viewonly ; return
if not(beg) and not(fin) then
crt nb ; gosub bad.comd ; return
end
numb = fin - beg + 1
crt 'Lines ':beg:' to ':fin:' (':numb:') will be Copied.'
stub = 'You are now at line ':here:'. Do it? n/y > '
gosub get.rope; answ = rope; crt
answ = oconv(trim(answ),'MCU')[1,1]
if answ ne 'Y' then
crt 'Block command canceled.'
return
end
dlim = ' '
rest = beg:' ':fin
numb = ''
gosub merge
if numb then
if beg gt here then beg = beg + numb
if fin gt here then fin = fin + numb
end
case comd = 'COUNT' ; * show the count of a string
line = rest ; gosub parse.line ; rest = line
if rest = '' then
crt 'No string given to count.'
gosub bad.comd ; return
end
gosub set.bounds
temp = 0
for here = bot to msup
gosub get.line
temp = temp + count(line,rest)
next here
here = msup
crt temp:' occurrances of string.'
case comd = 'CRT' ; * insert crt line for programmer
if viewflag then gosub viewonly ; return
if rest = '' then
crt 'You have not said what to put on CRT line'
comi = ''
return
end
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
here = here + 1 ; last = last + 1 ; lnum = 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 = 'CUT' ;* cut and save lines
if viewflag then gosub viewonly ; return
if not(sec.unload.flg) then
crt 'Unload disabled'
comi = ''
return
end
if comi = comd then
if not(beg) and not(fin) then
crt nb; gosub bad.comd; return
end
rest = beg
numb = fin-beg+1
end
rest = trim(rest)
if numb = '' then
if dlim = '"' 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
end
if not(rest matches '1N0N') or numb = '' then
crt 'Format of CUT command is: "CUTn/n"; eg: "CUT10/15"':
crt ' or "CUT/n/m"; eg: "CUT/5/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
save = rest
rest = ''
gosub get.load
rest = save
if temp = '' then return
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
bite = field(this,am,rest,numb)
if source.control then
dict.flag = odpt
file.name = ofpt
record.name = onid
record.data = bite
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
$ifdef werrorworks
write bite on ofil, onid on error crt 'FAILURE'; return
$else
write bite on ofil, onid
$endif
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
if comi = comd then beg = 0; fin = 0
begin case
case rest = 1
this = field(this,am,numb+1,last)
case rest+numb ge last
this = field(this,am,1,rest-1)
case 1
bite = field(this,am,rest+numb,last)
this = field(this,am,1,rest-1):am:bite
end case
begin case
case here ge rest+numb; here = here - numb
case here ge rest; here = rest
end case
if here lt 1 then here = 1
gosub set.record
if beg gt last then beg = last
if fin gt last then fin = last
crt 'Cut ':numb:' lines starting at line ':rest
gosub display.line
end else
crt 'Nothing done - no lines selected.'
comi = '' ; return
end
bite = ''; temp = ''
case 1 ; gosub bad.command
end case
return
d: begin case
case comd = 'D' ; * display current line
if here gt last then here = last
gosub display.line
case comd = 'DE' ; * delete lines
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
if rest ne '' then
gosub parse.cols
if not(good) then return
end
gosub set.bounds
* Quicker and also copes with CHAR(255)
gosub delete.lines
here = bot
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 = 'DISPLAY' ; * insert display line for programmer
if viewflag then gosub viewonly ; return
if rest = '' then
crt 'You have not said what to put on DISPLAY line'
comi = ''
return
end
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
here = here + 1 ; last = last + 1 ; lnum = 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 = 'DROP' ; * remove the block
if viewflag then gosub viewonly ; return
if not(beg) and not(fin) then
crt nb ; 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
if fin = last then
temp = temp - 1
temp<2> = len(this)
end else
temp<2> = index(this,am,fin)
end
if not(temp<2>) then
crt 'Cannot find end of block'
gosub bad.comd ; return
end
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
last = last - fin + beg - 1
begin case
case here le beg
case here le fin
here = beg
case 1
here = here - fin + beg - 1
end case
beg = 0 ; fin = 0
this = this[1,temp<1>]:this[temp<2>+1,len(this)]
gosub set.record
gosub display.line
case comd = 'DTX' ; * decimal to hex
if not(rest matches '1N0N') then
crt 'Must be numeric'
gosub bad.comd ; return
end
if len(rest) gt 9 then
crt 'Must be less than 1,000,000,000'
gosub bad.comd ; return
end
$ifdef universe
crt dtx(rest)
$else
crt oconv(rest,'MX')
$endif
case comd = 'DUP' ; * duplicate previous line
if viewflag then gosub viewonly ; return
if here lt 1 then
crt 'Nothing done - I abhor duplicating vacuums.'
gosub bad.comd ; return
end
if numb = '' and rest matches '1N0N' then numb = rest
if numb lt 1 then numb = 1
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
gosub get.line
for xx = 1 to numb
gosub insert.line
last = last + 1
next xx
gosub reset.record
crt 'Inserted ':numb:' copies of line ':here:
crt ' after line ':here:'. Still at ':here:'.'
case 1 ; gosub bad.command
end case
return
e: begin case
case comd = 'EDITPAGE'
if not(pageedit) then gosub bad.command; return
if editpage then
editpage = false
begn = char(13); ceop = ''; ceol = ''; goup = ''
end else
editpage = true
begn = @(0) ; ceop = @(-3) ; ceol = @(-4) ; goup = @(-10)
end
crt 'EDITPAGE = ':editpage
case comd = 'EC' ; * edit called program (in this file)
if here lt 1 then here = 1
gosub get.line
line = trim(line)
temp = oconv(line,'MCU')
good = index(line,'CALL ',1)
if good then line = trim(line[good+5,99999])
line = trim(field(line,'(',1))
if index(line,' ',1) then good = false
if line[1,1] = '@' then
crt 'Leading "@" is logical pointer'
good = false
end
if not(good) then
crt 'The EC command requires lines in format ':
crt '"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
if scrset then test = @(0,0)
crt 'Back editing record "':item:'" in file "':fnam:'"'
case comd = '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 = '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 = oconv(temp,'MCU')
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
line = fnam:' ':line
end case
if not(good) then
crt 'The EI command requires lines in format ':
crt '"$IN... {DICT} {FN} ID"'
gosub bad.comd ; return
end
execute verb:' ':line
if scrset then test = @(0,0)
crt 'Back editing record "':item:'" in file "':fnam:'"'
case comd = 'EIT' ; * edit i-types (@)
gosub get.line ; temp = line
gosub split.itype
ttid = whom:'_':levl:'_IType.in.line#':here
write bite on acom, ttid on error crt 'FAIL' ; return
crt 'editing IType as fields...':
execute verb:' AE_COMS ':ttid
if scrset then test = @(0,0)
crt 'Back editing record "':item:'" in file "':fnam:'"'
read line from acom, ttid else line = ''
delete acom, ttid
vmrk = ';'; gosub reset.fields
case comd = 'EPR' ; * edit prestores
ttid = whom:'_':levl:'_prestores'
temp = raise(pres)
$ifdef werrorworks
write temp on acom, ttid on error crt 'FAIL' ; return
$else
write temp on acom, ttid
$endif
crt 'editing prestores':
execute verb:' AE_COMS ':ttid
if scrset then test = @(0,0)
crt 'Back editing record "':item:'" in file "':fnam:'"'
read temp from acom, ttid else temp = ''
pres = lower(temp)
delete acom, ttid
case comd = 'ESV' ; * edit subvalues
vmrk = sm ; vals = 'subvalues'
gosub edit.fields
vmrk = sm; gosub reset.fields
case comd = 'EV' ; * edit values
vmrk = vm ; vals = 'values'
gosub edit.fields
vmrk = vm; gosub reset.fields
case comd = '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 = 'EX' or comd = 'EXIT' ; comd = 'Q' ; go q
case comd = 'EXK' or comd = 'EXITK' ; comd = 'QK' ; go q
case 1 ; gosub bad.command
end case
return
f: begin case
case comd = '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 = 'FILE' ; comd = 'SV' ; go s
case comd[1,2] = '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)]
$ifdef changeworks
convert 'BCRDL' to '' in temp
$else
chit = temp ; new1 = ''
old1 = 'B' ; gosub changeit
old1 = 'C' ; gosub changeit
old1 = 'R' ; gosub changeit
old1 = 'D' ; gosub changeit
old1 = 'L' ; gosub changeit
temp = chit
$endif
if temp = '' then gosub write.record else gosub bad.command
case comd = 'FL' or comd = 'FLA' ; * find labels
if not(caseflag) then rest = oconv(rest,'MCU')
if index(comd,'A',1) then
bump = -1
bot = here - 1
if bot lt 1 then return
if numb then msup = here - numb else msup = 1
if msup lt 1 then msup = 1
end else
bump = 1
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
end
for here = bot to msup step bump
gosub get.line
$ifdef trimfbworks
temp = field(trimf(line),' ',1)
$else
chit = line ; gosub trimfit ; temp = field(chit,' ',1)
$endif
if temp matches '1N0N"*"0X' then
temp = field(temp,'*',1)
end
if temp matches '1N0N"!"0X' then
temp = field(temp,'!',1)
end
bite = index(temp,':',1)
if bite then
bit = temp[bite+1,1]
if bit = ';' or bit = '*' or bit = '!' then
temp = temp[1,bite]
end
end
begin case
case temp = ''
case num(temp)
case temp[len(temp),1] = ':'
temp = temp[1,len(temp)-1]
case 1
temp = ''
end case
if not(caseflag) then temp = oconv(temp,'MCU')
if temp ne '' then
if rest = '' or temp matches rest then
gosub display.line
if not(numb) then return
end
end
next here
crt
gosub display.line
case comd = 'FM' or comd = 'FMA' ; * find match command
gosub get.line
word = field(trim(oconv(line,'MCU')),' ',1)
begin case
case rest ne ''
seek = rest
case word[1,1] = '*' or word[1,1] = '!'
seek = word[1,1]
case 1
locate(word,fm.words;posn) then
if index(comd,'A' ,1) then
seek = fm.finda
end else
seek = fm.findf
end
end else
locate(word,endwords;posn) then
seek = 'END'
end else
crt 'Starting word unknown'
gosub bad.comd ; return
end
end
end case
if seek = '' then
crt word:' has no matching word for ':comd
gosub bad.comd ; return
end
posn = index(oconv(line,'MCU'),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
bot = here - 1
if bot lt 1 then return
msup = 1
end else
bump = 1
bot = here + 1
if bot gt last then return
msup = last
end
save = here
for here = bot to msup step bump
gosub get.line
line = oconv(line,'MCU')
if line[1,1] ne '' then
temp = field(line,' ',1)
if num(temp) or temp[len(temp),1] = ':' 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] = seek<1,xx> then
if trim(line[slen+1,1]) = '' then
gosub display.line
return
end
end
next xx
next here
here = save
gosub get.line
case comd = 'FOLD' ; * fold the line
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last ; show = true
if dlim ne '' then fold = ''
if rest = '' then rest = fold
if rest = '' then rest = wide-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
* In UniVerse, we COULD replace the next two lines with
* TEMP = FOLD(LINE,FOLD)
* but then I'd need another flag, a nested one at that to cope with TRIMF
* and since I already wrote the code...
bite = line
gosub parse.bite
gosub check.line
if chng then
gosub change.made
end
case comd = 'FOR' or comd = 'FORMAT' ; * format this item
rest = oconv(rest,'MCU')
temp = index(rest,'-M',1)
if temp then fr(1) = field(rest[temp+2,99],' ',1) ; fr(2) = ''
if not(fr(1) matches '1N0N') then fr(1) = ''
if fr(1) = '' then
temp = this<1>
$ifdef trimfbworks
fr(1) = len(temp) - len(trimf(temp))
$else
chit = temp ; gosub trimfit
fr(1) = len(temp) - len(chit)
$endif
end
temp = index(rest,'-I',1)
if temp then fr(2) = field(rest[temp+2,99],' ',1)
if not(fr(2) matches '1N0N') then fr(2) = ''
if fr(2) = '' 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
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
crt 'Margin=':fr(1):', Indentation=':fr(2)
* FORMAT.BASIC = 'INDENTER'
* CALL @FORMAT.BASIC(THIS,LAST,MAT FR)
gosub indenter
gosub set.record
case 1 ; gosub bad.command
end case
return
g: begin case
case comd = 'G' ; * go to line
if numb ne '' then 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 = 'H' or comd = 'HELP'
gosub show.help
case comd = '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
bit = fmt(bit,prfx:'2':sufx)
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 = '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
if here gt 0 then
memr(cell) := str(am:rest,inum)
end else memr(1)<1> = str(rest:am,inum):memr(1)<1>
here = here + inum
gosub change.made
gosub get.line
gosub display.line
crt 'At line ':here:'. ':inum:' lines inserted,':
crt ' bottom now at line ':last:'.'
end else
if nill ne '' then
crt 'Terminate input with ':nill
end
loop
new1 = here + 1
stub = new1:'= '
if lfmt then stub = fmt(new1,lfmt):'='
gosub get.rope; line = rope
until line = nill do
gosub parse.line
last = last + 1
here = here + 1
lnum = lnum + 1
chng = 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 = nill then
crt begn:
if lfmt then crt fmt(new1,lfmt):'= ':
end
crt
numb = numb - 1
if numb = 0 then exit
repeat
crt begn:ceol:
end
if chng then gosub change.made
case comd = 'IC' ; * iconv
if viewflag then gosub viewonly ; return
if rest = '' then
crt 'No conversion given'
gosub bad.comd ; return
end
ccom = '*':rest ; gosub conv.command
case comd = 'IN' ; * insert from execute
if viewflag then gosub viewonly ; return
if trim(rest) = '' then
crt 'No external command given'
comi = '' ; return
end
execute rest capturing bite
if scrset then test = @(0,0)
numb = dcount(bite,am)
if numb then
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
this = insert(this,here+1,0,0,bite)
gosub set.record
crt 'Inserted ':numb:' lines':
crt '; 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 = '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 = here + 1
gosub set.bounds
for here = bot to msup
gosub get.line
test = test:join:line
next here
gosub delete.lines
if chng = 0 then return
here = save
oopl = here
gosub get.line
memr(cell) = test
gosub reset.record
end
gosub display.line
case 1 ; gosub bad.command
end case
return
k: begin case
case 1 ; gosub bad.command
end case
return
l: begin case
* List lines or Locate string
case comd = 'L' or comd = 'LN' or comd = 'LA' or comd = 'LNA'
if oconv(comi,'MCU') = 'L' then
if look<1,1> = '' then
crt 'No previous locate command to repeat.'
comi = ''
return
end
comi = look<1,1>
gosub parse.command
if comd = '' then comd = 'L' ; numb = 99999999
go l
end
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
bot = here - 1
if bot lt 1 then bot = 1
if numb then msup = here - numb + 1 else msup = 1
if msup lt 1 then msup = 1
end else
bump = 1
bot = here + 1
if bot gt last then bot = 1
if numb then msup = bot + numb - 1 else msup = last
if msup gt last then msup = last
end
line = rest ; gosub parse.line ; rest = line
if not(caseflag) then rest = oconv(rest,'MCU')
if not(spaceflag) then
$ifdef changeworks
convert ' ':char(9) to '' in rest
$else
chit = rest; old1 = ' '; new1 = ''
gosub changeit ; old1 = char(9)
gosub changeit ; rest = chit
$endif
end
for here = bot to msup step bump
gosub get.line
if cols then line = line[cols,colf]
if caseflag then temp = line else temp = oconv(line,'MCU')
if not(spaceflag) then
$ifdef changeworks
convert ' ':char(9) to '' in temp
$else
chit = temp; old1 = ' '; new1 = ''
gosub changeit ; old1 = char(9)
gosub changeit ; temp = chit
$endif
end
if index(temp,rest,1) 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 = msup
crt 'Now at line ':here:
if here = 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)
loop
while dcount(look,vm) gt looknumb do
look = delete(look,1,looknumb,0)
repeat
end
case comd = 'LC' ; * lower case (make line in)
if viewflag then gosub viewonly ; return
if rest = '' then ccom = 'MCL' else ccom = 'QMCL'
gosub conv.command
* Various forms for loading stuff
case comd = 'LD' or comd= 'LOAD' or comd= 'LDA' or comd= 'LOADA'
if viewflag then gosub viewonly ; return
if not(sec.load.flg) then
crt 'LOAD disabled'
comi = ''
return
end
gosub get.load
if temp = '' 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
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
this = insert(this,here+1,0,0,temp)
here = here + dcount(temp,am)
crt 'At line ':here:', ':dcount(temp,am):' lines loaded.'
temp = ''
gosub set.record
case comd = 'LL' ; * long lines
if not(rest matches '1N0N') then
rest = wide-llen-2
crt 'LL':numb:'/':rest
end
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
temp = trim(line[rest,999])
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 = 'M' ; * pattern matching
rest = field(rest,dlim,1)
if rest = '' then crt 'No pattern given to match'; return
gosub changematch.command
case comd = '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 = '' 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 = 'ME' ; * merge stuff from this file
if viewflag then gosub viewonly ; return
merge: rest = trim(rest)
if numb = '' then
if dlim = '"' 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
end
if not(rest matches '1N0N') or numb = '' then
crt 'Format of MErge command is: "MEn/n"; eg: "ME10/15"':
crt ' or "ME/n/m"; 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
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
this = insert(this,here+1,0,0,bite)
gosub set.record
crt 'Merged ':numb:' lines starting at line ':rest:
crt '; still at line ':here:'.'
end else
crt 'Nothing done - no lines selected.'
comi = '' ; return
end
case comd = 'MOVE' ; * move the block
if viewflag then gosub viewonly ; return
if not(beg) and not(fin) then
crt nb ; gosub bad.comd ; return
end
if here le fin and here ge beg then
crt 'A block may not be moved into itself. Copy will work.'
comi = ''
return
end
numb = fin - beg + 1
crt 'Lines ':beg:' to ':fin:' (':numb:
crt ') will be Copied (and deleted).'
stub = 'You are now at line ':here:'. Do it? n/y > '
gosub get.rope; answ = rope; crt
answ = oconv(trim(answ),'MCU')[1,1]
if answ ne 'Y' then
crt 'Block command canceled.'
return
end
dlim = ' '
rest = beg:' ':fin
numb = ''
gosub move
if numb then
beg = here + 1
fin = here + numb
end
case comd = 'MV' ; * move stuff from this file
if viewflag then gosub viewonly ; return
move: rest = trim(rest)
if numb = '' then
if dlim = '"' 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
end
if not(rest matches '1N0N') or numb = '' then
crt 'Format of MoVe command is: "MVn/n"; eg: "MV10/15"':
crt ' or "MV/n/m"; eg: "MV/15/24".'
gosub bad.comd ; return
end
msup = rest + numb - 1
if msup gt last then msup = last
if here ge rest and here le msup then
crt 'Nothing done - This line is within the range.'
comi = '' ; return
end
bite = field(this,am,rest,numb)
if numb ne 1 or bite ne '' then numb = dcount(bite,am)
if numb then
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
if here gt msup then
this = insert(this,here+1,0,0,bite)
this = this[1,col1()-1]:this[col2(),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
crt 'Moved ':numb:' lines starting at line ':rest:
if here gt msup then
here = here - numb
crt '; now at line ':here:'.'
end else
crt '; still at line ':here:'.'
end
end else
crt 'Nothing done - no lines selected.'
comi = '' ; return
end
case 1 ; gosub bad.command
end case
return
n: begin case
case comd = 'N' ; * same as "+"
if numb = '' then numb = 1
here = here + numb
if here gt last then here = last
gosub display.line
case comd = 'NULL' ; * null line input definition
dlim = trim(dlim):trim(rest)
dlim = dlim[1,1]
nill = dlim
crt 'NULL to terminate Insert is ':
if nill = '"' then
crt "'":nill:"'"
end else crt '"':nill:'"'
comi = ''
case comd = 'NUM' ; * toggle the line numbering
crt 'Line numbering ':
if lfmt = '' then
crt 'ON'
gosub get.lfmt
end else crt 'OFF' ; lfmt = ''
case 1 ; gosub bad.command
end case
return
o: begin case
case comd = 'OC' ; * oconv
if viewflag then gosub viewonly ; return
if rest = '' then
crt 'No conversion given'
gosub bad.comd ; return
end
ccom = rest ; gosub conv.command
case comd[1,2] = 'OO' ; * undo last change
if oopc ne '' then
this = oops
here = oopl
last = oopf
beg = oopb<1>
fin = oopb<2>
gosub set.record
crt '"':oopc:'" undone - now at line ':here:'.'
oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = ''
gosub display.line
end else
crt 'last change already "undone" or nothing to undo'
end
comi = ''
case 1 ; gosub bad.command
end case
return
p: begin case
case comd = 'P' ; * page on
if numb then plen = numb
numb = plen
if here ge last then here = 0
here = here + 1
gosub set.bounds
for here = bot to msup
gosub display.line
next here
here = msup
case comd = 'PA' ; * print window up to here
if numb then pwin = numb
numb = int(pwin)
save = here
here = here - numb
gosub set.bounds
for here = bot to msup
gosub display.line
next here
here = save
crt 'Still at ':here:'.'
case comd = '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 = '' 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
case comd = 'PL' ; * print window from here
if numb then pwin = numb
numb = int(pwin)
save = here
gosub set.bounds
for here = bot to msup
gosub display.line
next here
here = save
crt 'Still at ':here:'.'
case comd = 'PP' ; * print window bracketing here
if numb then pwin = numb
numb = pwin
save = here
here = here - int(pwin/2)
gosub set.bounds
for here = bot to msup
gosub display.line
next here
here = save
crt 'Still at ':here:'.'
case comd = 'PR' ; * prestore processing
if numb = '' then
crt 'Defined prestores'
for xx = 1 to presnumb
crt fmt(xx,prfx:'2':sufx):' ':pres<1,xx>
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 = rest<1,1,1>) then
crt 'Invalid - delimiter in prestore'
comi = ''
return
end
$ifdef changeworks
pres<1,numb> = change(rest,dlim,sm)
$else
old1 = dlim ; new1 = sm ; chit = rest
gosub changeit ; pres<1,numb> = chit
$endif
end else
salt = pres<1,numb>
end
case 1 ; gosub bad.command
end case
return
q: begin case
* Various forms for quitting
case comd = 'Q' or comd = 'QK' or comd = 'QUIT' or comd = 'QUITK'
if orig ne this then
stub = '***** Record changed --- OK to Quit? n/y > '
gosub get.rope; answ = rope; crt
answ = oconv(trim(answ),'MCU')[1,1]
if answ = 'Y' then stopsign = true
end else stopsign = true
if stopsign then
crt 'Quit "':item:'" in file "':fnam:'" ':
if orig = '' then crt 'not created.' else crt 'unchanged.'
if index(comd,'K',1) then
killsign = true
if idcnt gt 1 then crt 'Select list canceled.'
end
end
case 1 ; gosub bad.command
end case
return
r: begin case
case comd = 'RA'
if viewflag then gosub viewonly ; return
gosub change.command
case comd = 'R' and dlim ne '' and index(rest,dlim,1) ; * change
if viewflag then gosub viewonly ; return
crt ; comd = 'C'
gosub change.command
case comd = 'R' ; * replace lines
if viewflag then crt ; gosub viewonly ; return
if not(last) then
crt 'Empty record, use Insert (I).'
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 = '' then rest = ' '
loop
crt begn:
if lfmt then crt fmt(here,lfmt):'= ':
crt ceop:
if rest = '' then
stub = here:'= '
if lfmt then stub = fmt(here,lfmt):'='
gosub get.rope; line = rope
end else line = rest
gosub parse.line
until line = '' do
crt goup:begn:ceol:
if lfmt then crt fmt(here,lfmt):': ':
crt line
if line = comdmark then
line = ''
crt begn:
if lfmt then crt fmt(here,lfmt):': ':
end
if numb gt 1 then crt
if line = ' ' then line = ''
chng = chng + 1
memr(cell) = line
here = here + 1 ; numb = numb - 1
gosub get.line
if numb = 0 then exit
repeat
if here ne save then here = here - 1
if chng then
gosub change.made
gosub get.line
end
crt begn:ceol:
case comd = 'RELEASE' ; * release the item lock
release file,item
lock = false
case 1 ; gosub bad.command
end case
return
s: begin case
case comd = 'S' ; * search processing
if numb = '' then
crt 'Last ':looknumb:' searches (latest first)'
for xx = 1 to looknumb
crt fmt(xx,prfx:'2':sufx):' ':look<1,xx>
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 = '' then
crt 'There is no search ':numb
return
end
look = delete(look,1,numb,0)
look = insert(look,1,1,0,comi)
gosub parse.command
if comd = '' then comd = 'L' ; numb = 99999999
comi = ''
go l
case comd = 'SAVE' or comd = 'SV' ; * save the item
if viewflag then gosub viewonly ; return
comd = 'SV'
if rest = '' then
if not(sec.write.flg) then
crt 'File disabled'
comi = ''
return
end
gosub write.record
end else
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 = 'DICT' then
odpt = ofpt ; ofpt = oipt ; oipt = bite<3>
onam = onam:' ':ofpt
end
if oipt = '' 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 = odpt and fprt = ofpt then
ofil = file
end else
open odpt, ofpt to ofil else
crt 'File "':onam:'" was not found.'
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
$ifdef werrorworks
write this on ofil, oipt on error crt 'FAIL' ; return
$else
write this on ofil, oipt
$endif
crt 'Record "':oipt:'" saved in "':onam:'".'
end
case comd = 'SEQ' ; * build a sequence
if viewflag then gosub viewonly ; return
if dlim = '' 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 = '' 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 = '' 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)
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 = bot to msup
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
chng = chng + 1
memr(cell) = temp
gosub display.line
end
next here
here = msup
if chng then gosub change.made
case comd = 'SHOW' ; * show changes flag
shew = not(shew)
crt 'SHOW changes flag is ':
if shew then crt 'ON' else crt 'OFF'
case comd = 'SORT' ; * sort the block
if viewflag then gosub viewonly ; return
if not(beg) and not(fin) then
crt nb ; 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 = oconv(rest,'MCU')
if rest = '' 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 = last then temp<2> = len(this)+1
if not(temp<2>) then
crt 'Cannot find end of block'
gosub bad.comd ; return
end
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
bits = ''
for here = beg to fin
gosub get.line
locate(line,bits;posn;rest) else null
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)]
end else this = this[1,temp<1>]:bits
bits = ''
gosub set.record
gosub display.line
case comd = 'SPACE' ; * change spacing flag for 'L'
rest = oconv(rest,'MCU')
begin case
case rest = 'ON' ; spaceflag = true
case rest = 'OFF' ; spaceflag = false
case 1 ; spaceflag = not(spaceflag)
end case
crt 'SPACE flag is ':
if spaceflag then crt 'ON' else crt 'OFF'
case comd = 'SPOOL' ; * print
save = here
if numb = '' and rest matches '1N0N' then numb = rest
if numb = '' then here = 1 ; numb = last
gosub set.bounds
head = 'Record - ':item:' File - ':fnam
head = head:' Account - ':acct:' ':timedate():"'LL'"
temp = wide
printer on
temp = temp - llen - 2
heading head
for here = bot to msup
gosub get.line
$ifdef changeworks
convert badc to gudc in line
$else
chit = line; gosub change.non.print; line = chit
$endif
print fmt(here,lfmt):': ':line[1,temp]
loop
line = line[temp+1,len(line)]
until line = '' do
print space(llen+2):line[1,temp]
repeat
next here
printer close
if bot ne 1 or msup ne last then
crt 'Lines ':bot:' to ':msup:' of ':
end
crt '"':item:'" spooled to the printer.'
here = save
case comd = 'SPOOLHELP' ; * print the help
rest = am
gosub show.help
case comd = 'STAMP' ; * stamp it
if viewflag then gosub viewonly ; return
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
last = last + 1 ; here = here + 1 ; lnum = lnum + 1
line = '* Last updated by ':acct
if acct ne name then line = line:' (':name:')'
line = line:' at ':oconv(time(),'MTS')
line = line:' on ':oconv(date(),'D'):'.'
gosub insert.line
gosub reset.record
gosub display.line
case 1 ; gosub bad.command
end case
return
t: begin case
case comd = 'T' ; * top
here = 0
gosub display.line
case comd = 'TC' ; * text case (make line in)
if viewflag then gosub viewonly ; return
if rest = '' then ccom = 'MCT' else ccom = 'QMCT'
gosub conv.command
* Various ways to TRIM the line
case comd = 'TRIM' or comd = 'TRIMF' or comd = 'TRIMB'
if viewflag then gosub viewonly ; return
chng = 0 ; save = here ; savl = last
show = shew or index(rest,'S',1) or index(rest,'s',1)
if numb lt plen then show = true
if numb = '' and rest matches '1N0N' then numb = rest
gosub set.bounds
for here = bot to msup
gosub get.line
begin case
case comd = 'TRIM' ; temp = trim(line)
$ifdef trimfbworks
case comd = 'TRIMF' ; temp = trimf(line)
case comd = 'TRIMB' ; temp = trimb(line)
$else
case comd = 'TRIMF'
chit = line ; gosub trimfit ; temp = chit
case comd = 'TRIMB'
chit = line ; gosub trimbit ; temp = chit
$endif
end case
gosub check.line
next here
here = msup
if chng then
gosub change.made
if not(show) then
crt chng:' lines changed - now at ':here
end
end
return
case 1 ; gosub bad.command
end case
return
u: begin case
case comd = 'U' ; * same as "-"
if numb = '' 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 = 'UC' ; * upper case (make line in)
if viewflag then gosub viewonly ; return
if rest = '' then ccom = 'MCU' else ccom = 'QMCU'
gosub conv.command
case comd = 'UNLOAD' ; comd = 'SV' ; go s
if viewflag then gosub viewonly ; return
case 1 ; gosub bad.command
end case
return
v: begin case
case comd = 'V' ; * version information
crt 'Line EDitor version ':help.def
$ifdef qm
temp = trans('NEWVOC','$RELEASE',2,'X')
if temp = '' then
temp = trans('VOC','$RELEASE',2,'X')
end
if temp = '' then temp = 'not known'
crt ' QM version ':temp
$endif
$ifdef unidata
crt ' UniData version ':oconv('version','TVOC;X;;1')
$endif
$ifdef universe
temp = oconv('RELLEVEL','TNEWACC;X;;2')
if temp = '' then
temp = oconv('RELLEVEL','TVOC;X;;2')
end
if temp = '' then temp = 'not known'
crt ' UniVerse version ':temp
case comd = 'VLIST' ; * view vlist for programmer
crt 'Capturing VLIST data'
execute comi capturing temp
if temp<2> = '' then crt temp<1> ; return
ttid = whom:'_':levl:'_VLIST'
$ifdef werrorworks
write temp on acom, ttid on error temp = ''
if temp = '' then crt 'FAIL' ; return
$else
write temp on acom, ttid
$endif
temp = ''
crt 'editing VLIST data':
execute verb:' AE_COMS ':ttid
crt 'Back editing record "':item:'" in file "':fnam:'"'
delete acom, ttid
$endif
case 1 ; gosub bad.command
end case
return
w: begin case
case comd = 'W' or comd = 'WHERE' ; * what we are editing
crt
if not(viewflag) then crt 'Editing ': else crt 'Viewing ':
crt 'record "':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 = 'WM' ; * word marker display (change)
if dlim = '' then
crt 'WordMark is ':
end else
wordmark = dlim
crt 'WordMark changed to ':
end
if wordmark = '"' then
crt "'":wordmark:"'"
end else crt '"':wordmark:'"'
case 1 ; gosub bad.command
end case
return
x: begin case
* Another way of quitting
case comd = 'X' ; comd = 'QK' ; go q
case comd = '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
if scrset then test = @(0,0)
stub = 'return or command :'
gosub get.rope; rest = rope
if rest = '' then
crt begn:'returned: editing "':item:'" in "':fnam:'"'
end
until rest = '' do
repeat
gosub display.line
case comd = '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 = '' then numb = 1
bot = here
if bot lt 1 then bot = 1
msup = bot + numb - 1
if msup gt last then msup = last
numb = 0
return
null.command:
if dlim = '/' then
comd = 'L'
if numb = '' then numb = 99999999
return
end
if dlim = '-' or dlim = '+' then
if rest = '' then rest = 1
end
if numb ne '' then comd = numb ; return
if dlim = '' and rest = '' then
here = here + 1
if here gt last then here = 1
gosub display.line
return
end
crt
begin case
case dlim = '+' and rest matches '1N0N'
here = here + rest
if here gt last then here = last
gosub display.line
case dlim = '-' 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 = '^'
wild = not(wild)
crt 'Unprintable characters ':
if wild then crt 'shown.' else crt 'not shown.'
case dlim = '='
crt 'UNIDATA prestore is not implemented - Use "PR"'
case dlim = '.'
gosub dot.command
case dlim = '$'
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 = ''
crt 'Record "':comd:'" does not exist in "AE_XCOMS".'
case xcom[len(xcom)-2,3] ne '_AE'
gosub bad.xcom
case 1
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
comd = comd:' ':rest
call @xcom(mat junk)
comd = ''
end case
case comi = '?'
temp = 'R#22'
crt fmt('Login name = ',temp):name:
crt' (':term:', userno ':whom:')'
crt fmt('Account = ',temp):acct
if path ne '' then crt fmt('VOC path = ',temp):path
crt fmt('Level = ',temp):levl
crt fmt('File name = ',temp):fnam
crt fmt('Record id = ',temp):item
crt fmt('Current line = ',temp):here
crt fmt('Lines = ',temp):last
crt fmt('Characters = ',temp):len(this)
if chan ne '' then
crt fmt('Last Change command = ',temp):chan<1,1>
end
if cmat ne '' then
crt fmt('Last CMatch command = ',temp):
crt 'CM':cmat<1,3>:cmat<1,1>:cmat<1,2>
end
if olda then
crt fmt('Last Append command = ',temp):'A':
crt olda<1,2>:olda<1,1>
end
if beg or fin then
crt fmt('Block = ',temp):beg:'-':fin
end
crt 'Command Delimiter is ':
if comdmark = '"' then
crt "'":comdmark:"'":
end else crt '"':comdmark:'"':
crt ', NULL to terminate insert is ':
if nill = '"' then
crt "'":nill:"'":
end else crt '"':nill:'"':
crt ', WordMark is ':
if wordmark = '"' then
crt "'":wordmark:"'"
end else crt '"':wordmark:'"'
crt 'Page: window for PA/PL/PP is ':pwin:
crt ', length for P is ':plen
crt 'Up arrow ^ ':
if wild then crt 'on': else crt 'off':
crt ', CASE flag ':
if caseflag then crt 'on': else crt 'off':
crt ', SPACE flag ':
if spaceflag then crt 'on': else crt 'off':
crt ', SHOW flag ':
if shew then crt 'on' else crt 'off'
if oopc ne '' then
crt 'OOPS will restore record prior to command: ':oopc
end else
crt 'OOPS already executed, or no changes in effect.'
end
case comi[1,2] = '<>' ; gosub botharr
case comi[1,1] = '<' ; gosub leftarr
case comi[1,1] = '>' ; gosub rightarr
case 1
gosub bad.command
end case
return
parse.cols:
good = true
cols = field(rest,dlim,2)
rest = field(rest,dlim,1)
colf = field(cols,'-',2)
cols = field(cols,'-',1)
if colf = '' 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
change.command:
if comd = 'RA' then
if numb = '' then
crt 'Last ':channumb:' changes (latest first)'
for xx = 1 to channumb
crt fmt(xx,prfx:'2':sufx):' ':chan<1,xx>
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 = '' then
crt 'There is no change ':numb
return
end
chan = delete(chan,1,numb,0)
chan = insert(chan,1,1,0,comi)
gosub parse.command
comi = 'RA'
end
gosub get.fromto
if comi = '' then return
chng = 0 ; save = here ; savl = last
glob = index(field(rest,dlim,3),'G',1)
glob = glob + index(field(rest,dlim,3),'g',1)
show = shew or index(field(rest,dlim,3),'S',1)
show = show or index(field(rest,dlim,3),'s',1)
if numb lt plen then show = true
gosub set.bounds
for here = bot to msup
gosub get.line
gosub change.line
gosub check.line
next here
here = msup
if comi ne '' and oconv(comi,'MCU') ne 'RA' then
chan = insert(chan,1,1,0,comi)
loop
while dcount(chan,vm) gt channumb do
chan = delete(chan,1,channumb,0)
repeat
end
if chng then
gosub change.made
if not(show) then crt chng:' lines changed - now at ':here
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 = '' and count(rest,dlim) lt 2 then
crt 'Missing required TO field (for "CHANGE/FROM/TO").'
comi = ''
return
end
return
change.line:
if cfrom = '' then
temp = cto:line
end else
if glob then
$ifdef changeworks
temp = change(line,cfrom,cto)
$else
chit = line ; old1 = cfrom ; new1 = cto
gosub changeit ; line = chit
$endif
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)
if numb lt plen then show = true
if numb = '' and rest matches '1N0N' then numb = rest
gosub set.bounds
ctyp = ccom[1,1]
begin case
* ICONV
case ctyp = '*' ; ccom = ccom[2,999]
* Text conversion LC, TC, or UC command
case ctyp = 'Q' ; ccom = ccom[2,999]
end case
for here = bot to msup
gosub get.line
begin case
case ctyp = '*'
temp = iconv(line,ccom)
case ctyp = 'Q'
temp = field(trim(line),' ',1)
flag = false
if temp ne 'REMOVE' then
if temp[1,3] = 'REM' then flag = true
if temp[1,1] = '*' then flag = true
if temp[1,1] = '!' 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 = flag ; flag = ''
case flag ne ''
case index(qt,bit,1) ; flag = bit
case 1 ; bit = oconv(bit,ccom)
end case
temp = temp:bit
next xx
end
case 1
temp = oconv(line,ccom)
end case
if temp = '' then temp = line
gosub check.line
next here
here = msup
if chng then
gosub change.made
if not(show) then
crt chng:' lines changed - now at ':here
end
end
return
dot.command:
save = comi
comi = field(comi,dlim,2,999)
gosub parse.command
begin case
case comd = 'A' ; * append to line
if numb = '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
stak<1,numb> := rest
crt fmt(numb,prfx:'3':sufx):'. ':stak<1,numb>
end
case comd = 'C' ; * change lines
if numb = '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
gosub get.fromto
if comi = '' 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
crt fmt(numb,prfx:'3':sufx):'. ':temp
end
case comd = 'D' ; * delete lines
if numb = '' 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 = 'I' ; * insert a new line
if numb = '' 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)
crt fmt(numb,prfx:'3':sufx):'. ':stak<1,numb>
end
end
case comd = 'L' or comd = '' ; * list lines
if numb = '' then
if comd = 'L' then numb = plen else numb = 1
end
if numb gt dcount(stak,vm) then numb = dcount(stak,vm)
temp = rem(numb+1,plen)
for xx = numb to 1 step -1
crt fmt(xx,prfx:'3':sufx):'. ':stak<1,xx>
if xx gt 1 and rem(xx,plen) = temp then
stub = 'Press Enter'
gosub get.rope; wait = rope; crt
if wait = 'X' then exit
end
next xx
case comd = 'R' ; * restore a line to latest
if numb = '' 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 = 'S'
if numb = '' then numb = 1
if numb gt presnumb then
crt numb:' exceeds the pre-store limit of ':presnumb
return
end
rest = trim(rest)
bot = field(rest,dlim,1) ; if bot = '' then bot = 1
msup = field(rest,dlim,2) ; if msup = '' then msup = 1
if not(bot matches '1N0N' and msup matches '1N0N') then
crt 'One of the values was not a number'
return
end
if bot gt msup then temp = bot ; bot = msup ; msup = temp
temp = ''
for xx = msup to bot step -1
temp<1,1,-1> = stak<1,xx>
next xx
crt 'TEMP = ':temp
pres<1,numb> = temp
case comd = 'U' ; * upcase line
if numb = '' then numb = 1
if numb gt dcount(stak,vm) then
crt 'History command ':numb:' does not exist.'
end else
stak<1,numb> = oconv(stak<1,numb>,'MCU')
end
case comd = 'X' ; * re-execute an editor command
if numb = '' 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
bite = '^':fmt(bite,prfx:'3':sufx)
end else bite = char(bite)
temp = temp:bite
next xx
crt 'Command was: "':temp:'"'
comi = ''
temp = ''
return
bad.xcom:
crt 'Line 2 of record "':rest:'" in file "AE_XCOMS"'
crt 'contains "':xcom:'".'
crt
crt 'This line should contain the name of a Basic subroutine that'
crt 'has been written to implement the external command "':rest:'".'
crt 'The program name must end in "_AE". Try "help xcoms".'
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 = '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 = 'FD' then
stub = '***** You are about to DELETE the record! OK? n/y >'
gosub get.rope; temp = rope; crt
if trim(oconv(temp,'MCU'))[1,1] ne 'Y' then return
$ifdef werrorworks
delete file, item on error crt 'FAIL' ; return
$else
delete file, item
$endif
crt 'Deleted "':item:'" from file "':fnam:'".'
end else
if comd = 'SV' then
$ifdef werrorworks
writeu this on file, item on error crt 'FAIL' ; return
$else
writeu this on file, item
$endif
orig = this ; oops = '' ; oopc = '' ; oopl = '' ; oopf = ''
oopb = ''
crt 'Saved "':item:'" in "':fnam:'" - now at line ':here:'.'
return
end else
$ifdef werrorworks
write this on file, item on error crt 'FAIL' ; return
$else
write this on file, item
$endif
crt 'Filed "':item:'" in file "':fnam:'"':
if orig = this then crt 'unchanged.' else crt '.'
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
$ifdef changeworks
convert vmrk to am in line
$else
chit = line ; old1 = vmrk ; new1 = am
gosub changeit ; line = chit
$endif
ttid = whom:'_':levl:'_':vals:'.in.line#':here
$ifdef werrorworks
write line on acom, ttid on error crt 'FAIL' ; return
$else
write line on acom, ttid
$endif
crt 'editing ':vals:' as fields...':
execute verb:' AE_COMS ':ttid
if scrset then test = @(0,0)
crt 'Back editing record "':item:'" in file "':fnam:'"'
read line from acom, ttid else line = ''
delete acom, ttid
return
reset.fields:
$ifdef changeworks
convert am to vmrk in line
$else
chit = line ; old1 = am ; new1 = vmrk
gosub changeit ; line = chit
$endif
if temp ne line then
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
memr(cell) = line
gosub reset.record
end
return
get.load:
temp = ''
if trim(rest) = '' then
stub = 'Record name, or file name and record name >'
gosub get.rope; rest = rope; crt
if trim(rest) = '' then temp = ''; return
end
keepquot = false
gosub parse.rest
onam = bite<1>
onid = bite<2>
if onam = 'DICT' then
onam = onam:' ':onid
onid = bite<3>
end
if onid = '' then onid = onam ; onam = ''
if onid = '' then return
if onam = '' then
onam = fnam
odpt = dprt
ofpt = fprt
ofil = file
end else
odpt = field(onam,' ',1)
ofpt = field(onam,' ',2)
if ofpt = '' then ofpt = odpt ; odpt = ''
if odpt ne '' and odpt ne 'DICT' then
crt 'File "':onam:'" was not found.'
gosub bad.comd ; return
end
open odpt, ofpt to ofil else
crt 'File "':onam:'" was not found.'
gosub bad.comd ; return
end
end
read temp from ofil, onid then
if comd = 'CUT' then
stub = 'Record "':onid:'" already exists - overwrite? (Y/N) '
gosub get.rope; answ = rope; crt
answ = oconv(trim(answ),'MCU')[1,1]
if answ = 'Y' then temp = 'TRUE' else temp = ''
end
end else
if comd = 'CUT' then temp = 'TRUE'; return
crt 'Record "':onid:'" was not found on file "':onam:'".'
gosub bad.comd ; temp = '' ; 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 = 'CM' then cmat = dlim:vm:rest:vm:numb
cto = field(rest,dlim,3)
line = cto ; gosub parse.line ; cto = line
cfrom = oconv(field(rest,dlim,2),'MCU')
if cfrom = '' then cfrom = 'L'
if numb = '' and cto = '' and (cfrom = 'L' or cfrom = 'N') then
numb = last
flag = true
end else flag = false
if len(cfrom) = 1 and index('ADLNPR',cfrom,1) then
end else
gosub parse.cols
if not(good) then return
cfrom = ''
colf = cols + colf - 1
end
gosub set.bounds
show = shew
chng = 0 ; save = here ; savl = last
test = ''
for here = bot to msup
gosub get.line
if not(line matches patt) then
if cfrom = 'N' then
numb = numb + 1
gosub display.line
if flag then msup = here
end
continue
end
numb = numb + 1
temp = line
begin case
case cfrom = 'A'
temp = cto:line
case cfrom = 'D'
crt fmt((here + chng),lfmt):'+ ':line
test<-1> = here
case cfrom = 'L'
gosub display.line
if flag then msup = here
case cfrom = 'P'
temp = line:cto
case cfrom = 'R'
temp = cto
case cfrom = 'N'
numb = numb - 1
case 1
gosub parse.temp
end case
if index('APR',cfrom,1) or cfrom = '' then
gosub check.line
end
next here
if cfrom = 'D' and numb then
oops = this ; oopc = comi ; oopl = save ; oopf = savl
oopb = beg:am:fin
for here = numb to 1 step -1
temp = test
del this
if beg = temp then beg = 0
if beg gt temp then beg = beg - 1
if fin = temp then fin = 0
if fin gt temp then fin = fin - 1
next here
test = ''
gosub set.record
here = msup - numb
end else
here = msup
end
crt 'At line ':here:
if here ge last then crt '(bottom)':
crt '. ':
if not(numb) then
crt 'No lines (in ':bot:'-':msup:') ':
if cfrom = 'N' then crt 'NOT ':
crt 'matching pattern "':patt:'"':
end else
begin case
case cfrom = 'D'
crt 'Deleted ':numb:' lines matching "':patt:'"':
case cfrom = 'L'
crt 'Found ':numb:' lines matching "':patt:'"':
case cfrom = 'N'
crt 'Found ':numb:' lines NOT matching "':patt:'"':
end case
end
crt
if chng then
gosub change.made
begin case
case cfrom = 'A'
crt '"':cfrom:'" appended to ':
case cfrom = 'D'
crt 'Deleted ':
case cfrom = 'P'
crt '"':cfrom:'" prefixed to ':
case cfrom = 'R'
crt 'Replaced with "':cto:'", ':
case cfrom = 'L' or cfrom = 'N'
case cols = colf
crt 'Element ':cols:' changed to "':cto:'" in ':
case cols
crt 'Element ':cols:'-':colf:' changed to "':cto:'" in ':
end case
crt chng:' line':
if chng gt 1 then crt 's':
crt ' matching "':patt:'"'
end
return
parse.pattern:
* BITS<1> is the pattern pieces, <2> 'S'tring or 'P'attern flag
cntr = 1
bits = ''
flag = ''
good = true
first = true
xxno = len(patt)
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> = 'S'
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
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
* Get rid of some hard ones (0N0N --> 1N0N, like)
loop
chng = false
for xx = 1 to cntr
type = bits<2,xx>
if type = 'P' and bits<2,xx+1> = 'P' then
bit = bits<1,xx>
if bit[1,1] = '0' then
if bits<1,xx+1> = '0X' or bits<1,xx+1> = bit then
bits<1,xx> = '1':bit[2,1]
chng = true
end else
if bits<1,xx+1>[1,1] = '0' and bit = '0X' then
bits<1,xx+1> = '1':bits<1,xx+1>[2,1]
end
end
end
end
next xx
while chng do
repeat
return
parse.temp:
temp = ''
posn = 1
for xx = 1 to cntr
what = bits<1,xx>
type = bits<2,xx>
nmbr = what[1,1]
begin case
case xx gt colf
temp = line[posn,len(line)]
xx = cntr
case type = 'S'
bit = bits<1,xx>
posn = posn + len(bit)
temp = bit
case nmbr = '0' and xx = cntr
temp = line[posn,len(line)]
case nmbr = '0' and what ne '0X'
type = what[2,1]
bit = ''
yyno = len(line)
for yy = posn to yyno
chit = line[yy,1]
if chit matches '1':type then
bit = bit:chit
end else yy = yyno
next yy
if bits<2,xx+1> = 'P' then
what = bits<1,xx+1>
if what[2,1] = type then
crt 'BIT = ':bit
bit = bit[1,len(bit)-what[1,1]]
crt 'BIT = ':bit
end
end
temp = bit
posn = posn + len(bit)
case nmbr = '0' and bits<2,xx+1> = 'S'
temp = line[posn,len(line)]
bit = index(temp,bits<1,xx+1>,1)
bit = temp[1,bit-1]
temp = bit
posn = posn + len(bit)
case nmbr = '0'
* OK if we can get the rest of the length
bit = 0
for yy = xx + 1 to cntr
if bits<2,yy> = 'S' then
bit = bit + len(bits<1,yy>)
end else
nmbr = bits<1,yy>[1,1]
* I can't figure out what to do - SODDIT
if nmbr = '0' then
crt 'Line matches, but pattern ambiguous.'
crt fmt(here,lfmt):'# ':line
if here lt msup then msup = here ; crt 'Stopped ':
temp = line ; return
end
bit = bit + nmbr
end
next yy
bit = line[posn,len(line)-posn-bit+1]
temp = bit
posn = posn + len(bit)
case 1
bit = line[posn,nmbr]
posn = posn + len(bit)
temp = bit
end case
next xx
temp = cto
for xx = cols + 1 to colf
temp = delete(temp,cols+1)
next xx
$ifdef changeworks
convert am to '' in temp
$else
chit = temp ; old1 = am ; new1 = ''
gosub changeit ; temp = chit
$endif
return
get.lines:
stub = "'Q'uit, or starting line > "
gosub get.rope; bot = rope
bot = oconv(trim(bot),'MCU')
if bot = '' then bot = 1 ; crt bot:
if bot[1,1] = 'Q' then temp = false ; return
if not(bot matches '1N0N') then
crt
crt 'Nothing done - starting and ending lines must be numeric.'
gosub bad.comd ; temp = false ; return
end
if bot gt dcount(temp,am) then
crt
crt 'Nothing done - the record does not have that many lines.'
gosub bad.comd ; temp = false ; return
end
stub = "'Q'uit, or starting line > ":bot:', ending line > '
gosub get.rope; msup = rope
msup = oconv(trim(msup),'MCU')
if msup = '' then msup = dcount(temp,am) ; crt msup:
if msup[1,1] = 'Q' then temp = false ; return
if not(msup matches '1N0N') then
crt
crt 'Nothing done - starting and ending lines must be numeric.'
gosub bad.comd ; temp = false ; return
end
if msup gt dcount(temp,am) then
msup = dcount(temp,am)
crt begn:"File is ":onam:": 'Q'uit, or starting line > ":
crt bot:', ':msup:
end
temp = field(temp,am,bot,msup-bot+1)
crt
return
parse.bite:
temp = ''
loop
while bite ne '' do
$ifdef trimfbworks
bite = trimf(bite)
$else
chit = bite ; gosub trimfit ; bite = chit
$endif
xx = fold
if count(bite[1,xx],' ') and trim(bite[xx+1,1]) ne '' then
loop
until trim(bite[xx,1]) = '' 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:
if help.def = '' then
crt '**** the file LED.HELP could not be opened'
return
end
rest = trim(oconv(rest,'MCU'))
temp = field(rest,' ',1)
* IF TEMP NE '' AND TEMP NE 'NEW' AND TEMP NE AM THEN
* READ HELP FROM LED.HELP,TEMP THEN
* REST = FIELD(REST,' ',2)
* END ELSE HELP = ''
* END ELSE HELP = ''
* IF HELP = '' THEN
* READ HELP FROM LED.HELP,HELP.DEF ELSE
* CRT 'There is no default help for ':HELP.DEF
* RETURN
* END
* END
if rest = am then
printer on
heading "LED editor help file ":timedate():"'LL'"
xxno = dcount(help,am)
for xx = 1 to xxno
temp = help
print temp
next xx
printer close
return
end
if rest = 'NEW' then crt ; crt 'New features' ; crt
good = false
xxno = dcount(help,am)
pg = 0
flag = false
for xx = 1 to xxno
temp = help
bit = temp[1,len(rest)]
if temp[14,1] = '=' then
temp = temp[1,13]:'-':temp[15,99]
if rest = 'NEW' then bit = 'NEW'
end
if trim(bit) ne '' then flag = false
if bit = rest or flag then
flag = true
pg = pg + 1
if pg ge system(3) then
stub = "'S'kip the rest of this explanation, "
stub := 'or press return >'
gosub get.rope; answ = rope
crt begn:ceol:
answ = trim(oconv(answ,'MCU'))[1,1]
if answ = 'S' or answ = 'Q' then
crt
return
end
pg = 1
end
crt temp
good = true
end
next xx
if not(good) then
crt
crt "No explanation of '":rest:"' is available."
crt "For a list of words that have explanations, type 'HELP'."
crt
end
return
get.page.comd:
gosub get.comd
do.page.comd:
locate(comd,keys;cpos) then cpos = acts else cpos = 0
begin case
case cpos = uarr ;* up key
if here le 1 then crt bell:; return
gosub check.page
here = 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 = darr ;* down key
if here ge last then crt bell:; return
gosub check.page
here = 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 = larr ;* left key
if pchr le 1 then crt bell:; return
pchr = pchr - 1
if pchr lt ppos then
gosub check.page
gosub disp.page
end
case cpos = rarr ;* right key
pchr = pchr + 1
if pchr-ppos ge wide then
gosub check.page
gosub disp.page
end
case cpos = upag ;* page up key
gosub check.page
ptop = ptop - botl
if ptop lt 1 then ptop = 1
here = here - botl
if here lt 1 then here = 1
pchr = 1
gosub get.line; temp = line
gosub disp.page
case cpos = 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 = lpag ;* start of line key
pchr = 1
if pchr lt ppos then gosub check.page; gosub disp.page
case cpos = rpag ;* end of line key
pchr = len(temp)+1
if pchr lt ppos then gosub check.page; gosub disp.page
if pchr-ppos ge wide then
gosub check.page
gosub disp.page
end
case cpos = tpag ;* top page key
gosub check.page
here = 1
ptop = 1
pchr = 1
gosub disp.page
gosub get.line; temp = line
case cpos = bpag ;* bottom page key
gosub check.page
here = last
ptop = last - botl + 1
gosub get.line
pchr = len(line)
gosub disp.page
gosub get.line; temp = line
case cpos = escp ;* escape key
if this ne that then
crt botp:@(-13):'Abandoning changes':@(-14)
end
this = that
here = savl<1>
gosub set.record
mode = 'LINE'
case cpos = phlp ;* help key
gosub page.help
case cpos = zoom ;* go to line key
stub = 'Go to line :'
crt botp:
gosub get.rope; numb = trim(rope)
crt botp:'Press ':kcap(phlp):' for help':
if not(numb matches '1N0N') then numb = here
if numb gt last then numb = last
if numb = here then return
gosub check.page
here = numb
ptop = here
pchr = 1
gosub disp.page
gosub get.line; temp = line
case not(sec.write.flg)
crt bell:
case cpos = delc ;* delete character key
if temp = '' then return
if pchr = 1 then
temp = temp[2,len(temp)]
end else
temp = temp[1,pchr-1]:temp[pchr+1,len(temp)]
end
crap = temp[pchr,wide-pcol]
$ifdef changeworks
convert badc to gudc in crap
$else
chit = crap; gosub change.non.print; crap = chit
$endif
crt @(pcol,prow):ceol:crap:
case cpos = dell ;* delete line key
del this
gosub set.record
gosub disp.page
gosub get.line; temp = line
case cpos = 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
del this
this = line
gosub set.record
gosub disp.page
gosub get.line; temp = line
end else
temp = temp[1,pchr-1]
this = temp
memr(cell) = temp
line = temp
crt @(pcol,prow):ceol:
end
case cpos = back ;* keys(back)space key
if pchr = 1 then crt bell:; return
pchr = 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,wide)
crt @(pcol,prow):ceol:
crap = temp[pchr,wide-pcol]
$ifdef changeworks
convert badc to gudc in crap
$else
chit = crap; gosub change.non.print; crap = chit
$endif
crt crap:
end
case cpos = carr ;* keys(carr)iage return key
if pchr = 1 then
line = ''
end else
line = temp[1,pchr-1]
temp = temp[pchr,len(temp)]
end
memr(cell) = line
last = last + 1
lnum = lnum + 1
line = temp
gosub insert.line
gosub reset.record
here = 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 = togg ;* keys(togg)le mode key
if mode<2> = 'Ins' then
mode<2> = 'Over'
end else mode<2> = 'Ins'
case cpos = writ ;* write away data key
gosub check.page
mode = 'LINE'
return
case cpos = doit
gosub doit.comd
case seq(comd) lt 28 or seq(comd) gt 127 or len(comd) gt 1
crt bell:
case seq(comd) eq 30 or seq(comd) eq 31
crt bell:
case 1
if seq(comd) = 28 then comd = char(252)
if seq(comd) = 29 then comd = char(253)
if pchr and len(temp) lt (pchr-1) then
temp = temp:str(' ',pchr)
temp = temp[1,pchr-1]
end
if mode<2> = 'Ins' then
offset = pchr
end else offset = pchr+1
if pchr = 1 then
temp = comd:temp[1,len(temp)]
end else
temp = temp[1,pchr-1]:comd:temp[offset,len(temp)]
end
if mode<2> = 'Ins' then
crt @(pcol,prow):ceol:
crap = temp[pchr,wide-pcol]
$ifdef changeworks
convert badc to gudc in crap
$else
chit = crap; gosub change.non.print; crap = chit
$endif
crt crap:
end else
crt @(pcol,prow):comd:
end
pchr = pchr + 1
if pchr-ppos ge wide then
gosub check.page
gosub disp.page
end
end case
return
check.page:
chng = ''
gosub check.line
if chng then gosub reset.record
return
get.comd:
$ifdef qm
comd = keyinc()
locate(comd,kini;kpos) then
loop
nap 5
input full,-1
while full do
comd := keyinc()
locate(comd,kmul,kpos;full) then return
repeat
end
$endif
$ifdef universe
comd = keyin()
locate(comd,kini;kpos) then
loop
nap 5
input full,-1
while full do
comd := keyin()
locate(comd,kmul,kpos;full) then return
repeat
end
$endif
$ifdef unidata
comd = in()
locate(comd,kini;kpos) then
loop
a = system(12)
loop
until system(12) ge (a+5) do
repeat
input full,-1
while full do
comd := in()
locate(comd,kmul,kpos;full) then return
repeat
end
$endif
return
page.help:
gosub clear.page
crt @(30,0):'Page editing help':
crt @(0,2):' Cursor movement keys ':
crt @(0,4):' UP = ':kcap(uarr):
crt @(0,5):' DOWN = ':kcap(darr):
crt @(0,6):' LEFT = ':kcap(larr):
crt @(0,7):' RIGHT = ':kcap(rarr):
crt @(0,9):' Page movement keys':
crt @(0,11):' PREVIOUS = ':kcap(upag):
crt @(0,12):' NEXT = ':kcap(dpag):
crt @(0,13):' TOP = ':kcap(tpag):
crt @(0,14):' BOTTOM = ':kcap(bpag):
crt @(40,2):' Line movement keys':
crt @(40,4):' LEFT END = ':kcap(lpag):
crt @(40,5):' RIGHT END = ':kcap(rpag):
crt @(40,6):' GO TO LINE = ':kcap(zoom):
crt @(50,7):'(prompts for desired line)':
if sec.write.flg then
crt @(40,9):' Deleting keys':
crt @(40,11):' DELETE CHAR = ':kcap(delc):
crt @(40,12):' DELETE LINE = ':kcap(dell):
crt @(40,13):' DELETE TO EOL = ':kcap(delr):
crt @(50,14):'(at EOL joins next line)':
crt @(40,15):' = Value Mark':
crt @(40,16):' = Sub-value Mark':
crt @(0,16):space(15-len(kcap(back))):
crt ' ':kcap(back):' is destructive':
crt @(0,17):space(15-len(kcap(carr))):
crt ' ':kcap(carr):' splits the line':
crt @(0,18):space(15-len(kcap(togg))):
crt ' ':kcap(togg):
crt ' toggles between the insert and overwrite modes':
if keys(writ) ne '' then
crt @(0,20):space(9-len(kcap(writ))):
crt ' ':kcap(writ):' Returns to line editor mode':
if sec.write.flg then crt ' WITH changes':
end
end
crt @(0,21):space(9-len(kcap(escp))):
crt ' ':kcap(escp):' Returns without changes'
crt botp:
stub = 'Press to continue:'
gosub get.rope
gosub display.page
return
get.line:
line = ''
if here = 0 or here gt last then return
cell = int((here-1)/cellsize) + 1
$ifdef removeworks
coff = rem(here,cellsize)
if ooff and ocel = cell and ooff = 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 = 2 then
lnum = lnum + 1
if lnum = coff then exit
line = ''
end else
line = line:char(256-dlim)
end
repeat
if not(dlim) then lnum = lnum + 1
$else
lnum = rem(here,cellsize)
if not(lnum) then lnum = cellsize
line = memr(cell)
$endif
return
delete.lines:
chng = 0
if bot gt msup then
crt 'No deletion possible - ':bot:' > ':msup
return
end
oops = this ; oopc = comi ; oopl = here ; oopf = last
oopb = beg:am:fin
chng = msup - bot + 1
begin case
case bot = 1 and msup = last
this = ''
beg = 0
fin = 0
case msup = last
temp = index(this,am,bot-1)
this = this[1,temp-1]
if beg gt bot then beg = 0
if fin gt bot then fin = 0
case bot = 1
temp = index(this,am,msup)
this = this[temp+1,len(this)]
if beg le msup then beg = 0 else beg = beg - chng
if fin le msup then fin = 0 else fin = fin - chng
case 1
temp = index(this,am,bot-1)
temp<2> = index(this,am,msup)
this = this[1,temp<1>]:this[temp<2>+1,len(this)]
if beg ge bot and beg le msup then beg = 0 else
if beg gt msup then beg = beg - chng
end
if fin ge bot and fin le msup then fin = 0 else
if fin gt msup then fin = fin - chng
end
end case
gosub set.record
return
check.line:
if '*':temp ne '*':line then
chng = chng + 1
memr(cell) = temp
if show then gosub display.line
end
return
insert.line:
if here le beg then beg = beg + 1
if here le fin then fin = fin + 1
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 = 0 ; here = 0 ; crt begn:'Top of empty record.'
case here = 0 ; cell = 1 ; lnum = 0 ; 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
bite = '^':fmt(bite,prfx:'3':sufx)
end else bite = char(bite)
temp = temp:bite
next xx
line = temp
end else
$ifdef changeworks
convert badc to gudc in line
$else
chit = line; gosub change.non.print; line = chit
$endif
end
crt begn:ceol:
if lfmt then
blk = ': '
if here = beg then blk = '< '
if here = fin then blk = '> '
if here = beg and here = fin then blk = '<>'
if lfmt then crt (here lfmt):blk:
end
crt line
if here = last then crt 'Bottom at line ':last:'.'
end case
return
clear.page:
crt @(0,1):ceop:@(0,0):ceol:
return
display.page:
crt clpg
disp.page:
gosub clear.page
gosub get.lfmt
crt botp:'Press ':kcap(phlp):' for help':
crt @(0,0):
if not(viewflag) then crt 'Editing ': else crt 'Viewing ':
crt '"':item:'" in file "':fnam:'" ':ceol:
if idcnt gt 1 then crt '<':id:'/':idcnt:'> ':
crt
ppos = int((pchr-1)/wide)
ppos = wide*ppos+1
save = here:am:lnum:am:cell:am:line
for xx = 1 to botl
here = ptop + xx - 1
gosub get.line
disp = line[ppos,wide]
$ifdef changeworks
convert badc to gudc in disp
$else
chit = disp; gosub change.non.print; disp = chit
$endif
crt @(0,xx):disp
next xx
here = save<1>; lnum = save<2>; cell = save<3>; line = save<4>
return
change.made:
oops = this ; oopc = comi ; oopl = save ; oopf = savl
oopb = beg:am:fin
reset.record:
matbuild this from memr using am
set.record:
gosub parse.record
if here and here le last then
gosub get.line
end else cell = 1 ; lnum = 0
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 = 0 then
$ifdef newdimworks
dim memr(1)
$else
cellsize = 1
$endif
mat memr = ''
cell = 1 ; lnum = 0
return
end
$ifdef newdimworks
numcells = int((last-1)/cellsize)+1
dim memr(numcells)
$else
cellsize = int(last/numcells)+1
$endif
mat memr = ''
$ifdef removeworks
cell = 1
lnum = 0
line = ''
loop
remove bite from this setting mark
line = line:bite
begin case
case mark = 0
if line ne '' then
line = line[1,len(line)]
end
memr(cell) = line
case mark = 2
lnum = lnum + 1
if lnum ge cellsize then
memr(cell) = line
line = ''
cell = 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
$else
lnum = 1
cell = 0
xx = 0
loop
cell = cell + 1
xx = xx + cellsize
temp = index(this,am,xx)
if temp then
memr(cell) = this[lnum,temp-lnum]
lnum = temp + 1
end else
memr(cell) = this[lnum,9999999]
end
while xx lt last do
repeat
$endif
cell = 1
lnum = 0
return
locked.record:
stub = 'Record currently locked by another user. Try again (Y/N) '
gosub get.rope; answ = rope; crt
answ = oconv(trim(answ),'MCU')
if answ = 'PASSWORD' then
lock = false
read this from file, item then go carry.on
end
if answ[1,1] = 'Y' then go edit.item
return
exec.that:
temp = temp<1>:' ':fnam:' ':item:temp<2>
$ifdef filinfworks
if fileinfo(file,3) ne '4' then
crt 'Cannot ':temp:' - must be type 1 or 19'
return
end
$endif
execute temp
if scrset then 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 = ' ' then
if bite ne '' then posn = posn + 1
end else
if index(qt,bit,1) then
flag = bit
if keepquot then bite = bite:bit
end else
if bit = '(' then
flag = ')'
if bite ne '' then posn = posn + 1
bite = '('
end else bite = bite:bit
end
end
end else
if bit ne flag then
bite = bite:bit
end else
if keepquot or bit = ')' then bite = bite:bit
posn = 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 = ';' then
posn = posn + 1
end else
if index(qt,bit,1) then flag = bit
if bit = '(' then flag = ')'
bite = bite:bit
end
end else
if bit = flag then flag = ''
bite = bite:bit
end
next xx
return
get.lfmt:
* set up the line format
llen = len(last)
if llen lt 3 then llen = 3
lfmt = prfx:llen:sufx
prmt = '*':str('-',llen-1)
return
doit.comd:
* This is where the page editor could be expanded - does nothing now
return
leftarr: *
numb = oconv(trim(comi[2,len(comi)]),'MCN')
if numb = '' 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 = here then gosub display.line
end else crt 'Cannot mark line ':numb
return
rightarr: *
numb = oconv(trim(comi[2,len(comi)]),'MCN')
if numb = '' 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 = 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 = ''
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 ne '' then
beg = numb<1>
fin = numb<2>
if beg = fin then
crt 'Block starts and ends at line ':beg
end else
crt 'Block starts at ':beg:' and ends at ':fin
end
if here = beg or here = fin then
gosub display.line
end
end else crt 'Cannot mark Block'
return
$ifndef changeworks
* This is only required if CHANGE and CONVERT don't work
changeit:
loop
bits = index(chit,old1,1)
while bits do
chit = chit[1,bits-1]:new1:chit[bits+len(old1),len(chit)]
repeat
return
change.non.print:
if chit ne oconv(chit,'MCP') then
yyno = len(chit)
bite = ''
for yy = 1 to yyno
bit = chit[yy,1]
if bit ne oconv(bit,'MCP') then
sit = seq(bit)
if sit = char(253) or sit = char(252) else bit = '~'
end
bite := bit
next yy
chit = bite
end
return
$endif
$ifndef trimfbworks
* This is only required if TRIMF doesn't work
trimfit:
bit = trim(chit)
if bit = '' then chit = bit ; return
bit = bit[1,1]
bit = index(chit,bit,1)
chit = chit[bit,len(chit)]
return
* This is only required if TRIMB doesn't work
trimbit:
bit = trim(chit)
if bit = '' then chit = bit ; return
bit = bit[len(bit),1]
bits = count(chit,bit)
bits = index(chit,bit,bits)
chit = chit[1,bits]
return
$endif
setup.help:
help = ''
help<-1> = " LED version 01.05"
help<-1> = " The Line EDitor can be called with the following formats:"
help<-1> = " LED file and record id's are prompted for"
help<-1> = " LED file record id's are prompted for"
help<-1> = " LED file id edit the record 'id' in 'file'"
help<-1> = " LED file id id... edit multiple records in 'file'"
help<-1> = " LED file * edit all records in 'file'"
help<-1> = " SELECT may precede 'LED 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> = " (NOTE that '/' is used as delimiter, but any non-alphanumeric works)"
help<-1> = "A - Do the last 'A any' (APPEND) command again."
help<-1> = "A any - APPEND 'any' to this line."
help<-1> = "B - Set the current line pointer to the BOTTOM line."
help<-1> = "B any - BREAK the current line after 'any' into two lines."
help<-1> = "BD any - BREAK and discard the second part."
help<-1> = "BK any - BREAK and Keep only the second part."
help<-1> = "C - Do the last 'CHANGE' command again."
help<-1> = "C/// - CHANGE one or more lines. Formats are:"
help<-1> = " C/from/to C#/from/to/"
help<-1> = " C/from/to/G C#/from/to/G"
help<-1> = " C/from/to/S C#/from/to/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> = "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> = "CM/// - ChangeMatch one or more lines. Formats are:"
help<-1> = " CM/pattern CM#/pattern"
help<-1> = " CM/pattern/range/to 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, saying 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> = "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> = "COL - Display relative COLUMN POSITIONS on the CRT."
help<-1> = "COPY - Copy the predefined block to after the current line"
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 " or \ as delimiter to change quotes>'
help<-1> = "CUT - Remove and save the predefined block."
help<-1> = " You will be prompted for a file and item to save it to."
help<-1> = "CUTx/y - Remove and save x lines starting at line y."
help<-1> = "CUT/x/y - Remove and save the lines starting at x to line y inclusive."
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'."
$ifdef qm
help<-1> = "DISPLAY xxxx - Inserts a line DISPLAY 'xxxx = ':xxxx"
help<-1> = " Just like CRT, handy to distinguish debug code."
$endif
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> = "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> = "EPR - Edit the prestored commands."
help<-1> = "ESV - Edit subvalues as lines."
help<-1> = "EV - Edit multivalues as lines."
help<-1> = "EW - Edit words as lines."
help<-1> = "EXIT (EX) - QUIT - EXIT the editor."
help<-1> = "EXITK (EXK) - QUITKill - EXIT the editor, 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)."
$ifdef qm
help<-1> = " You can modify BASIC with D for DEBUGGING (EG. FIBD)."
$endif
help<-1> = " You can modify CATALOG with L for LOCAL (EG. FICL)."
help<-1> = "FILE - Synonym for SAVE"
help<-1> = "FM - Find Matching logic by position"
help<-1> = "FM/any - Find next line with string 'any' matching start of this line"
help<-1> = "FMA - Find Matching logic by position above this line"
help<-1> = "FMA/any - Find Matching string 'any' above this line."
help<-1> = "FOLD/length - Split current line (on blanks if possible) to fit the width."
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> = "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 CRT."
help<-1> = "HELP any - Display HELP information on CRT 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> = "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> = "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> = "LN#/any/1-20 - LOCATE NOT - line without 'any' in columns 10 to 20"
help<-1> = "LNA#/any/1-2 - LOCATE line above this one without 'any' in columns 10 to 20"
help<-1> = "LL#/length - Show lines 'length' or longer (null '#' is a search)"
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> = "MEx/y - Merge x lines starting at line y"
help<-1> = "ME/x/y - Merge lines starting at x to line y inclusive"
help<-1> = "MOVE - Move the predefined block to after the current line"
help<-1> = "MVx/y - Move the x lines starting at line y"
help<-1> = "MV/x/y - Move the lines starting at x to line y inclusive"
help<-1> = "NUM - Toggle the line numbering"
help<-1> = "NULL/ - Change the 'end of inserting' character to '/'"
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> = "P - PRINT on CRT the number of lines specified by last 'P#'."
help<-1> = "P# - PRINT on CRT '#' 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> = "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 editor."
help<-1> = "QUITK (QK) - QuitKill - EXIT the editor, 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 and move it to #1."
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 and move it to #1."
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 - toggle overriding 'S'how flag for 'C' command."
help<-1> = "SORT seq - Sort the predefined block (seq defaults to 'AL')"
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> = "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> = "TRIMB# - TRIMB '#' lines (default 1)."
help<-1> = "TRIMF# - TRIMF '#' lines (default 1)."
help<-1> = "UC# - Change '#' lines to upper case (default 1)."
help<-1> = "UC# any Comments and quoted strings are unchanged."
help<-1> = "V - Version information"
$ifdef universe
help<-1> = "VLIST - Allows viewing a VLIST output (UniVerse only)"
$endif
help<-1> = "WHERE (W) - Show the item and file being edited."
help<-1> = "WM - Show or change the word marker."
help<-1> = "X - QuitKill - EXIT the editor, 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 editor. Upon completion of the"
help<-1> = " command, control will be returned back to the editor."
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 CRT 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> = ".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."
help<-1> = "-# - Back up current line POINTER by '#' lines."
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 display non-printing characters as"
help<-1> = " ^nnn where nnn is the decimal equivalent of ASCII code."
help<-1> = "? - Show various parameters."
help<-1> = ""
return
indenter:
* SUBROUTINE INDENTER(THIS,XXNO,MAT FR)
* S/R - Indents program logic
* DIM FR(10)
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
equ dead to 'ACDGHIJKMOPQSVXYZ'
push = 'LOOP\WHILE\UNTIL\FOR\THEN\ELSE\BEGIN\LOCKED\ERROR'
$ifdef changeworks
push = convert('\',am,push)
pull = convert('\',am,'UNTIL\WHILE\REPEAT\NEXT\END')
$else
chit = push ; old1 = '\' ; new1 = am
gosub changeit ; push = chit
chit = pull ; old1 = '\' ; new1 = am
gosub changeit ; pull = chit
$endif
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) = '' then
if first then bite = '' else bite = ''
continue
end
note = false
wcnt = 0; more = 0; less = 0
mark = ''; tags = ''; lastword = ''
zz = 1
$ifdef trimfbworks
thisline = trimf(thisline)
$else
chit = thisline ; gosub trimfit ; thisline = chit
$endif
if thisline matches '1N0N"*"0X' then
temp = field(thisline,'*',1)
temp = thisline[col2(),len(thisline)]
thisline = field(thisline,'*',1):' ':temp
end
left = field(thisline,' ',1)
if num(left) or left[len(left),1] = ':' then
if not(index(left,'=',1)) then tags = left
end
if tags gt '' then
$ifdef trimfbworks
thisline = trimf(thisline[col2()+1,len(thisline)])
$else
chit = thisline[col2()+1,len(thisline)]
gosub trimfit
thisline = chit
$endif
end
zzno = len(thisline)
loop
while zz lt zzno and not(note) do
loop
thisun = thisline[zz,1]
begin case
case mark = '' and index(marx,thisun,1)
mark = thisun
case mark ne ''
if thisun = mark then mark = ''
case wcnt and thisun = ';'
that = field(trim(thisline[zz+1,zzno]),' ',1)
that = oconv(that,'MCU')
if that ne 'REMOVE' then
if that[1,3] = 'REM' then that = ''
if that[1,1] = '*' then that = ''
if that[1,1] = '!' then that = ''
end
if that = '' then zz = zzno
case wcnt
case thisun = '!' or thisun = '$'
note = true; zz = zzno
case astx and thisun = '*'
note = true; zz = zzno
case oconv(field(thisline,' ',1),'MCU') = 'REMOVE'
case oconv(thisline[zz,3],'MCU') = '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 = thisline[zz,1]
until index(skip,thisun,1) or zz gt zzno do
zz += 1
repeat
word = oconv(thisline[left,zz-left],'MCU')
wcnt += 1
if wcnt ne 1 then
if word = 'WHILE' or word = 'UNTIL' then word = ' '
if word = 'NEXT' or word = 'REPEAT' then
word = ' '
more -= dent
end
if lastword = 'LOCKED' then more -= dent
end
if word = 'CASE' then
if lastword ne 'BEGIN' and lastword ne 'END' then
more += dent
less += dent
end
if suit and lastword = 'BEGIN' then more += dent
if suit and lastword = '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' and word ne 'ELSE' and word ne 'ERROR'
that = trim(thisline[zz,zzno])
if that[1,1] = ';' then
that = trim(that[2,zzno])[1,3]
if that ne 'REMOVE' then
if that[1,3] = 'REM' then that = ''
if that[1,1] = '*' then that = ''
if that[1,1] = '!' then that = ''
end
end
if test or that = '' then
locate(word,push;rubbish) then
more += dent
end
end
if that ne '' and lastword = '' then
if word = 'THEN' or word = 'ELSE' then
more -= dent
less -= dent
end
end
end
lastword = word
repeat
marg -= less
if tags = '' then pict = '' else pict = 'L#':(len(tags)+1)
if marg gt len(tags) then pict = 'L#':marg
if thisline = '!' or thisline = '$' then note = true
if oconv(thisline,'MCU') = 'REM' then note = true
if astx and thisline = '*' then note = true
if note then
if tags = '' then pict = '' else pict = 'L#':(len(tags)+1)
end
$ifdef trimfbworks
thisline = trimb(fmt(tags,pict):thisline)
$else
chit = fmt(tags,pict):thisline
gosub trimbit
thisline = chit
$endif
if first then
bite = thisline
end else bite = 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:
return
end
* The following variables are used
*
* BARE - what you are going to reveal (the displayed part)
* CRAM - insert mode on (vs overwrite mode)
* DPOT - display position
* STEM - the prefix part of the display line
* ICON - a picture of what you last displayed
* PANS - the PAN increment
* PPOT - the PAN origin position
* SPAN - the PAN width
* PULP - SEQ(COMI) - what you get from a key press
* PURE - untouched, a virgin
* POST - the stack position
* TPOT - text position
* XX - loop variable
* yy - loop variable
post = 0
rope = ''
loop
if heap then
stem = prmt:': '
if post then stem = '>':fmt(post, "2'0'R"):stem[4,99]
end else
stem = '>':stub
end
span = wide - len(stem)
pans = int(span/2)
ppot = 1
tpot = 1
cram = true
icon = space(wide)
crt begn : ceol :
pure = true
loop
begin case
case tpot lt ppot ; ppot -= pans
case tpot ge (ppot+span) ; ppot += pans
end case
bare = stem : rope[ppot, span]
dpot = 0
if icon ne bare then
left = 0
for xx = 1 to wide until left
if bare[xx,1] ne icon[xx,1] then left = xx
next xx
crt @(left-1):bare[left,wide]:ceol:@(dpot):
icon = bare[1,wide]
end
dpot = len(stem) + tpot - ppot
crt @(dpot) :
gosub get.comd
locate(comd,keys;cpos) then cpos = acts else cpos = 0
pulp = seq(comd)
if pulp lt 32 or pulp ge 128 then comd = ''
if pure and cpos eq 0 and comd ne '' then
rope = ''
tpot = 1
end
pure = false
begin case
case heap and (cpos eq uarr or cpos eq upag)
if post lt dcount(stak, vm) then
post += 1
rope = stak<1,post>
end
exit
case heap and (cpos eq darr or cpos eq dpag)
if post gt 1 then
post -= 1
rope = stak<1,post>
end else
post = 0
rope = ''
end
exit
case cpos eq larr
if tpot gt 1 then tpot -= 1
case cpos eq rarr
if tpot le len(rope) then tpot += 1
case cpos eq lpag
tpot = 1
case cpos eq rpag
tpot = len(rope) + 1
case cpos eq escp
post = 0
rope = ''
exit
case cpos eq delc
rope = rope[1, tpot - 1] : rope[tpot + 1, 999]
case cpos eq delr
rope = rope[1, tpot - 1]
case cpos eq back
if tpot gt 1 then
tpot -= 1
rope = rope[1, tpot - 1] : rope[tpot + 1, 999]
end
case cpos eq carr
!IF NOT(HEAP) THEN RETURN
!$IFDEF TRIMFBWORKS
! ROPE = TRIMF(TRIMB(ROPE))
!$ELSE
! CHIT = ROPE
! GOSUB TRIMFIT; GOSUB TRIMBIT
! ROPE = CHIT
!$ENDIF
if heap then crt begn : ceol : ':' : rope:
return
case cpos eq togg
cram = not(cram)
crt @(0):
if cram then crt '>': else crt '#':
crt @(dpot):
case pulp eq 23 ;* ctrl-w
begin case
case rope eq oconv(rope,'MCL')
rope = oconv(rope,'MCU')
case rope eq oconv(rope,'MCT')
rope = oconv(rope,'MCL')
case rope eq oconv(rope,'MCU')
rope = oconv(rope,'MCT')
case 1
rope = oconv(rope,'MCU')
end case
case pulp ge 32 and pulp lt 128
if cram then
rope = rope[1, tpot - 1] : comd : rope[tpot, 999]
end else
if tpot le len(rope)
then rope[tpot, 1] = comd
else rope := comd
end
tpot += 1
case 1
crt bell:
end case
repeat
repeat
return