******************************************************************************* * * uniVerse PI/open EDITOR * * Module %M% Version %I% Date %H% * * (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved * This is unpublished proprietary source code of Ardent Software Inc. * The copyright notice above does not evidence any actual or intended * publication of such source code. * ******************************************************************************* * * Maintenance log - insert most recent change descriptions at top * * Date.... GTAR# WHO Description......................................... * 10/14/98 23801 SAP Change copyrights. * 07/30/96 18933 ALC Corrected fix below, it had quoting problems * 06/10/96 18598 PEJ Modified create.file &ED& for NT * 04/12/96 18194 KAM Disallow VOC Fptr changes if MODFPTRS tunable set * 03/13/96 17797 AGM Replace 'SH -c' with OS.EXEC * 10/27/95 17576 LDG If NLS on, check ^ mode display for invalid UTF. * 06/28/95 16793 LDG Hide NLS functionality until after 8.3.3 * 05/18/95 15741 EAP Added error message for NLS write errors * 05/16/95 15741 EAP Added error message for NLS unmappable Ids * 05/03/95 16475 LDG Only display record ID in ^ mode if ^ or ^X is * actually on if NLS is enabled. * 04/28/95 16433 LDG Changed ^X handling of char 128 (SQL NULL) * 04/26/95 16433 LDG Changed ^X handling of chars 248 thru 250. * 03/09/95 13096 SAP Fixed problem with SPOOL command core dumping. * 02/07/95 16092 LDG Added ^X for Unicode UP ARROW mode, plus ability to * input all Unicode characters via ^X. * 12/07/94 15420 PVW Fix error handling on opens * 11/08/94 13738 JSM Change definition of non-printing characters to be * compatible with release 6 editor * 03/15/94 12299 LA Replaced calls to PRINTER.IO to reset terminal and/or * printer with PRINTER CLOSE and PRINTER RESET * statements to make sure printer buffer is flushed. * 02/16/94 12267 FTW Allow nulls to be edited in all cases. * 02/11/94 12101 FTW Fixed several lock releasing problems. * 01/24/94 12516 KAM Fixed LOOP functionality for prestored commands. * 11/05/93 11751 WLG Fixed to recognize difference between "" and no * Record-id being supplied. * 10/28/93 11751 WLG Fixed to allow null record-ids. * 08/18/93 12082 PVW Changed message 970012 and added message 970013 * 07/07/93 11317 PVW Fix problem with SPOOL command * 07/07/93 11762 PVW Save and Restore all COMMON variables * 06/29/93 11742 PVW Handle SQL Integrity Constraint Violations * 06/29/93 11762 PVW Clear COMMON variables before exiting ED * 06/01/93 11645 PVW Remove DEVSYS.STRIPSTRS.MODE from code * 03/18/93 11152 WLG Fixed non-existent error to use message 20141 * 02/23/93 11109 PVW Fix handling of sql null when inserting. * 02/19/93 10797 PVW Check status() before writing out to another record * for part files. * 02/02/93 10955 PVW Fixed editor error messages if DICT file. * 02/01/93 10966 PVW Allow SQL NULL as element in multivalued data. * 01/25/93 10716 LPC Enforce data restrictions for partfiles. * 01/21/93 10797 LPC Check for invalid partfiles * 01/21/93 10908 PVW Fix problem with I types. * 01/06/93 10826 PVW Change the way the LOOP handles start command. * 01/06/93 10785 PVW Make 'FI file item' behave as 'FILE file item' * 01/05/93 10812 PVW Fix problem when line = char(128) in ^ mode. * 01/05/93 10757 PVW Correct permissions handling for the new editor * 12/31/92 10793 PVW Set DEVSYS.STRIPSTRS.MODE to "Editor". * 12/30/92 10757 PVW Changed handling for Pnn,"-",and "+". * 12/18/92 10757 PVW Change special character handling. * 12/17/92 10214 PVW Further changes to merge the two editors. * 12/17/92 10692 PVW Show char 128 in up arrow mode. * 12/11/92 10708 PVW Open and close DEVSYS.VOC.FILE within ED. * 12/09/92 10214 PVW Help Message added. * 12/07/92 10214 PVW More formatting problems. * 12/03/92 10214 PVW Fixed miscellaneous problems regarding QA. * 11/11/92 10214 PVW Port PI/open EDITOR to replace uniVerse EDITOR. * ******************************************************************************* $OPTIONS INFORMATION $INCLUDE UNIVERSE.INCLUDE VERBINSERT.H $INCLUDE UNIVERSE.INCLUDE UV.COM $INCLUDE UNIVERSE.INCLUDE FORMAT.OPTS.H $INCLUDE UNIVERSE.INCLUDE GETPU.H $INCLUDE UNIVERSE.INCLUDE FILENAMES.H $INCLUDE UNIVERSE.INCLUDE UVNLS.H $INCLUDE UNIVERSE.INCLUDE MACHINE.NAME ******************************************************************************* * * The following lines of code are included to setup this program * with then same input as the PI/open ED.B subroutine receives * from the PI/open command line processor PERFORM.B. * * SUBROUTINE ED (SENTENCE, MAT SYMBOLS) * $INCLUDE UNIVERSE.INCLUDE SYMBOL.TBL.H OPEN "VOC" TO DEVSYS.VOC.FILE ELSE CALL *UVPRINTMSG(001752,"") STOP END DIM SYMBOLS (VALSTART + MAXTOKENS) MAT SYMBOLS = '' SYMBOLS (NEXT.TKN.VALUE) = VALSTART SYMBOLS (ORIGINAL.SENTENCE) = @SENTENCE SENTENCE = TRIMF(@SENTENCE) CHECK.TOKEN = FIELD(SENTENCE," ",1) IF CHECK.TOKEN = "RUN" OR CHECK.TOKEN = "RAID" THEN SENTENCE = FIELD(SENTENCE," ",2,9999) SENTENCE = TRIMF(SENTENCE) SENTENCE = FIELD(SENTENCE," ",2,9999) END ******************************************************************************* * *---- EQU's and DIMensions. EQU IntegrityViolation TO -3 EQU OBJ.FMC TO 19 EQU VOC.K.CODE.DICT TO 20 EQU LINES.PER.CELL TO 40 ; * LINES PER CELL OF MEMORY MATRIX EQU STARS LIT 'STR("*", 5)' SETPU = '!SETPU' GETPU = '!GETPU' MATBLOCK = '-MATBLOCK' GET.FILE.NAME = '-GET.FILE.NAME' ; * To get file name from command line. STRIPSTRINGS = '-STRIPSTRINGS' FORMAT.BASIC = '-FORMAT.BASIC' PERMISSIONS = '-PERMISSIONS' SQLINTCHK = '-SQLINTCHK' OpenError = '-OpenError' *---- Define vital elements of blocked memory (see GET.LINE comments). @SYSTEM.SET = 0 MEMORY.DIM = 100 ; * Initial size of memory matrix. DIM MEMORY (MEMORY.DIM) DIM LPC (MEMORY.DIM) DIM PRIOR.MEMORY (MEMORY.DIM) DIM PRIOR.LPC (MEMORY.DIM) DIM SAVED.MEMORY (MEMORY.DIM) DIM SAVED.LPC (MEMORY.DIM) NEW.MEMORY.DIM = 20 ; * INITIAL SIZE OF NEW.MEMORY MATRICES DIM NEW.MEMORY (NEW.MEMORY.DIM) DIM NEW.LPC (NEW.MEMORY.DIM) GOSUB CLEAR.NEW.MEMORY ; * CLEAR MATRICES AND INITIALIZE VARIABLES DIM CMD.STACK (101), CMD.NAME (5) MAT CMD.STACK = '' DIM ED.CMD.STRING (1) *---- Initialize for this EDIT session. OVERFLOW.FLAG = 0 ; * SJE 23 Apr 84 ABORT.FLAG = '' STACK.MODE = FALSE ; * indicates if stack processor mode INPUT.MODE = FALSE ; * indicates if prompt is '=' or ':' INPUT.LINE = '' BLOCK.VERIFY.FLAG = TRUE RECORD.NAME.LOCKED = FALSE PROMPT ' ' ; AT.LIST = '' ; AT.SUB = '' ; HELP.RECORD = '' X = '@FILE' ; Y = '' GOSUB AT.INSERT X = '@ID' ; Y = '' GOSUB AT.INSERT X = '@LINE' ; Y = '' GOSUB AT.INSERT X = '@IM' ; Y = @IM GOSUB AT.INSERT X = '@VM' ; Y = @VM GOSUB AT.INSERT X = '@SM' ; Y = @SM GOSUB AT.INSERT X = '@COMMAND' ; Y = @COMMAND GOSUB AT.INSERT X = '@PARASENTENCE' ; Y = @PARASENTENCE GOSUB AT.INSERT X = '@SENTENCE' ; Y = @SENTENCE GOSUB AT.INSERT X = '@LEVEL' ; Y = @LEVEL GOSUB AT.INSERT X = '@LOGNAME' ; Y = @LOGNAME GOSUB AT.INSERT X = '@WHO' ; Y = @WHO GOSUB AT.INSERT X = '@USERNO' ; Y = @USERNO GOSUB AT.INSERT X = '@TIME' ; Y = OCONV(@TIME, 'MTHS') GOSUB AT.INSERT X = '@DATE' ; Y = OCONV(@DATE, 'D4') GOSUB AT.INSERT X = '@MONTH' ; Y = @MONTH GOSUB AT.INSERT X = '@DAY' ; Y = @DAY GOSUB AT.INSERT X = '@YEAR' ; Y = @YEAR GOSUB AT.INSERT X = '@TM' ; Y = @TM ; * 007 GOSUB AT.INSERT ; * 007 LINES.MESSAGE = @SYS.BELL:'Number of lines to print must be a' PRE.STORE = 'Pre-stored command' REC = 'record' UREC = 'Record' ENABLED = 'enabled' DISABLED = 'disabled' UNICODE = '+Unicode' ;* NLS, for when ^X enabled, not just ^ IN.FILE = ' in file "' DUMMY = @(0) ; * TURN OFF CRT PAGING ON DISPLAY FIRST.RECORD = TRUE APPEND = '' ; * APPEND STRING CMD = '' ; * COMMAND LINE CMD.STACK (1) = '$' ; * END OF STACK INDICATOR CMD.STRING = '' ; * CMD STACK DUMPED INTO HERE BEFORE BEING SAVED (.S) COMMA = FALSE ; * FOR ANALYZING SAVE (.S) COMMAND CURR.CMD.NAME = '' ; * INIT VARIABLE DELIM.STRING = '!"#$%&()*+,-./:=@[\]_`{|}':"'" ED.CMD.STRING (1) = '$' ; * INIT END OF PRE-STORED COMMAND STRING INDICATOR ED.CMD.STRING.ACTIVE = FALSE ; * FLAG TRUE IF A CMD STRING IS BEING EXECUTED ED.CMD.STRING.SUSPENDED = FALSE ; * FLAG TRUE IF AN EXECUTING COMMAND STRING IS IN 'PAUSE' MODE END.STACK = 1 ; * POINTER TO THE END OF STACK INDICATOR L.SELECT.FLAG = FALSE ; * FLAG TRUE IF CMD STRING RECORD NAMES SELECTED FROM A FILE LOOP.FLAG = FALSE ; * FLAG TRUE IF CMD STRING IS BEING REPEATED BY A 'LOOP' COMMAND NULL.CTR = 0 ; * COUNTER FOR SUCCESSIVE NULL COMMANDS STACK.LIMIT = 100 ; * MAX NR OF STACK COMMANDS IS 99 UNLOAD.FLAG = FALSE ; * FLAG TRUE IF USING STRING.WRITE SUBR TO UNLOAD LINES UPCMD = '' ; * INIT VARIABLE UPCMD4 = '' ; * INIT VARIABLE ERROR.COND = CHAR(0):@IM:CHAR(0) ; * ERROR INDICATOR FIND.STRING = '' ; * 'FIND' STRING FLEN = 0 ; * LENGTH OF FIND.STRING ST.COLUMN = 1 ; * STARTING COLUMN (FIND COMMAND) LOCATE.STRING = '' ; * LOCATE SEARCH STRING MATCH.STRING = '' ; * 'MATCH' STRING OLD.CHANGE.CMD = '' ; * PREVIOUS CHANGE COMMAND PNUM = @CRTHIGH - 2 ; * LAST NUMBER OF LINES PRINTED REPLACE.STRING = '' ; * PREVIOUS REPLACE COMMAND STRING UP.ARROW = '^' ; * DEFINE UP ARROW CHARACTER UP.ARROW.FLAG = FALSE ; * DISPLAY SPECIAL CHAR AS !XXX, FLAG UP.ARROW.UNIC = '^x' ; * NLS up arrow mode that uses Unicode UP.ARROW.UNIC.UP = UPCASE(UP.ARROW.UNIC) ;* used frequently LEN.UP.ARROW.UNIC = LEN(UP.ARROW.UNIC) ;* ...ditto UP.ARROW.UNIC.FLAG = FALSE ; * (display chars as ^xhhhh) in hex NLS.ON.FLAG = SYSTEM(NLS$ON) ; * Set to 1 if NLS support switched on PP.LINES = 20 ; * Default line count for PP command. PL.LINES = 20 ; * Default line count for PL command. NUM.REMAINING = '' ; * to control null editing *---- Get CRT line width for folding. CRT.WIDTH = @CRTWIDE IF CRT.WIDTH < 1 OR CRT.WIDTH > 132 THEN CRT.WIDTH = 80 *---- Parse command sentence for file and record names. SENT = TRIMF(FIELD(SENTENCE, ' ', 2, 9999)) INPUT.FILENAME: PROMPT.FOR.FILE = TRUE ; NO.SELECT.LIST = TRUE SINGLE.FILE.ONLY = TRUE ; ONLY.ONE.RECORD.FLAG = FALSE FILE.NAME = '' ; DICT = '' CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, DICT, FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY) IF DICT = '' THEN DICT.TEXT = '' ELSE DICT.TEXT = DICT:' ' IF LEN(FILE.NAME) = 0 OR FILE.NAME # FILE.NAME <1> THEN GOTO STOP * * Open the file to be edited. Carry on if partially successful open * of distributed file. * TEMP.SENTENCE = '' FILE.NAME.VALID = FALSE LOOP UNTIL FILE.NAME.VALID DO IF FILE.NAME = '' THEN CALL @GET.FILE.NAME(NO.SELECT.LIST,TEMP.SENTENCE,DICT,FILE.NAME,PROMPT.FOR.FILE,SINGLE.FILE.ONLY) END IF DICT = '' THEN DICT.TEXT = '' ELSE DICT.TEXT = DICT:' ' IF LEN(FILE.NAME) = 0 OR FILE.NAME # FILE.NAME<1> THEN GOTO STOP OPENCHECK DICT, FILE.NAME TO EDIT.FILE THEN FILE.TYPE = STATUS() FILE.NAME.VALID = TRUE EDIT.READ.ONLY = FALSE EDIT.PERM.MODE = 1 EDIT.PERM.IN = 6 EDIT.PERM.OUT = '' CALL @PERMISSIONS(EDIT.FILE,EDIT.PERM.MODE,EDIT.PERM.IN,EDIT.PERM.OUT) IF NOT(EDIT.PERM.OUT) THEN EDIT.READ.ONLY = TRUE END END ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,FILE.NAME THEN IF DICT = "" THEN PathName = FileRec<2> END ELSE PathName = FileRec<3> END RELEASE DEVSYS.VOC.FILE,FILE.NAME END ELSE PathName = "" END IF DICT = "" THEN FileName = FILE.NAME END ELSE FileName = "DICT,":FILE.NAME END CALL @OpenError(ErrorCode,FileName,PathName) DICT = '' ; FILE.NAME = '' END REPEAT X = '@FILE' ; Y = FILE.NAME ; GOSUB AT.INSERT IF TRIM(SENT) = '""' OR TRIM(SENT) = "''" THEN NULL.ID = TRUE END ELSE NULL.ID = FALSE IF INDEX(SENT, "'", 1) + INDEX(SENT, '"', 1) THEN CALL @STRIPSTRINGS(SENT, MAT SYMBOLS) END ELSE SENT = TRIM(SENT) IF SENT = '*' THEN CALL *UVPRINTMSG(001295,"") SELECT EDIT.FILE SENT = '' END SELECT.LIST.FLAG = FALSE READLIST RECORD.LIST THEN CONVERT @IM TO @FM IN RECORD.LIST SELECT.LIST.FLAG = TRUE NUM.REMAINING=DCOUNT(RECORD.LIST,@FM) END ELSE RECORD.LIST = '' END IF LEN(SENT) # 0 THEN IF COUNT(SENT, ' ') = 0 AND NOT(SELECT.LIST.FLAG) THEN ONLY.ONE.RECORD.FLAG = TRUE NUMSENT=COUNT(SENT,' ')+1 SENT.AVAIL=NUMSENT NUM.REMAINING=NUMSENT LOOP RECORD.NAME = FIELD(SENT, ' ', 1) IF RECORD.NAME [1, 1] = CHAR(LITERAL) THEN RECORD.NAME = SYMBOLS(RECORD.NAME [2, 999]) END SENT = SENT [COL2() + 1, 999999] WHILE SENT.AVAIL GT 0 SENT.AVAIL=SENT.AVAIL-1 RECORD.LIST=RECORD.NAME REPEAT END IF COUNT(RECORD.LIST, @FM) THEN SELECT.LIST.FLAG = TRUE GET.NEXT.RECORD: ; * Get the next record. GOSUB GET.RECORD GOSUB OOPS.INITIAL.SAVE ; * SET UP FOR OOPS <==== GET.CMD: ; * Get next command from user. * Set up to save record prior to change for 'OOPS'. IF CHANGE.FLAG OR CHANGE.DURING.CMD.STRING THEN IF NOT(ED.CMD.STRING.ACTIVE) THEN GOSUB OOPS.AFTER.CHANGE.CMD ; * SET UP FOR OOPS <==== CHANGE.DURING.CMD.STRING = FALSE END ELSE CHANGE.DURING.CMD.STRING = TRUE END GET.CMD.0: IF CHANGE.FLAG THEN RECORD.CHANGE.FLAG = TRUE IF BOT = 0 THEN LNUM = 0 ; * BOT=0 MEANS RECORD IS NULL IF BOT THEN GOSUB GET.LINE ; * GET LINE IF RECORD IS NOT NULL ELSE IF CHANGE.FLAG THEN CHANGE.FLAG = FALSE ; RECORD.CHANGE.FLAG = TRUE IF NOT(ED.CMD.STRING.ACTIVE) THEN IF LNUM => BOT AND BOT > 0 THEN CALL *UVPRINTMSG(001209,BOT) END CALL *UVPRINTMSG(001210,"") END ELSE IF ED.CMD.STRING.SUSPENDED THEN CALL *UVPRINTMSG(001242,"") CALL *UVPRINTMSG(001210,"") END END GOSUB INPUT.LINE GET.CMD.1: COMMAND.SUCCESSFUL = TRUE STACK.MODE = FALSE CMD = INPUT.LINE ORIGINAL.CMD = CMD IF CMD = '.?' THEN CMD = 'HELP .' IF CMD # '?' AND CMD [LEN(CMD), 1] = '?' THEN CMD = CMD [1, LEN(CMD) - 1] ; GOSUB STASH.IT ; GOTO GET.CMD END CMD = REPLACE(CMD, 1, 1, 1, TRIMF(CMD <1, 1, 1>)) GOSUB PUT.ON.STACK GET.CMD.2: IF LEN(CMD) = 0 THEN IF BOT = 0 THEN GOTO GET.CMD ; * BOT = 0 MEANS RECORD IS NULL LNUM = IF LNUM < BOT THEN LNUM + 1 ELSE 0 GOTO END.NOCHANGE END NULL.CTR = 0 IF NUM(CMD) THEN GOTO SET.LNUM IF CMD = "-" OR CMD = "+" THEN GOTO END.NOCHANGE *---- Convert lower case to upper case for command processing. UPCMD = UPCASE(CMD) ; *---- Look for 'OOPS' command to restore; else, save record if necessary. IF UPCMD = 'OOPS' THEN IF ED.CMD.STRING.ACTIVE THEN J = 0 ; * KILL ACTIVE CMD STRING ED.CMD.STRING.ACTIVE = FALSE ED.CMD.STRING.SUSPENDED = FALSE IF CHANGE.DURING.CMD.STRING THEN GOSUB OOPS.AFTER.CHANGE.CMD CHANGE.DURING.CMD.STRING = FALSE END END IF LEN(SAVED.CMD) = 0 THEN CALL *UVPRINTMSG(001249,"") GOTO GET.CMD END J = 0 ; * KILL ANY ACTIVE EDIT CMD STRING ED.CMD.STRING.ACTIVE = FALSE GOSUB OOPS.RESTORE ; * SET UP FOR OOPS <==== GOTO END.CMD END ELSE IF NOT(ED.CMD.STRING.ACTIVE) THEN GOSUB OOPS.BEFORE.EACH.CMD ; * SET UP FOR OOPS <==== END CMDN = 1 *---- Look for 1-letter commands. IF LEN(UPCMD) = 1 THEN CMDX = INDEX('ABCDFILMNPQRTX<>^?', UPCMD, 1) ON CMDX + 1 GOTO CMD.ERR, A, B, C, D, F, I, L, M, N, P, QUIT, R, T, X, MFROM, MTHRU, UP.ARROW.TOGGLE, QUESTION.MARK END *---- Look for a letter and a space, followed by any string. IF UPCMD MATCHES '1A" "0X' THEN ANY = CMD [3, 9999] CMDX = INDEX('ABCFILMR', UPCMD [1, 1], 1) ON CMDX + 1 GOTO CMD.ERR, A.ANY, B.ANY, C.ANY, F.ANY, I.ANY, L.ANY, M.ANY, R.ANY END *---- Look for 'Fnnn' --- a column-restricted FIND. IF UPCMD [1, 1] = "F" THEN IF CMD [2, 9999] MATCHES '0N" "0X' THEN ST.COLUMN = FIELD(CMD [2, 9999], " ", 1) ANY = CMD [LEN(ST.COLUMN) + 3, 9999] GO TO F.COL END END *---- Look for a letter followed by a number. IF UPCMD MATCHES '1A0N' THEN CMDN = CMD [2, 99] IF CMDN > BOT THEN CMDN = BOT CMDX = INDEX('DGLP', UPCMD [1, 1], 1) ON CMDX + 1 GOTO CMD.ERR, D, G.N, P.N, P.N END *---- Look for command words. UPCMD1 = UPCMD [1, 1] ; UPCMD2 = UPCMD [1, 2] UPCMD3 = UPCMD [1, 3] ; UPCMD4 = UPCMD [1, 4] UPCMD5 = UPCMD [1, 5] ; UPCMD6 = UPCMD [1, 6] UPCMD8 = UPCMD [1, 8] IF UPCMD = 'ABORT' THEN GOTO ABORT: IF UPCMD = 'BLOCK' THEN GOTO BLOCK.VERIFY: IF UPCMD3 = 'CAT' THEN GOTO CAT.ANY: IF UPCMD = 'COL' THEN GOTO COL: IF UPCMD = 'COPY' THEN GOTO COPY: IF UPCMD = 'DELETE' THEN GOTO DELETE: IF UPCMD2 = 'DE' THEN GOTO DE.N: IF UPCMD = 'DROP' THEN GOTO DROP: IF UPCMD3 = 'DUP' THEN GOTO DUP.ANY: IF UPCMD = 'EX' THEN GOTO QUIT: IF UPCMD = 'FD' THEN GOTO DELETE: IF UPCMD = 'FI' THEN GOTO FILE.ANY: IF UPCMD = 'FILE' THEN GOTO FILE.ANY: * GTAR 10785 * Fake editor into thich user typed 'FILE file record' * IF UPCMD3 = 'FI ' THEN CMD = 'FILE ':CMD[4,9999] UPCMD = UPCASE(CMD) UPCMD3 = UPCMD[1,3] UPCMD4 = UPCMD[1,4] UPCMD5 = UPCMD[1,5] UPCMD6 = UPCMD[1,6] UPCMD7 = UPCMD[1,7] UPCMD8 = UPCMD[1,8] GOTO FILE.ANY END IF UPCMD5 = 'FILE ' THEN GOTO FILE.ANY: IF UPCMD = 'FORMAT' THEN FORMAT.TYPE = TRUE ; GOTO FORMAT: IF UPCMD = 'FANCY.FORMAT' THEN FORMAT.TYPE = FALSE ; GOTO FORMAT: IF UPCMD = 'G<' THEN GOTO G.BEGIN.BLOCK: IF UPCMD = 'G>' THEN GOTO G.END.BLOCK: IF UPCMD4 = 'HELP' THEN GOTO HELP.ANY: IF UPCMD2 = 'IB' THEN GOTO I.BEFORE IF UPCMD5 = 'LOAD ' THEN GOTO LOAD.ANY: IF UPCMD = 'MOVE' THEN GOTO MOVE: IF UPCMD = 'PB' THEN GOTO PRINT.BLOCK: IF UPCMD2 = 'PL' THEN GOTO PL.CMD: IF UPCMD2 = 'PO' THEN GOTO PO.N: IF UPCMD2 = 'PP' THEN GOTO PP.CMD: IF UPCMD = 'QUIT' THEN GOTO QUIT: IF UPCMD = 'RELEASE' THEN GOTO RELEASE: IF UPCMD = 'SAVE' THEN GOTO SAVE.ANY: IF UPCMD5 = 'SAVE ' THEN GOTO SAVE.ANY: IF UPCMD3 = 'SEQ' THEN GOTO SEQ.ANY: IF UPCMD = 'SIZE' THEN COMMAND.SUCCESSFUL = FALSE ; DISPLAY.CURRENT.LINE = FALSE ; GOTO SIZE: IF UPCMD = 'SPOOLHELP' THEN GOTO SPOOL.HELP: IF UPCMD5 = 'SPOOL' THEN GOTO SPOOL.N: IF UPCMD5 = 'STAMP' THEN GOTO STAMP: IF UPCMD6 = 'UNLOAD' THEN GOTO UNLOAD.ANY: IF UPCMD4 = 'XEQ ' THEN GOTO XEQ.ANY: IF UPCMD3 = 'PE ' THEN GOTO XEQ.ANY: IF UPCMD8 = 'PERFORM ' THEN GOTO XEQ.ANY: IF UPCMD = "<>" THEN GOTO MFROM: IF UPCMD = UP.ARROW.UNIC.UP THEN GOTO UP.ARROW.TOGGLE ;* NLS Unicode ^x cmd *---- Look for EDITOR STACK and STRING commands. IF UPCMD1 = '.' OR UPCMD4 = 'LOOP' OR UPCMD5 = 'PAUSE' THEN GOTO STACK.PROCESSOR: IF UPCMD1 = 'C' OR UPCMD1 = 'R' THEN GOTO C.ANY: ; * CHANGE command. CMD.ERR: UNLOAD.FLAG = FALSE ; * RESET FLAGS ON LOAD/UNLOAD ERROR CONDITIONS L.SELECT.FLAG = FALSE * IF UPCMD4 = 'LOOP' THEN ED.CMD.STRING.ACTIVE = FALSE * ELSE IF NOT(ED.CMD.STRING.SUSPENDED) AND ED.CMD.STRING.ACTIVE THEN CALL *UVPRINTMSG(001272,J:@FM:ED.CMD.STRING (J)) CALL *UVPRINTMSG(001273,"") ERROR.FORMAT = TRUE GOSUB PRINT.CMD.STRING MSG.TEXT = UVREADMSG(001274,"") IF NOT(@SYS.BELL) THEN MSG.TEXT = CONVERT(CHAR(07),"",MSG.TEXT) END PRINT MSG.TEXT<1> PRINT CALL *UVPRINTMSG(001275,"") CALL *UVPRINTMSG(001276,"") INPUT COMMAND ; ANS = COMMAND ; ANS = UPCASE(ANS) IF ANS # 'Q' THEN ED.CMD.STRING (J) = COMMAND J -= 1 END ELSE ED.CMD.STRING.ACTIVE = FALSE GOTO GET.CMD END * END IF NOT(STACK.MODE) THEN CALL *UVPRINTMSG(001245,"") GOTO GET.CMD NUMBER.ERR: PRINT 'A non-numeric parameter was encountered where a number was expected.' GOTO CMD.ERR END.NOCHANGE: ; * End of command that did not change record. CHANGE.FLAG = FALSE GOTO END.CMD END.CHANGE: ; * End of command that changed record. CHANGE.FLAG = TRUE END.CMD: ; * Set up to save record prior to change for 'OOPS'. IF CHANGE.FLAG OR CHANGE.DURING.CMD.STRING THEN IF NOT(ED.CMD.STRING.ACTIVE) THEN GOSUB OOPS.AFTER.CHANGE.CMD ; * SET UP FOR OOPS <==== CHANGE.DURING.CMD.STRING = FALSE END ELSE CHANGE.DURING.CMD.STRING = TRUE END GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD.0 DONE.WITH.RECORD: IF RECORD.NAME.LOCKED THEN RELEASE EDIT.FILE, RECORD.NAME ; * RELEASE RECORD LOCK RECORD.NAME.LOCKED = FALSE END IF ONLY.ONE.RECORD.FLAG THEN GOTO STOP ELSE GOTO GET.NEXT.RECORD ! * Command processing routines. ! *---- Conventions used in command processors: * * 1. Entered from a 'GOTO' in the routine 'GET.CMD'. * * 2. Exit with a 'GOTO' to one of the following labels: * A. 'GET.CMD', to get the next command. * B. 'END.CMD', to print the current line before going to 'GET.CMD'. * C. 'END.CHANGE' to set 'CHANGE.FLAG' to 'TRUE' after changing * the record; control proceeds through 'END.CMD', to print * the current line before going to 'GET.CMD'. * D. 'CMD.ERR', to print standard error message. * * 3. Use these standard 'GOSUB' routines: * A. 'GET.LINE', to get the line numbered 'LNUM' into 'LINE'. * B. 'PRINT.LINE', to print the string in 'LINE'. * C. 'INPUT.LINE', to input a line of text from the CRT. * * 4. Each processor should maintain these variables as necessary: * A. 'MEMORY' matrix contains 'LPC' lines of record in each cell. * B. 'LNUM' is the line number being displayed/processed. * C. 'LINE' contains the current line from record at line 'LNUM'. * D. 'LPC' matrix defines number of lines per cell in 'MEMORY'. * E. 'CELL' is the cell number in 'MEMORY' containing line 'LNUM'. * F. 'CELL.FIRST.LINE' is the real line number of the first * line of the current cell. * G. 'CHANGE.FLAG' must be set to 'TRUE' if record is changed. * H. 'BOT' should be set to the bottom line number if * the number of lines is changed. A.ANY: ; * APPEND command. APPEND = ANY A: IF LNUM < 1 THEN CALL *UVPRINTMSG(970007,LNUM) GOTO CMD.ERR END LINE := APPEND MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE) GOTO END.CHANGE ABORT: ; * Toggle command ABORT flag. ABORT.FLAG = NOT(ABORT.FLAG) IF ABORT.FLAG THEN CALL *UVPRINTMSG(001267,ENABLED) END ELSE CALL *UVPRINTMSG(001267,DISABLED) END GOTO END.NOCHANGE BLOCK.VERIFY: ; * Toggle command BLOCK.VERIFY flag. BLOCK.VERIFY.FLAG = NOT(BLOCK.VERIFY.FLAG) IF BLOCK.VERIFY.FLAG THEN CALL *UVPRINTMSG(001268,ENABLED) END ELSE CALL *UVPRINTMSG(001268,DISABLED) END GOTO END.NOCHANGE B.ANY: ; * Break a line into two lines. IF LNUM < 1 THEN CALL *UVPRINTMSG(970008,LNUM) GOTO CMD.ERR END X = INDEX(LINE, ANY, 1) IF X = 0 THEN GOTO CMD.ERR X += LEN(ANY) MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE [1, X - 1]:@FM:LINE [X, 999999]) LPC (CELL) += 1 ; BOT += 1 BLOCK.TRACK.LNUM = LNUM + 1 ; BLOCK.TRACK.CHANGE = 1 ; GOSUB BLOCK.TRACK GOTO END.CHANGE B: ; * Go to BOTTOM of record. LNUM = BOT ; GOTO END.NOCHANGE CAT.ANY: ; * Catenate two lines together. IF LNUM < 1 OR LNUM = BOT THEN CALL *UVPRINTMSG(970006,LNUM) GOTO CMD.ERR END LINEX = LINE LNUM += 1 GOSUB GET.LINE ; * GET NEXT LINE LINEY = LINE NUM.OF.LINES.TO.DELETE = 1 GOSUB DELETE.MEMORY MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINEX:CMD [5, 99]:LINEY) BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = -1 ; GOSUB BLOCK.TRACK GOTO END.CHANGE COL: ; * Column display command. CALL *UVPRINTMSG(001212,"") CALL *UVPRINTMSG(001213,"") GOTO END.NOCHANGE C: ; * Change command. CMD = OLD.CHANGE.CMD IF LEN(CMD) = 0 THEN PRINT 'No previous CHANGE command in effect ; must have parameters.' GOTO CMD.ERR END C.ANY: ; * Look for first non-space, non-alphanumeric character as delimiter. X = 2 LOOP DELIM = CMD [X, 1] WHILE DELIM = ' ' DO X += 1 REPEAT IF NOT(INDEX(DELIM.STRING, DELIM, 1)) THEN PRINT 'Valid delimiters are ':DELIM.STRING GOTO CMD.ERR END IF COUNT(CMD, DELIM) > 3 THEN PRINT 'Too many delimiters (3 max.).' ; GOTO CMD.ERR END OLD.CHANGE.CMD = CMD FROM.FIELD = FIELD(CMD, DELIM, 2) LEN.FROM.FIELD = LEN(FROM.FIELD) TO.FIELD = FIELD(CMD, DELIM, 3) IF COL2() = 0 THEN PRINT 'Missing required TO field (for "CHANGE/FROM/TO").' GOTO CMD.ERR END GLOBAL = FIELD(CMD, DELIM, 4) ; GLOBAL = UPCASE(GLOBAL) ; GLOBAL.FLAG = FALSE IF GLOBAL [1, 1] = 'G' THEN GLOBAL = GLOBAL [2, 99] ; GLOBAL.FLAG = TRUE IF GLOBAL [LEN(GLOBAL), 1] = 'G' THEN GLOBAL = GLOBAL [1, LEN(GLOBAL) - 1] ; GLOBAL.FLAG = TRUE BLOCK.LOGIC = FALSE IF GLOBAL = 'B' THEN IF MFROM # 0 AND MTHRU # 0 THEN LNUM = MFROM ; * IF BLOCK SET, MOVE LNUM TO FRONT OF BLOCK GOSUB BLOCK.CHECK BLOCK.LOGIC = TRUE END N = IF NUM(GLOBAL) AND GLOBAL => 1 THEN GLOBAL ELSE 1 IF LNUM <= 0 THEN LNUM = 1 IF BLOCK.LOGIC THEN LNUM = MFROM ; LEND = MTHRU ; N = LEND - LNUM + 1 ELSE LEND = LNUM + N - 1 ; IF LEND > BOT THEN LEND = BOT X.CHANGE.FLAG = FALSE ; * RESET LOCAL CHANGE FLAG FOR LNUM = LNUM TO LEND GOSUB GET.LINE IF LEN(FROM.FIELD) = 0 THEN LINE = TO.FIELD:LINE ; GOTO C.REPLACE.LINE X = INDEX(LINE, FROM.FIELD, 1) IF X = 0 THEN GOTO C.NEXT.LINE NEW.LINE = '' LOOP NEW.LINE := LINE [1, X - 1] :TO.FIELD LINE = LINE [X + LEN.FROM.FIELD, 999999] X = INDEX(LINE, FROM.FIELD, 1) WHILE GLOBAL.FLAG AND X DO REPEAT LINE = NEW.LINE:LINE C.REPLACE.LINE: MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE) GOSUB PRINT.LINE CHANGE.FLAG = TRUE X.CHANGE.FLAG = TRUE ; * SET LOCAL CHANGE FLAG C.NEXT.LINE: GOSUB ABORT.CHECK IF ABORT = 'Q' THEN CALL *UVPRINTMSG(001228,"") GOTO C.ABORT END NEXT LNUM C.ABORT: IF LNUM = 0 THEN CALL *UVPRINTMSG(001190,"") ELSE IF N > 1 AND LNUM # BOT THEN PRINT 'At line ':LNUM CHANGE.FLAG = X.CHANGE.FLAG ; * SET UP FLAG FOR OOPS SINCE GET.LINE ; * COULD HAVE RESET IT AFTER LAST LINE ACTUALLY CHANGED GOTO GET.CMD COPY: ; * Copy a BLOCK (i.e., duplicate the lines). MOVE.FLAG = FALSE ; GOTO MOVE.COPY DELETE: ; * Delete the entire record from the file. IF (NOT(SYSTEM(62)) AND (EDITING.VOC.FPTR)) THEN CALL *UVPRINTMSG(020553,"") GOTO GET.CMD END CALL *UVPRINTMSG(001214,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS # 'Y' THEN CALL *UVPRINTMSG(001215,"") ; GOTO GET.CMD DELETE EDIT.FILE, RECORD.NAME ELSE * DELETEU EDIT.FILE, RECORD.NAME ON ERROR PRINT @SYS.BELL:'Failed to delete "':DISPLAY.RECORD.NAME:'" from file "':DICT:FILE.NAME:'". STATUS = ':STATUS() GOTO GET.CMD END CALL *UVPRINTMSG(001246,DISPLAY.RECORD.NAME) CALL *UVPRINTMSG(001286,DICT.TEXT:FILE.NAME) GOTO DONE.WITH.RECORD DE.N: ; * Delete a line or lines. CMDN = CMD [3, 99] IF NOT(NUM(CMDN)) THEN PRINT 'Command requires number of lines to DELETE.' GOTO CMD.ERR END IF CMDN <= 0 THEN CMDN = 1 D: IF LNUM <= 0 THEN LNUM = 1 IF CMDN > (BOT - LNUM + 1) THEN CMDN = BOT - LNUM + 1 NUM.OF.LINES.TO.DELETE = CMDN GOSUB DELETE.MEMORY BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = -CMDN ; GOSUB BLOCK.TRACK GOTO GET.CMD DROP: ; * Delete a BLOCK of lines. IF MFROM # 0 AND MTHRU # 0 THEN LNUM = MFROM ; * IF BLOCK SET, MOVE LNUM TO FRONT OF BLOCK GOSUB BLOCK.CHECK ; GOSUB GET.LINE NUM.OF.LINES.TO.DELETE = MTHRU - MFROM + 1 GOSUB DELETE.MEMORY MTHRU = 0 ; * KILL BLOCK POINTERS MFROM = 0 GOTO END.CMD DUP.ANY: ; * Duplicate the current line. IF LNUM < 1 THEN CALL *UVPRINTMSG(970009,LNUM) GOTO CMD.ERR END CMDN = CMD [4, 99] IF NOT(NUM(CMDN)) THEN PRINT 'Command requires number of lines to DUPLICATE.' GOTO CMD.ERR END IF CMDN <= 0 THEN CMDN = 1 IF CMDN = 1 THEN * LNUM += 1 * MEMORY (CELL) = INSERT(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE) * The following code replaces the above 2 lines, which fail when * inserting data before the last field if the last field is null. X = LNUM - CELL.FIRST.LINE IF X < 0 THEN IF LEN(MEMORY (CELL)) = 0 THEN MEMORY (CELL) = LINE ELSE MEMORY (CELL) = LINE:@FM:MEMORY (CELL) END ELSE Y = FIELD(MEMORY (CELL), @FM, 1, X + 1):@FM:LINE X = MEMORY (CELL) [COL2(), 99999999] IF LEN(X) = 0 THEN MEMORY (CELL) = Y ELSE MEMORY (CELL) = Y:X END LNUM += 1 *---- End of special code. LPC (CELL) += 1 ; BOT += 1 ; CHANGE.FLAG = TRUE END ELSE NEW.MEMORY.LINE = LINE FOR X = 1 TO CMDN ; * BUILD A BLOCK OF NEW LINES GOSUB APPEND.NEW.MEMORY IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84 NEXT X GOSUB INSERT.MEMORY ; * INSERT THE NEW BLOCK IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84 GOSUB CLEAR.NEW.MEMORY LNUM += 1 END BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = CMDN ; GOSUB BLOCK.TRACK GOTO END.CMD FILE.ANY: ; * File the record; finished with it. GOSUB FILE.IT IF WRITEERROR THEN GOTO END.NOCHANGE ; *026 GOTO DONE.WITH.RECORD F.COL: ; * A column-restricted FIND. FIND.STRING = ANY ; GO TO F F.ANY: ; * Find a line starting with string 'any'. FIND.STRING = ANY ; ST.COLUMN = 1 F: FLEN = LEN(FIND.STRING) ; SEARCH.X = 1 ; GOTO L.AGAIN FORMAT: ; * Format INFO/BASIC program. DISPLAY.CURRENT.LINE = FALSE COMMAND.SUCCESSFUL = FALSE IF BOT = 0 THEN GOTO END.NOCHANGE ; * EXIT IF NO LINES TO FORMAT * * Move the current lines of the program into the PROGRAM array ready * for formatting, 1 line per field. * PROGRAM = '' FOR LNUM = 1 TO BOT GOSUB GET.LINE ; PROGRAM<-1> = LINE NEXT LNUM BOTX = BOT ; * SAVE BOT LNUM = 1 GOSUB GET.LINE NUM.OF.LINES.TO.DELETE = BOT GOSUB DELETE.MEMORY ; * CLEAR ALL OF MEMORY, RETURN DMR SPACE BOT = BOTX ; * RESTORE BOT WHICH WAS RESET BY DELETE.MEMORY * * Now do the actual format of this record. * Depending on the value of FORMAT.TYPE do a FORMAT or FANCY.FORMAT * IF FORMAT.TYPE THEN MAT FORMAT.OPTIONS = '' ; * Initialize the default FORMAT FORMAT.MARGIN = 6 ; * options. FORMAT.INDENT = 3 ; * FORMAT.CASE = 'MCU' ; * Treat all keywords in upper case FORMAT.LABELS = 0 ; * Do not place labels on a separate line FORMAT.COMMENT = 0 ; * Do not format comments FORMAT.BRIEF = 0 ; * Indicate progess with *'s FORMAT.SURROUND = 0 ; * Do not surround special characters FORMAT.ALIGN = 0 ; * Do not align within statements END ELSE MAT FORMAT.OPTIONS = '' ; * Initialize the default FORMAT FORMAT.MARGIN = 6 ; * options. FORMAT.INDENT = 3 ; * FORMAT.CASE = 'MCU' ; * Treat all keywords in upper case FORMAT.LABELS = 1 ; * Do not place labels on a separate line FORMAT.COMMENT = 1 ; * Do not format comments FORMAT.BRIEF = 0 ; * Indicate progess with *'s FORMAT.SURROUND = 1 ; * Do not surround special characters FORMAT.ALIGN = 0 ; * Do not align within statements END CALL @FORMAT.BASIC(PROGRAM, BOT, MAT FORMAT.OPTIONS) * X = INT((BOT - 1) / LINES.PER.CELL) ; * DETERMINE NUMBER OF FULL CELLS LNUM = 0 PROGRAM = PROGRAM ; * Reset remove pointer FOR XX = 1 TO X LPC (XX) = LINES.PER.CELL LNUM += 1 PROGRAM.LINE = '' LOOP REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK) REPEAT IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT MEMORY (XX) = PROGRAM.LINE FOR XXX = 2 TO LINES.PER.CELL ; * MOVE LINES INTO CELL LNUM += 1 PROGRAM.LINE = '' LOOP REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK) REPEAT IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT MEMORY (XX) := @FM:PROGRAM.LINE NEXT XXX NEXT XX XX = X + 1 ; * CELL NUMBER OF LAST CELL X = MOD(BOT - 1, LINES.PER.CELL) + 1 ; * DETERMINE NUM OF LINES IN LAST CELL IF X THEN LPC (XX) = X LNUM += 1 PROGRAM.LINE = '' LOOP REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK) REPEAT IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT MEMORY (XX) = PROGRAM.LINE FOR XXX = 2 TO X ; * MOVE LINES INTO LAST CELL LNUM += 1 PROGRAM.LINE = '' LOOP REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK) REPEAT IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR PROGRAM.LINE := LINE.SEGMENT MEMORY (XX) := @FM:PROGRAM.LINE NEXT XXX END LAST.CELL = XX CELL.FIRST.LINE = 1 ; CELL = 1 ; LNUM = 0 PROGRAM = '' ; * RETURN DMR STRING SPACE GOTO END.CHANGE G.N: ; * Goto a line (by number). LNUM = CMDN ; GOTO CK.NUM G.BEGIN.BLOCK: ; * 'G<': goto beginning of a BLOCK. IF MFROM = 0 THEN GOSUB BLOCK.CHECK LNUM = MFROM ; GOTO END.NOCHANGE G.END.BLOCK: ; * 'G>': goto end of a BLOCK. IF MTHRU = 0 THEN GOSUB BLOCK.CHECK LNUM = MTHRU ; GOTO END.NOCHANGE HELP.ANY: ; * Display HELP information. GOSUB READ.HELP.RECORD ANY = UPCMD [5, 99] IF LEN(ANY) = 0 THEN CALL *UVPRINTMSG(001248,"") GOSUB INPUT.LINE ; ANY = INPUT.LINE END *---- Upcase the keywords or letter. ANY = TRIM(ANY) ; ANY = UPCASE(ANY) ; XX = 0 ; PRINT HELP.COUNT = COUNT(HELP.RECORD, @FM) + 1 FOR X = 1 TO HELP.COUNT LINEX = HELP.RECORD IF (IF LEN(ANY) # 1 THEN INDEX(LINEX, ANY, 1) ELSE LINEX [1, 1] = ANY) THEN LOOP REMOVE LINEXX FROM LINEX SETTING DELIM PRINT LINEXX ; XX += 1 IF XX => (@CRTHIGH - 2) THEN CALL *UVPRINTMSG(001142,"") INPUT Q, 1 ; Q = UPCASE(Q) IF Q = 'Q' THEN GOTO HELP.END XX = 0 ; PRINT END WHILE DELIM REPEAT END NEXT X HELP.END: LINEX = '' ; PRINT ; GOTO END.NOCHANGE I.ANY: ; * Insert a new line of text. IF ANY = ' ' THEN ANY = ' ' ; * ANY = '' * LNUM += 1 * MEMORY (CELL) = INSERT(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, ANY) * The following code replaces the above 2 lines, which fail when * inserting data before the last field if the last field is null. X = LNUM - CELL.FIRST.LINE IF X < 0 THEN IF LEN(MEMORY (CELL)) = 0 THEN MEMORY (CELL) = ANY ELSE MEMORY (CELL) = ANY:@FM:MEMORY (CELL) END ELSE Y = FIELD(MEMORY (CELL), @FM, 1, X + 1):@FM:ANY X = MEMORY (CELL) [COL2(), 99999999] IF LEN(X) = 0 THEN MEMORY (CELL) = Y ELSE MEMORY (CELL) = Y:X END LNUM += 1 *---- End of special code. LPC (CELL) += 1 IF BOT = 0 THEN LAST.CELL = 1 BOT += 1 BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = 1 ; GOSUB BLOCK.TRACK CHANGE.FLAG = TRUE GOTO END.CMD I.BEFORE: ; * Insert before current line. ANY = CMD [4, 9999] LNUM -= 1 ; * Back up one line. IF LNUM < 0 THEN LNUM = 0 IF ANY THEN GOTO I.ANY ELSE GOTO I I: ; * Put editor into INPUT mode. LNUM.INPUT = LNUM LNUM += 1 PRINT STR('0', 4 - LEN(LNUM)):LNUM:'=': LOOP INPUT.MODE = TRUE GOSUB INPUT.LINE IF LEN(INPUT.LINE) = 0 THEN LNUM = LNUM.INPUT GOSUB INSERT.MEMORY IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84 LNUM = LNUM.INPUT + NEW.BOT BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = NEW.BOT ; GOSUB BLOCK.TRACK GOSUB CLEAR.NEW.MEMORY GOTO GET.CMD END LNUM += 1 ; * PRINT NEXT LINE NUM ASAP PRINT STR('0', 4 - LEN(LNUM)):LNUM:'=': IF INPUT.LINE = ' ' THEN INPUT.LINE = '' ; * INPUT A NULL LINE NEW.MEMORY.LINE = INPUT.LINE GOSUB APPEND.NEW.MEMORY IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84 REPEAT L.ANY: ; * Locate a line containing the string 'any'. LOCATE.STRING = ANY L: SEARCH.X = 2 L.AGAIN: IF LNUM => BOT THEN LNUM = 0 L.NEXT: COMMAND.SUCCESSFUL = FALSE GOSUB ABORT.CHECK IF ABORT = 'Q' THEN CALL *UVPRINTMSG(001228,"") GOTO END.NOCHANGE END LNUM += 1 IF LNUM > BOT THEN LNUM = BOT ; GOTO END.NOCHANGE GOSUB GET.LINE ON SEARCH.X GOTO FINDX, LOCATEX, MATCHX FINDX: IF LINE [ST.COLUMN, FLEN] = FIND.STRING THEN COMMAND.SUCCESSFUL = TRUE GOTO END.NOCHANGE END ELSE GOTO L.NEXT END LOCATEX: IF INDEX(LINE, LOCATE.STRING, 1) THEN COMMAND.SUCCESSFUL = TRUE GOTO END.NOCHANGE END ELSE GOTO L.NEXT END MATCHX: IF LEN(LINE) => 188 THEN PRINT 'Line ':LNUM:' is longer than 188 characters, MATCH NOT DONE, line skipped.' GOTO L.NEXT END IF LINE MATCHES MATCH.STRING THEN COMMAND.SUCCESSFUL = TRUE GOTO END.NOCHANGE END ELSE GOTO L.NEXT END LOAD.ANY: ; * Load lines from another record. IF UPCMD1 = '.' THEN SENT = TRIM(CMD [4, 99]) ELSE SENT = TRIM(CMD [6, 99]) IF COUNT(SENT, ' ') > 2 THEN PRINT 'Too many parameters. Expected (at most) a file name and record name.' GOTO CMD.ERR END IF COUNT(SENT, ' ') THEN PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE ; SINGLE.FILE.ONLY = TRUE LOAD.FILE.NAME = '' ; LOAD.DICT = '' ; LOAD.DICT.TEXT = '' CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, LOAD.DICT, LOAD.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY) IF LOAD.DICT = '' ELSE LOAD.DICT.TEXT = LOAD.DICT:' ' IF LEN(LOAD.FILE.NAME) = 0 OR LOAD.FILE.NAME # LOAD.FILE.NAME <1> THEN PRINT 'Invalid file name (not found in VOC, or not FILE DEFINITION record).' GOTO CMD.ERR END LOAD.REC.NAME = SENT * * Open file to load data from. Carry on if partially successful open * of distributed file. * OPENCHECK LOAD.DICT, LOAD.FILE.NAME TO LOAD.FILE ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,LOAD.FILE.NAME THEN IF LOAD.DICT = "" THEN PathName = FileRec<2> END ELSE PathName = FileRec<3> END RELEASE DEVSYS.VOC.FILE,LOAD.FILE.NAME END ELSE PathName = "" END IF LOAD.DICT = "" THEN FileName = LOAD.FILE.NAME END ELSE FileName = "DICT,":LOAD.FILE.NAME END CALL @OpenError(ErrorCode,FileName,PathName) GOTO CMD.ERR END END ELSE LOAD.FILE.NAME = FILE.NAME ; LOAD.DICT = DICT ; LOAD.FILE = EDIT.FILE LOAD.DICT.TEXT = DICT.TEXT IF UPCMD1 = '.' THEN IF L.SELECT.FLAG AND LEN(SENT) # 0 THEN OPENCHECK '', SENT TO LOAD.FILE ELSE ErrorCode = STATUS() READL FileRec from DEVSYS.VOC.FILE,SENT THEN PathName = FileRec<2> RELEASE DEVSYS.VOC.FILE,SENT END ELSE PathName = "" END FileName = SENT CALL @OpenError(ErrorCode,FileName,PathName) GOTO CMD.ERR END LOAD.FILE.NAME = SENT ; GOTO SL.3 END LOAD.FILE.NAME = '&ED&' LOAD.DICT = '' ; LOAD.DICT.TEXT = '' OPENCHECK LOAD.DICT,LOAD.FILE.NAME TO LOAD.FILE ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,LOAD.FILE.NAME THEN PathName = FileRec<2> RELEASE DEVSYS.VOC.FILE,LOAD.FILE.NAME END ELSE PathName = "" END FileName = LOAD.FILE.NAME CALL @OpenError(ErrorCode,FileName,PathName) GOTO CMD.ERR END END LOAD.REC.NAME = SENT END IF L.SELECT.FLAG THEN GOTO SL.3 IF LEN(SENT) = 0 THEN GOTO CMD.ERR IF UPCMD1 = '.' THEN GOTO READ.1 IF ED.CMD.STRING.ACTIVE THEN PRINT STARS:' Loading "':LOAD.DICT.TEXT:LOAD.FILE.NAME:'" "':LOAD.REC.NAME:'"':'.' END CALL *UVPRINTMSG(001193,"") GOSUB INPUT.LINE ; START = INPUT.LINE IF NOT(NUM(START)) THEN PRINT 'Starting line/field must be numeric ; you entered "':START:'".' GOTO CMD.ERR END IF START < 1 THEN CALL *UVPRINTMSG(001231,"") GOTO CMD.ERR END CALL *UVPRINTMSG(001195,"") GOSUB INPUT.LINE ; ENDING = INPUT.LINE IF NOT(NUM(ENDING)) THEN PRINT 'Ending line/field must be numeric ; you entered "':ENDING:'".' GOTO CMD.ERR END IF ENDING < START THEN CALL *UVPRINTMSG(001233,ENDING:@FM:START) GOTO CMD.ERR END READ.1: READ BLOCK FROM LOAD.FILE, LOAD.REC.NAME ELSE * Record %s does not exist IF STACK.MODE THEN CALL *UVPRINTMSG(970004,LOAD.REC.NAME:@FM:LOAD.FILE.NAME) PRINT GOSUB DISPLAY.CURRENT.LINE END ELSE CALL *UVPRINTMSG(001196,LOAD.REC.NAME) END GOTO CMD.ERR END IF UPCMD1 = '.' THEN GOTO GET.CMD.FROM.BLOCK IF ENDING - START + 1 > 32767 THEN ; *015 FIELDS = 32767 ; *015 BLOCK1 = FIELD(BLOCK, @FM, START, FIELDS) ; *015 LOOP ; *015 START += 32767 ; *015 IF ENDING - START + 1 <= 32767 THEN ; *015 FIELDS = ENDING - START + 1 ; *015 END ; *015 WHILE FIELDS > 0 DO ; *015 TEMPBLOCK = FIELD(BLOCK, @FM, START, FIELDS) ; *015 IF TEMPBLOCK # '' THEN ; *015 BLOCK1 = BLOCK1:@FM:TEMPBLOCK ; *015 END ELSE ; *015 START = ENDING + 1 ; *015 END ; *015 REPEAT ; *015 BLOCK = BLOCK1 ; *015 END ELSE ; *015 BLOCK = FIELD(BLOCK, @FM, START, ENDING - START + 1) END ; *015 LINES.READ = IF LEN(BLOCK) = 0 THEN 0 ELSE COUNT(BLOCK, @FM) + 1 IF LINES.READ = 0 THEN GOTO LOAD.3 X = INT((LINES.READ - 1) / LINES.PER.CELL) ; * DETERMINE NUM OF CELLS REQUIRED IF X + 1 > NEW.MEMORY.DIM THEN NEW.MEMORY.DIM = X + 10 DIM NEW.MEMORY (NEW.MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; GOTO END.CMD ; * SJE 23 Apr 84 DIM NEW.LPC (NEW.MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; GOTO END.CMD ; * SJE 23 Apr 84 END *---- The following code sets up * to make a BLOCK of each element of the array. The size of the * BLOCK is defined by LINES.PER.CELL. *** MATBLOCK NEW.MEMORY FROM BLOCK, @FM, LINES.PER.CELL CALL @MATBLOCK(MAT NEW.MEMORY,BLOCK,@FM,LINES.PER.CELL) FOR XX = 1 TO X NEW.LPC (XX) = LINES.PER.CELL NEXT XX NEW.LAST.CELL = X + 1 NEW.LPC (NEW.LAST.CELL) = MOD(LINES.READ - 1, LINES.PER.CELL) + 1 NEW.BOT = LINES.READ GOSUB INSERT.MEMORY IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84 GOSUB CLEAR.NEW.MEMORY LNUM += 1 BLOCK = '' ; * RETURN STRING SPACE LOAD.3: * %i lines/fields loaded. CALL *UVPRINTMSG(001280,LINES.READ) BLOCK.TRACK.LNUM = LNUM + LINES.READ - 1 BLOCK.TRACK.CHANGE = LINES.READ ; GOSUB BLOCK.TRACK GOTO END.CMD M.ANY: ; * Locate a line that matches pattern 'any'. MATCH.STRING = ANY M: SEARCH.X = 3 ; GOTO L.AGAIN MOVE: ; * Move a BLOCK of lines (deleting source lines). MOVE.FLAG = TRUE MOVE.COPY: GOSUB BLOCK.CHECK INSERT.LNUM = LNUM ; * SAVE LNUM FOR LNUM = MFROM TO MTHRU ; * COPY THE DESIRED LINES INTO NEW MEMORY GOSUB GET.LINE NEW.MEMORY.LINE = LINE GOSUB APPEND.NEW.MEMORY IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84 NEXT LNUM IF MOVE.FLAG THEN LNUM = MFROM GOSUB GET.LINE NUM.OF.LINES.TO.DELETE = MTHRU - MFROM + 1 GOSUB DELETE.MEMORY ; * DELETE THE BLOCK IF CMD IS A MOVE LNUM = INSERT.LNUM ; * RESTORE LNUM IF LNUM => MTHRU THEN LNUM -= MTHRU - MFROM + 1 MTHRU += LNUM - MFROM + 1 MFROM = LNUM + 1 END ELSE LNUM = INSERT.LNUM ; * RESTORE LNUM IF LNUM < MFROM THEN X = MTHRU - MFROM + 1 ; MTHRU += X ; MFROM += X END END GOSUB INSERT.MEMORY IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84 GOSUB CLEAR.NEW.MEMORY LNUM += 1 GOTO END.CMD N: ; * Move on to next record (if SELECT list is active). IF SELECT.LIST.FLAG THEN IF NOT(RECORD.CHANGE.FLAG) THEN GOTO DONE.WITH.RECORD * Record changed --- OK to go to next record (Y) CALL *UVPRINTMSG(001222,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS = 'Y' THEN GOTO DONE.WITH.RECORD ELSE GOTO END.NOCHANGE END ELSE GOTO X.2 P: ; * Print lines on the CRT. CMDN = PNUM ; GOTO P.N.1 P.N: CMDN = CMD [2, 99] ; * GET ORIGINAL NUMBER P.N.1: IF LNUM <= 0 THEN LNUM = 1 LINE1 = LNUM IF CMDN > 1 AND UPCMD[1,1] = "P" THEN PNUM = CMDN LINE2 = LNUM + CMDN - 1 IF LINE2 > BOT THEN LINE2 = BOT GOSUB PRINT.GROUP GOTO GET.CMD PRINT.BLOCK: ; * Print BLOCK on the CRT. IF MFROM = 0 OR MTHRU = 0 THEN * BLOCK not set up. CALL *UVPRINTMSG(001219,"") GOTO CMD.ERR END IF MFROM > MTHRU THEN * BLOCK from %i through %i is in the wrong order. CALL *UVPRINTMSG(001201,MFROM:@FM:MTHRU) GOTO CMD.ERR END LINE1 = MFROM ; LINE2 = MTHRU ; LNUMX = LNUM GOSUB PRINT.GROUP LNUM = LNUMX ; PRINT ; GOTO END.NOCHANGE PRINT.GROUP: ; * GOSUB routine for above PRINT routines. FOR LNUM = LINE1 TO LINE2 GOSUB GET.LINE ; GOSUB PRINT.LINE GOSUB ABORT.CHECK IF ABORT = 'Q' THEN CALL *UVPRINTMSG(001228,"") RETURN END NEXT LNUM RETURN PO.N: ; * Set line number pointer to line 'n'. CMD = CMD [3, 99] IF NOT(NUM(CMD)) THEN PRINT 'A line number is required ; you entered ':CMD:'.' GOTO CMD.ERR END GOTO SET.LNUM QUIT: ; * Quit this edit session. * IF SELECT.LIST.FLAG THEN * CALL *UVPRINTMSG(001216,"") * PRINT 'Use "X" to exit EDITOR or "N" to see next selected ':REC:'.' * GOTO CMD.ERR * END IF NOT(RECORD.CHANGE.FLAG) THEN GOTO DONE.WITH.RECORD * Record changed, OK to Quit (Y) CALL *UVPRINTMSG(001218,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS = 'Y' THEN GOTO DONE.WITH.RECORD GOTO END.NOCHANGE QUESTION.MARK: ; * '?': display current STATUS. COMMAND.SUCCESSFUL = FALSE DISPLAY.CURRENT.LINE = FALSE CALL *UVPRINTMSG(970011,@ACCOUNT) CALL *UVPRINTMSG(001262,"") PRINT DICT.TEXT:FILE.NAME: IF EDIT.READ.ONLY THEN CALL *UVPRINTMSG(001263,"") PRINT LINEX = DISPLAY.RECORD.NAME IF NLS.ON.FLAG AND UP.ARROW.FLAG THEN ;* in NLS mode, only display ID GOSUB CONV.LINEX.TO.UP.ARROW ;* as ^xxx if ^ mode is on END CALL *UVPRINTMSG(001264,LINEX) ;* record name = nnnnnn CALL *UVPRINTMSG(001265,LNUM) IF UP.ARROW.FLAG THEN IF UP.ARROW.UNIC.FLAG THEN CALL *UVPRINTMSG(001266,ENABLED:UNICODE) ;* NLS Unicode ^x mode on END ELSE CALL *UVPRINTMSG(001266,ENABLED) ;* standard ^ mode on END END ELSE CALL *UVPRINTMSG(001266,DISABLED) END IF ABORT.FLAG THEN CALL *UVPRINTMSG(001267,ENABLED) END ELSE CALL *UVPRINTMSG(001267,DISABLED) END IF BLOCK.VERIFY.FLAG THEN CALL *UVPRINTMSG(001268,ENABLED) END ELSE CALL *UVPRINTMSG(001268,DISABLED) END IF MTHRU = 0 OR MFROM = 0 THEN * No BLOCK currently defined. CALL *UVPRINTMSG(001269,"") IF MFROM # 0 THEN * Block FROM set to line %i. CALL *UVPRINTMSG(001226,MFROM) END IF MTHRU # 0 THEN * Block THROUGH set to line %i. CALL *UVPRINTMSG(001225,MTHRU) END END ELSE * BLOCK is from line %i through %i. CALL *UVPRINTMSG(001270,MFROM:@FM:MTHRU) END IF CURR.CMD.NAME THEN PRINT 'Last Pre-store executed = "':CURR.CMD.NAME:'".': IF ED.CMD.STRING.SUSPENDED THEN PRINT ' Command is at a PAUSE.' ELSE PRINT ' Command is not active.' END ELSE PRINT 'No ':PRE.STORE:' has been executed this session.' END RESTORE.CMD = IF ED.CMD.STRING.ACTIVE AND CHANGE.DURING.CMD.STRING THEN PRIOR.CMD ELSE SAVED.CMD IF RESTORE.CMD THEN CALL *UVPRINTMSG(001271,RESTORE.CMD) END ELSE CALL *UVPRINTMSG(001249,"") END GOTO END.CMD R.ANY: ; * Replace line with new text. REPLACE.STRING = CMD [3, 999999] R: IF LNUM < 1 THEN CALL *UVPRINTMSG(970010,LNUM) GOTO CMD.ERR END MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, REPLACE.STRING) GOTO END.CHANGE RELEASE: ; * Release record lock. IF RECORD.NAME.LOCKED THEN RELEASE EDIT.FILE, RECORD.NAME RECORD.NAME.LOCKED = FALSE CALL *UVPRINTMSG(001252,"") END ELSE PRINT UREC:' was not locked.' GOTO END.NOCHANGE SAVE.ANY: ; * Save a copy of this record. COMMAND.SUCCESSFUL = FALSE DISPLAY.CURRENT.LINE = FALSE IF RECORD.CHANGE.FLAG OR UPCMD # 'SAVE' THEN GOSUB FILE.IT IF NOT(WRITEERROR) THEN RECORD.CHANGE.FLAG = FALSE ; * RESET ;*026 END ELSE PRINT UREC:' has not been changed, or you already have done a SAVE.' END GOTO END.NOCHANGE SEQ.ANY: ; * Generate a sequential number. X = 4 LOOP DELIM = CMD [X, 1] WHILE DELIM = ' ' DO X += 1 REPEAT IF NOT(INDEX(DELIM.STRING, DELIM, 1)) THEN PRINT 'Valid delimiters are ':DELIM.STRING GOTO CMD.ERR END IF COUNT(CMD, DELIM) > 4 THEN PRINT 'Too many delimiters (4 maximum).' GOTO CMD.ERR END FROM.FIELD = FIELD(CMD, DELIM, 2) LEN.FROM.FIELD = LEN(FROM.FIELD) TO.FIELD = FIELD(CMD, DELIM, 3) INC.FIELD = FIELD(CMD, DELIM, 5) IF NOT(NUM(INC.FIELD)) OR LEN(TO.FIELD) = 0 OR NOT(NUM(TO.FIELD)) THEN GOTO NUMBER.ERR END IF LEN(INC.FIELD) = 0 THEN INC.FIELD = 1 EXTEND = 0 N = FIELD(CMD, DELIM, 4) N = UPCASE(N) IF N = 'B' THEN GOSUB BLOCK.CHECK ; LNUM = MFROM ; LEND = MTHRU END ELSE IF LEN(N) = 0 OR NOT(NUM(N)) THEN GOTO NUMBER.ERR IF LNUM <= 0 THEN LNUM = 1 LEND = LNUM + N - 1 EXTEND = 0 IF FROM.FIELD THEN IF LEND > BOT THEN LEND = BOT END ELSE IF LEND > BOT THEN EXTEND = LEND ; LEND = BOT END END X.CHANGE.FLAG = FALSE ; * RESET LOCAL CHANGE FLAG FOR LNUM = LNUM TO LEND GOSUB GET.LINE IF LEN(FROM.FIELD) = 0 THEN LINE = TO.FIELD:LINE ; GOTO S.REPLACE.LINE X = INDEX(LINE, FROM.FIELD, 1) IF X = 0 THEN GOTO S.NEXT.LINE LINE = LINE [1, X - 1]:TO.FIELD:LINE [X + LEN.FROM.FIELD, 999999] S.REPLACE.LINE: MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE) GOSUB PRINT.LINE CHANGE.FLAG = TRUE X.CHANGE.FLAG = TRUE ; * SET LOCAL CHANGE FLAG TO.FIELD += INC.FIELD S.NEXT.LINE: NEXT LNUM IF EXTEND THEN FOR LNUM = BOT + 1 TO EXTEND LINE = TO.FIELD GOSUB PRINT.LINE NEW.MEMORY.LINE = LINE GOSUB APPEND.NEW.MEMORY IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84 TO.FIELD += INC.FIELD NEXT LNUM LNUM = BOT GOSUB INSERT.MEMORY IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84 GOSUB CLEAR.NEW.MEMORY LNUM = EXTEND GOTO GET.CMD END CHANGE.FLAG = X.CHANGE.FLAG ; * SET UP FLAG FOR OOPS SINCE GET.LINE ; * COULD HAVE RESET IT AFTER LAST LINE ACTUALLY CHANGED GOTO GET.CMD SIZE: ; * Display information about SIZE of record. LENGTH = 0 FOR X = 1 TO LAST.CELL LENGTH += LEN(MEMORY (X)) ; * ADD LENGTH OF LINES NEXT X IF LAST.CELL > 1 THEN LENGTH += LAST.CELL - 1 CALL *UVPRINTMSG(001255,DISPLAY.RECORD.NAME:@FM:BOT:@FM:LENGTH) GOTO END.NOCHANGE SPOOL.HELP: ; * Spool the HELP file on line printer. GOSUB READ.HELP.RECORD PRINTER ON HEADING 'EDITOR H E L P LIST OF COMMANDS ':TIMEDATE():"'LLL'" LOOP REMOVE LINEX FROM HELP.RECORD SETTING DELIM PRINT LINEX ; PRINT ' ' WHILE DELIM REPEAT PRINTER OFF DUMMY = @(0) ; * TURN OFF CRT PAGING PRINT 'HELP listing spooled to printer.' GOTO HELP.END SPOOL.N: ; * Spool the record on line printer. CMDN = CMD [6, 99] IF NOT(NUM(CMDN)) THEN GOTO NUMBER.ERR IF CMDN > 0 THEN IF LNUM <= 0 THEN LNUM = 1 IF LNUM + CMDN - 1 > BOT THEN CMDN = BOT - LNUM + 1 LEND = LNUM + CMDN - 1 END ELSE LNUM = 1 ; LEND = BOT BREAK KEY OFF PRINTER ON ;* send output to lptr 0 via channel 0. LPTR.WIDTH = @LPTRWIDE LPTR.MODE = 0 ; CODE = 0 CALL @GETPU(PU$MODE,0,LPTR.MODE,CODE) IF LPTR.MODE # 3 THEN * save banner LPTR.BANNER = SPACE(32) CODE = 0 CALL @GETPU(PU$BANNER,0,LPTR.BANNER,CODE) * set banner RECORD.BANNER = FMT(DISPLAY.RECORD.NAME, 'L#32') CALL @SETPU(PU$BANNER,0,RECORD.BANNER,CODE) END HEADING UREC:' - ':DISPLAY.RECORD.NAME:' File - ':FILE.NAME:' Account - ':@ACCOUNT:' ':TIMEDATE():"'LL'" LINE.LENGTH = LPTR.WIDTH - 7 FOR LNUM = LNUM TO LEND GOSUB GET.LINE ; GOSUB PRINT.LINE NEXT LNUM PRINTER CLOSE ;* Flush printer buffer (GTAR 12556) PRINTER OFF PRINTER CLOSE IF LPTR.MODE # 3 THEN * reset banner PRINTER ON CALL @SETPU(PU$BANNER,0,LPTR.BANNER,CODE) PRINTER CLOSE ;* Flush printer buffer (GTAR 12556) PRINTER OFF END BREAK KEY ON DUMMY = @(0) ; * TURN OFF CRT PAGING LINE.LENGTH = CRT.WIDTH - 7 IF CMDN > 0 THEN PRINT 'Lines ':LEND - CMDN + 1:' to ':LEND:' of ': PRINT '"':DISPLAY.RECORD.NAME:'" spooled to the printer.' T: ; * Goto TOP of record. LNUM = 0 ; GOTO END.NOCHANGE STAMP: CMD = 'I ' BEGIN CASE CASE RECORD.NAME [4] = '.CBL' OR RECORD.NAME [6] = '.COBOL' CMD := SPACE(6):'*' CASE RECORD.NAME [4] = '.CPL' CMD := '/*' CASE RECORD.NAME [4] = '.F77' OR RECORD.NAME [4] = '.FTN' CMD := 'C' CASE RECORD.NAME [7] = '.PASCAL' CMD := '{' CASE RECORD.NAME [4] = '.PL1' OR RECORD.NAME [5] = '.PL1G' OR RECORD.NAME [4] = '.PLP' OR RECORD.NAME [4] = '.SPL' CMD := '/*' CASE RECORD.NAME [5] = '.RUNI' CMD := '.*' CASE TRUE CMD := '*' END CASE CMD := ' Last updated by ':@WHO IF @WHO # @LOGNAME THEN CMD := ' (':@LOGNAME:')' CMD := ' at ':OCONV(TIME(), 'MTS') CMD := ' on ':OCONV(DATE(), 'D4/'):'.' BEGIN CASE CASE RECORD.NAME [7] = '.PASCAL' CMD := ' }' CASE RECORD.NAME [4] = '.PL1' OR RECORD.NAME [5] = '.PL1G' OR RECORD.NAME [4] = '.PLP' OR RECORD.NAME [4] = '.SPL' CMD := ' */' CASE TRUE NULL END CASE STACK.MODE = FALSE GOTO GET.CMD.2 UNLOAD.ANY: ; * Unload lines to another record. COMMAND.SUCCESSFUL = FALSE DISPLAY.CURRENT.LINE = FALSE SV.LNUM = LNUM ; UNLOAD.FLAG = TRUE GOSUB STRING.WRITE UNLOAD.FLAG = FALSE ; LNUM = SV.LNUM GOTO END.NOCHANGE SET.LNUM: ; * '+n', '-n', 'n': set line number. IF CMD [1, 1] = '+' OR CMD [1, 1] = '-' THEN LNUM += INT(CMD) ELSE LNUM = INT(CMD) CK.NUM: IF LNUM < 0 THEN LNUM = 0 IF LNUM > BOT THEN LNUM = BOT ; COMMAND.SUCCESSFUL = FALSE GOTO END.NOCHANGE MFROM: ; * '<': set BLOCK 'from' pointer. COMMAND.SUCCESSFUL = FALSE DISPLAY.CURRENT.LINE = FALSE IF LNUM = 0 THEN CLEAR.BLOCK: MFROM = 0 ; MTHRU = 0 * The current BLOCK pointers have been cleared. CALL *UVPRINTMSG(001224,"") END ELSE MFROM = LNUM * Block FROM set to line %i. CALL *UVPRINTMSG(001226,MFROM) END IF UPCMD # '<>' OR LNUM = 0 THEN GOTO END.NOCHANGE MTHRU: ; * '>': set BLOCK 'to' pointer. COMMAND.SUCCESSFUL = FALSE DISPLAY.CURRENT.LINE = FALSE IF LNUM = 0 THEN GOTO CLEAR.BLOCK MTHRU = LNUM * Block THROUGH set to line %i. CALL *UVPRINTMSG(001225,MTHRU) GOTO END.NOCHANGE UP.ARROW.TOGGLE: ; * '^': Up arrow display mode toggle. * Controls the display/printing of special characters. * There are two modes: * - Straight '^' mode, in which unprintable characters are displayed as * ^ddd (3-digit decimals) (UP.ARROW.FLAG AND NOT(UP.ARROW.UNIC.FLAG)) * unless the characters is > 255, in which case same as ^X mode. * - NLS '^X' mode, in which unprintable characters are displayed as * ^hhhh (4-digit hex) (UP.ARROW.FLAG AND UP.ARROW.UNIC.FLAG). IF UPCMD = UP.ARROW.UNIC.UP THEN * ^X means force Unicode ^ mode on regardless of previous state, but * is only recognized if Unicode (NLS) mode is on: IF NOT(NLS.ON.FLAG) THEN * 'The %s command is not allowed unless NLS support is ON.' * CALL *UVPRINTMSG('970014',UP.ARROW.UNIC.UP) GOSUB PRINT.INVALID.UP.ARROW ;* replace with line above after 8.3.3 GOTO END.NOCHANGE END UP.ARROW.UNIC.FLAG = TRUE UP.ARROW.FLAG = TRUE END ELSE * ^ on its own toggles standard mode, always sets Unicode ^ mode off: UP.ARROW.FLAG = NOT(UP.ARROW.FLAG) UP.ARROW.UNIC.FLAG = FALSE END IF UP.ARROW.FLAG THEN IF UP.ARROW.UNIC.FLAG THEN CALL *UVPRINTMSG(001266,ENABLED:UNICODE) ;* NLS Unicode ^x mode on END ELSE CALL *UVPRINTMSG(001266,ENABLED) ;* standard ^ mode on END END ELSE CALL *UVPRINTMSG(001266,DISABLED) END GOTO END.NOCHANGE *********************************************************************** * exit edit session and close common VOC file. * STOP: IF ASSIGNED(DEVSYS.VOC.FILE) THEN CLOSE DEVSYS.VOC.FILE END DEVSYS.DICT.SWITCH = 0 IF ASSIGNED(DEVSYS.DICT.FILE) THEN CLOSE DEVSYS.DICT.FILE END DEVSYS.DICT.FILE.NAME = "" IF ASSIGNED(DEVSYS.DATA.FILE) THEN CLOSE DEVSYS.DATA.FILE END DEVSYS.DATA.FILE.NAME = "" IF ASSIGNED(DEVSYS.R.FILE) THEN CLOSE DEVSYS.R.FILE END DEVSYS.R.FILE.NAME = "" PRINT: STOP.POP: RETURN TO STOP.POP X: ; * Exit from editor when SELECT list is active. IF SELECT.LIST.FLAG THEN *---- PCC was here 11/04/83. Now releases locked record before stoppping. IF RECORD.CHANGE.FLAG THEN *------- See if we want to file first. * Record changed --- OK to EXIT (Y) CALL *UVPRINTMSG(001223,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS # 'Y' THEN GOTO END.NOCHANGE ; * file it maybe END *------- We're stopping, but first may need to release current record. IF RECORD.NAME.LOCKED THEN RELEASE EDIT.FILE, RECORD.NAME ; * RELEASE RECORD LOCK RECORD.NAME.LOCKED = FALSE END GOTO STOP END X.2: * This command can only be used when a SELECT list is active. CALL *UVPRINTMSG(001221,"") GOTO CMD.ERR * * 007 - This section of code has replaced the old section completely. * Note: the @variable @LINE is a special case, as it is the current * line being edited, and must be allocated dynamically as * the xeq sentence is being 'parsed'; * Note: tokens are strings delimited by blanks, thus to pass a legal * @variable name to xeq without replacing it, the sentence must * be of the form: * XEQ ..... '@variable' ..... or * XEQ ..... "@variable" ..... * * Note the blanks before and after the dots * XEQ.ANY: ; * 007 Execute any PERFORM statement. NEW.XEQ='' * * Get the PERFORM sentence to execute * XEQ.POS = INDEX(CMD, ' ', 1) XEQ = CMD[XEQ.POS+1, 999999] * BLK=' ' XEQ.LEN=LEN(XEQ) IF XEQ.LEN > 0 THEN ; * if there is anything after XEQ NT=COUNT(XEQ,BLK)+1 ; * COUNT NUMBER OF TOKENS(>0) FOR I=1 TO NT TOKEN=FIELD(XEQ,BLK,I) ; * EXTRACT CURRENT TOKEN C1=TOKEN[1,1] C2='' ; * 013 IF C1 = '*' OR C1 = '-' THEN ; * 013 C2=C1 ; * 013 TOKEN=TOKEN[2,999999] ; * 013 C1=TOKEN[1,1] ; * 013 END ; * 013 L.TOK=LEN(TOKEN) CL=TOKEN[L.TOK,1] IF C1 = '@' THEN ; * CHECK FOR LEGAL @VARIABLE NAME LOCATE TOKEN IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE AT.LOC='' IF AT.LOC THEN ; * LEGAL NAME FOUND,SPEC.CASE FOR @LINE IF TOKEN='@LINE' THEN AT.SUB=REPLACE(AT.SUB,AT.LOC,0,0,LINE) TOKEN = AT.SUB END END IF TOKEN = '@FM' THEN TOKEN = @FM ; * CONVERT @FM TO ~ * * NOW PROCESS QUOTED STRINGS, CHECKING THAT DATA INSIDE QUOTES IS A LEGAL * @ VARIABLE NAME. NOTE THAT WE DO NOT NEED A SPECIAL CASE FOR @LINE, BUT * THAT WE DO NEED ONE FOR @FM AS IT IS NOT IN AT.SUB * SUB.TOKEN IS TOKEN STRIPPED OF QUOTES * IF (C1=CHAR(34) OR C1=CHAR(39)) AND CL = C1 THEN SUB.TOKEN = TOKEN[2,L.TOK-2] LOCATE SUB.TOKEN IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE AT.LOC='' IF AT.LOC OR SUB.TOKEN='@FM' THEN TOKEN=SUB.TOKEN END * *IN ALL CASES ADD WHATEVER IS IN TOKEN TO NEW.XEQ * NEW.XEQ=NEW.XEQ:C2:TOKEN:BLK ; * 013 ;* ADD TOKEN TO NEW.XEQ IN ALL CASES NEXT I ; * END OF DO LOOP END ; * END OF IF PRECEEDING DO LOOP NEW.XEQ = NEW.XEQ[1,LEN(NEW.XEQ)-1] ; * 014 ;* 018 CALL *UVPRINTMSG(001259,NEW.XEQ) * * (GTAR 12556) Reset terminal using uniVerse PRINTER RESET * PFLAG = SYSTEM(1) IF PFLAG THEN PRINTER OFF PRINTER RESET IF PFLAG THEN PRINTER ON SAVE.DEVSYS.VOC.FILE = DEVSYS.VOC.FILE SAVE.DEVSYS.DICT.SWITCH = DEVSYS.DICT.SWITCH SAVE.DEVSYS.DICT.FILE = DEVSYS.DICT.FILE SAVE.DEVSYS.DICT.FILE.NAME = DEVSYS.DICT.FILE.NAME SAVE.DEVSYS.DATA.FILE = DEVSYS.DATA.FILE SAVE.DEVSYS.DATA.FILE.NAME = DEVSYS.DATA.FILE.NAME SAVE.DEVSYS.R.FILE = DEVSYS.R.FILE SAVE.DEVSYS.R.FILE.NAME = DEVSYS.R.FILE.NAME EXECUTE NEW.XEQ ; * EXECUTE THE COMMAND LINE DEVSYS.VOC.FILE = SAVE.DEVSYS.VOC.FILE DEVSYS.DICT.SWITCH = SAVE.DEVSYS.DICT.SWITCH DEVSYS.DICT.FILE = SAVE.DEVSYS.DICT.FILE DEVSYS.DICT.FILE.NAME = SAVE.DEVSYS.DICT.FILE.NAME DEVSYS.DATA.FILE = SAVE.DEVSYS.DATA.FILE DEVSYS.DATA.FILE.NAME = SAVE.DEVSYS.DATA.FILE.NAME DEVSYS.R.FILE = SAVE.DEVSYS.R.FILE DEVSYS.R.FILE.NAME = SAVE.DEVSYS.R.FILE.NAME PRINTER CLOSE ;* Flush printer buffer (GTAR 12556) DUMMY = @(0) ; * DISABLE CRT PAGING AGAIN CALL *UVPRINTMSG(001260,"") PROMPT ' ' GOTO END.NOCHANGE ! * General GOSUB routines. ! GET.LINE: ; * Get specified line from record. GOSUB routine. *---- The record being editted is maintained in a matrix called MEMORY. * Each element of the matrix contains NUMBER.LINES.PER.CELL of source * lines when the record is originally read into MEMORY. * The actual number of lines in each cell is kept in a parallel matrix * called LPC (Lines Per Cell). *---- As MEMORY is modified, LPC must also be changed to reflect the correct * number of lines in the changed cells. The current line, called LNUM, * is in the current cell called CELL. The effective line number of the * first line in the current cell is called CELL.FIRST.LNUM. The last * line number is called BOT (bottom) and is in the last active cell * called LAST.CELL. The variable LNUM.SAVE is used to indicate the * previous line number that was being pointed to. *---- The primary goal of the MEMORY accessing is speed. It is necessary * to know if the current cell has been changed (since this reset any * REMOVE pointers). The variable CHANGE.FLAG must be set to TRUE by any * routine that changes any cell of MEMORY. If a cell has been changed * then the REMOVE pointers must be rescanned. *---- When accessing a line, the logic will determine if the line LNUM is * in the current cell. If so, then it determines if the remove pointers * can be used or if they have to be reset. If the line is not in the * current cell, then the logic determines the fastest access * to one of the four possible quadrants of MEMORY by * scanning LPC forward from the first cell or the current cell or by * scanning LPC backward from the last cell or the current cell. * Once the correct cell is located, the desired line is REMOVEd. * Subsequent accesses to get the next sequential line will use the REMOVE * pointers until either a line is changed or the next line is in the * next cell. *---- GET.LINE should not be called with LNUM <= 0 or LNUM > BOT, or when the memory * matrix is null !!! *---- BOT line number of the last line (bottom) * CELL current cell of MEMORY containing line LNUM * CELL.FIRST.LINE line number of first line in this cell * CHANGE.FLAG set to TRUE whenever a routine changes MEMORY (set by user) * LAST.CELL last cell (matrix element) used in MEMORY and LPC * LINE text line from record at line number LNUM * LNUM line number of current line (set by user) * LNUM.SAVE line number of previously accessed line * LPC matrix, number of Lines Per Cell in MEMORY (set by user) * MEMORY matrix of record being editted, LPC lines in each cell (set by user) IF CHANGE.FLAG THEN CHANGE.FLAG = FALSE ; RECORD.CHANGE.FLAG = TRUE END ELSE IF LNUM = LNUM.SAVE + 1 THEN IF LNUM < CELL.FIRST.LINE + LPC (CELL) THEN GOTO GET.LINE.7 ; * GET NEXT SEQUENTIAL LINE ELSE GOTO GET.LINE.2 ; * MUST GOTO TO NEXT CELL END IF (LNUM => CELL.FIRST.LINE) AND (LNUM < LPC (CELL) + CELL.FIRST.LINE) THEN IF LNUM = LNUM.SAVE THEN RETURN ; * ALREADY HAVE IT IF LNUM > LNUM.SAVE THEN GOTO GET.LINE.6 ; * IN THIS CELL AFTER LNUM.SAVE ELSE GOTO GET.LINE.5 ; * IN THIS CELL BEFORE LNUM.SAVE END END *---- Not in current cell, or cell changed; find cell containing LNUM. IF LNUM => CELL.FIRST.LINE THEN IF LNUM > (CELL.FIRST.LINE + BOT) / 2 THEN GOTO GET.LINE.3 ; * SCAN BACK FROM BOT ELSE GOTO GET.LINE.2 ; * SCAN UP FROM CELL END ELSE IF LNUM > CELL.FIRST.LINE / 2 THEN GOTO GET.LINE.4 ; * SCAN BACK FROM CELL ELSE GOTO GET.LINE.1 ; * SCAN UP FROM START (TOP) END GET.LINE.1: ; * Initialize scan forward from first line. CELL = 1 ; CELL.FIRST.LINE = 1 IF LNUM = 0 THEN LINE = '' ; LNUM.SAVE = 0 MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!! RETURN END GET.LINE.2: ; * Scan forward to locate desired cell containing line LNUM. LOOP WHILE LNUM => CELL.FIRST.LINE + LPC (CELL) CELL.FIRST.LINE += LPC (CELL) MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!! CELL += 1 REPEAT GOTO GET.LINE.5: GET.LINE.3: ; * Initialize to scan backward from last cell. CELL = LAST.CELL CELL.FIRST.LINE = BOT + 1 - LPC (CELL) GET.LINE.4: ; * Scan backward to locate desired cell containing line LNUM. LOOP WHILE LNUM < CELL.FIRST.LINE MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!! CELL -= 1 ; CELL.FIRST.LINE -= LPC (CELL) REPEAT GET.LINE.5: ; * Reset to start remove from first line of cell. LNUM.SAVE = CELL.FIRST.LINE - 1 MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, KEEP THIS LINE !!! GET.LINE.6: ; * Remove lines up to the line before the desired one. FOR X = LNUM.SAVE TO LNUM - 2 LOOP REMOVE LINE FROM MEMORY (CELL) SETTING DX UNTIL DX = 2 OR DX = 0 REPEAT NEXT X GET.LINE.7: ; * Remove the desired line. LNUM.SAVE = LNUM REMOVE LINE FROM MEMORY (CELL) SETTING DX IF ISNULL(LINE) THEN LINE = @NULL.STR IF DX = 2 OR DX = 0 THEN RETURN LOOP LINE := CHAR(256 - DX) REMOVE LX FROM MEMORY (CELL) SETTING DX IF ISNULL(LX) THEN LX = @NULL.STR LINE := LX UNTIL DX = 2 OR DX = 0 REPEAT RETURN DELETE.MEMORY: ; * Delete 1 or more lines from record memory. GOSUB routine. *---- This subroutine deletes lines from the blocked memory. It is assumed * that GET.LINE has been called with LNUM set to the first line to be * deleted (this sets up variables used here). Also, the variable * NUM.OF.LINES.TO.DELETE should be set by the caller to the number of lines to * be deleted. * It is assumed that LNUM + NUM.OF.LINES.TO.DELETE - 1 is not greater than BOT. * If during the deleting process, one or more cells of memory are * completely cleared (LPC (CELL) = 0), then they will be squeezed out of * the matrices MEMORY and LPC. * The most probable delete case is to delete a single line. This case * is optimized to be the fastest. When deleting lines out of a cell * the logic will check to see if the entire cell will be cleared so that * it may be squeezed out of the matrices. If two cells are partially * deleted, they will not be recombined. * The subroutine exits with MEMORY and LPC set up to reflect the new * record content. CHANGE.FLAG will be set, LNUM will be backed up * one line, and BOT and LAST.CELL will be properly adjusted. * Two variables, CELLX and CELLY are used to count the cell to squeeze. * CELLX points to the first cell that may be squeezable. * CELLY points to the cell after the last one that may be squeezed. *---- Initialize: IF NUM.OF.LINES.TO.DELETE = 0 THEN RETURN CHANGE.FLAG = TRUE BOT -= NUM.OF.LINES.TO.DELETE *---- Check if first cell will be totally deleted; if so, squeeze out cell. IF LNUM = CELL.FIRST.LINE AND NUM.OF.LINES.TO.DELETE => LPC (CELL) THEN CELLX = CELL ; GOTO DELETE.MEMORY.1 END *---- Check if only one line (but not all of cell) to be deleted. IF NUM.OF.LINES.TO.DELETE = 1 THEN MEMORY (CELL) = DELETE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0) LPC (CELL) -= 1 GOTO DELETE.MEMORY.2 END *---- Determine number of lines to delete from the first cell. NUM.TO.DELETE = IF LNUM + NUM.OF.LINES.TO.DELETE > CELL.FIRST.LINE + LPC (CELL) THEN LPC (CELL) - (LNUM-CELL.FIRST.LINE) ELSE NUM.OF.LINES.TO.DELETE *---- Delete some lines from the current cell. SENT = FIELD(MEMORY (CELL), @FM, LNUM - CELL.FIRST.LINE + 1, NUM.TO.DELETE) ; * SET COL1() AND COL2() SENT = '' ; * RETURN DMR SPACE MEMORY (CELL) = MEMORY (CELL) [1, COL1() - 1]:MEMORY (CELL) [COL2() + IF COL1() THEN 0 ELSE 1, 999999] LPC (CELL) -= NUM.TO.DELETE *---- Check if all done; if not, go to next cell. IF NUM.TO.DELETE = NUM.OF.LINES.TO.DELETE THEN GOTO DELETE.MEMORY.2 CELLX = CELL + 1 NUM.OF.LINES.TO.DELETE -= NUM.TO.DELETE DELETE.MEMORY.1: ; * Scan cell line count to see if they can be squeezed. CELLY = CELLX LOOP WHILE IF CELLY <= LAST.CELL THEN NUM.OF.LINES.TO.DELETE => LPC (CELLY) ELSE 0 NUM.OF.LINES.TO.DELETE -= LPC (CELLY) CELLY += 1 ; * ON EXIT, CELLY CONTAINS FIRST LINE AFTER DELETED BLOCK REPEAT *---- Calculate number of cells to shift and abandon. XX = CELLY - CELLX ; * XX IS THE NUMBER OF CELLS TO SQUEEZE OUT IF XX THEN *---- Shift end of memory down unless there are no cells left to shift. IF CELLY <= LAST.CELL THEN FOR X = CELLX TO LAST.CELL-XX MEMORY (X) = MEMORY (CELLY) LPC (X) = LPC (CELLY) CELLY += 1 NEXT X END LAST.CELL -= XX ; * SET UP LAST.CELL TO CORRECT FINAL VALUE *---- Clear out abandoned cells. FOR X = LAST.CELL + 1 TO LAST.CELL + XX MEMORY (X) = '' ; LPC (X) = 0 NEXT X END *---- Delete unwanted lines from next cell, if any. IF NUM.OF.LINES.TO.DELETE THEN MEMORY (CELLX) = FIELD(MEMORY (CELLX), @FM, NUM.OF.LINES.TO.DELETE+1, 999999) LPC (CELLX) -= NUM.OF.LINES.TO.DELETE END DELETE.MEMORY.2: ; * Exit with LNUM backed up one line. IF LNUM = CELL.FIRST.LINE THEN IF LNUM # 1 THEN CELL -= 1 ; * BACKUP TO LAST LINE OF PREVIOUS CELL CELL.FIRST.LINE -= LPC (CELL) END END LNUM -= 1 RETURN INSERT.MEMORY: * Insert a new block into record memory. GOSUB routine. * This subroutine inserts blocks of lines into the blocked record memory. * New lines from NEW.MEMORY will be inserted after the current line LNUM. * The block of new lines is contained in matrices called NEW.MEMORY * and NEW.LPC in the same format as the main matrices MEMORY and LPC. * They contain the number of lines specified by NEW.BOT (new bottom) * and contain NEW.LAST.CELL active cells (matrix elements). * The strategy of insertion is to push the new memory cells into the * memory matrices without altering or combining any cells. If the * insertion requires splitting the current cell (that is, the current * line LNUM is not the last line of the cell) then that cell will * be split into two cells and the new memory cells will be pushed * in between. * If LNUM=0 then insertion will be made in front of all lines. * The new memory matrices and associated variables will not be altered. * The subroutine exits with all key memory variables correctly set up. IF NEW.BOT = 0 THEN RETURN GOSUB GET.LINE ; * INITIALIZE POINTERS TO MEMORY FOR CURRENT LNUM CHANGE.FLAG = TRUE IF BOT = 0 THEN LAST.CELL = 0 ; * RESET IF RECORD IS NULL BOT += NEW.BOT *---- Check size of memory matrices & re-dimension if necessary. IF NEW.LAST.CELL + LAST.CELL + 1 > MEMORY.DIM THEN MEMORY.DIM = NEW.LAST.CELL + LAST.CELL + 20 DIM MEMORY (MEMORY.DIM) ; * RE-DIMEMSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM LPC (MEMORY.DIM) ; * RE-DIMEMSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM PRIOR.MEMORY (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM PRIOR.LPC (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM SAVED.MEMORY (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM SAVED.LPC (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 FOR X = LAST.CELL + 1 TO MEMORY.DIM MEMORY (X) = '' ; * INITIALIZE MEMORY LPC (X) = 0 ; * INITIALIZE LINES.PER.CELL MATRIX PRIOR.MEMORY (X) = '' ; SAVED.LPC (X) = 0 PRIOR.LPC (X) = 0 ; SAVED.MEMORY (X) = '' NEXT X END *---- Is insert at front (LNUM = 0). IF LNUM = 0 THEN START.CELL = 1 CELLX = LAST.CELL + NEW.LAST.CELL GOTO INSERT.MEMORY.1 END *---- Is insert after end (LNUM = BOT). IF LNUM = BOT THEN CELLX = LAST.CELL + NEW.LAST.CELL GOTO INSERT.MEMORY.2 END *---- Set up to insert after the current cell. START.CELL = CELL + 1 *---- Allow 1 extra if splitting current cell (LNUM not at cell end * and LNUM # 0). CELLX = LAST.CELL + NEW.LAST.CELL + ((LNUM < CELL.FIRST.LINE + LPC (CELL) - 1) AND LNUM # 0) INSERT.MEMORY.1: ; * Spread memory cells to allow for new cells. CELLY = CELLX ; * SAVE NEW LAST.CELL FOR X = LAST.CELL TO START.CELL STEP -1 MEMORY (CELLX) = MEMORY (X) LPC (CELLX) = LPC (X) CELLX -= 1 NEXT X *---- Split cell into two if LNUM not at cell end and LNUM # 0. IF LNUM THEN X = LPC (CELL) - (LNUM - CELL.FIRST.LINE + 1) IF X THEN MEMORY (CELLX) = FIELD(MEMORY (CELL), @FM, LNUM - CELL.FIRST.LINE + 2, X) LPC (CELLX) = X MEMORY (CELL) = MEMORY (CELL) [1, COL1() - 1] LPC (CELL) -= X CELLX -= 1 ; * SKIP OVER EXTRA CELL END END INSERT.MEMORY.2: ; * Insert the cells of the new memory blocks. FOR X = NEW.LAST.CELL TO 1 STEP -1 MEMORY (CELLX) = NEW.MEMORY (X) LPC (CELLX) = NEW.LPC (X) CELLX -= 1 NEXT X LAST.CELL = CELLY RETURN APPEND.NEW.MEMORY: ; * Append new line to memory. * This routine will append the line in NEW.MEMORY.LINE to the end of * the NEW.MEMORY matrix. This routine will leave all key new memory * variables set up for a subsequent call to INSERT.MEMORY. NEW.BOT += 1 NEW.LAST.CELL = INT((NEW.BOT - 1) / LINES.PER.CELL) + 1 IF NEW.LAST.CELL > NEW.MEMORY.DIM THEN NEW.MEMORY.DIM += 10 DIM NEW.MEMORY (NEW.MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM NEW.LPC (NEW.MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 FOR Y = NEW.MEMORY.DIM-9 TO NEW.MEMORY.DIM NEW.MEMORY (Y) = '' ; * CLEAR NEW MEMORY NEW.LPC (Y) = 0 NEXT Y END NEW.MEMORY (NEW.LAST.CELL) := (IF NEW.LPC (NEW.LAST.CELL) THEN @FM ELSE '') :NEW.MEMORY.LINE NEW.LPC (NEW.LAST.CELL) += 1 RETURN CLEAR.NEW.MEMORY: ; * Clear out new memory variables. MAT NEW.MEMORY = '' ; MAT NEW.LPC = 0 NEW.BOT = 0 ; NEW.LAST.CELL = 0 RETURN OOPS.INITIAL.SAVE: ; * Memory restore routines: for OOPS command. PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU PRIOR.BOT = BOT ; PRIOR.CELL = CELL PRIOR.CELL.FIRST.LINE = CELL.FIRST.LINE PRIOR.LAST.CELL = LAST.CELL ; PRIOR.LNUM = LNUM MAT PRIOR.LPC = MAT LPC ; MAT PRIOR.MEMORY = MAT MEMORY RETURN OOPS.BEFORE.EACH.CMD: PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU PRIOR.CELL = CELL ; PRIOR.CMD = CMD IF CMD.STACK (1) = 'STAMP' THEN PRIOR.CMD = CMD.STACK (1) PRIOR.CELL.FIRST.LINE = CELL.FIRST.LINE PRIOR.LNUM = LNUM RETURN OOPS.AFTER.CHANGE.CMD: SAVED.BLOCK.MFROM = PRIOR.BLOCK.MFROM SAVED.BLOCK.MTHRU = PRIOR.BLOCK.MTHRU SAVED.BOT = PRIOR.BOT ; SAVED.CELL = PRIOR.CELL SAVED.CELL.FIRST.LINE = PRIOR.CELL.FIRST.LINE SAVED.LAST.CELL = PRIOR.LAST.CELL SAVED.LNUM = PRIOR.LNUM ; SAVED.CMD = PRIOR.CMD MAT SAVED.LPC = MAT PRIOR.LPC MAT SAVED.MEMORY = MAT PRIOR.MEMORY PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU PRIOR.BOT = BOT ; PRIOR.LAST.CELL = LAST.CELL MAT PRIOR.LPC = MAT LPC ; MAT PRIOR.MEMORY = MAT MEMORY RETURN OOPS.RESTORE: MFROM = SAVED.BLOCK.MFROM ; MTHRU = SAVED.BLOCK.MTHRU BOT = SAVED.BOT ; CELL = SAVED.CELL CELL.FIRST.LINE = SAVED.CELL.FIRST.LINE LAST.CELL = SAVED.LAST.CELL ; LNUM = SAVED.LNUM MAT LPC = MAT SAVED.LPC ; MAT MEMORY = MAT SAVED.MEMORY * Record restored to condition prior to Command %s. OLD.LINEX = LINEX LINEX = SAVED.CMD GOSUB CONV.LINEX.TO.UP.ARROW CALL *UVPRINTMSG(001250,LINEX) LINEX = OLD.LINEX PRIOR.CMD = '' ; CHANGE.FLAG = TRUE RETURN BLOCK.TRACK: ; * Move BLOCK pointers. *---- Entered with the following variables set up: * BLOCK.TRACK.LNUM (line before lines deleted, or last line inserted) * BLOCK.TRACK.CHANGE (+lines inserted, or -lines deleted) * Check if deletion crossed BLOCK pointer. IF BLOCK.TRACK.CHANGE < 0 THEN BLOCK.TRACK.END = BLOCK.TRACK.LNUM - BLOCK.TRACK.CHANGE IF MFROM => BLOCK.TRACK.LNUM + 1 AND MFROM <= BLOCK.TRACK.END THEN GOTO BLOCK.KILL IF MTHRU => BLOCK.TRACK.LNUM + 1 AND MTHRU <= BLOCK.TRACK.END THEN GOTO BLOCK.KILL END *---- If an INSERT, calculate line before doing inserts. IF BLOCK.TRACK.CHANGE > 0 THEN BLOCK.TRACK.LNUM -= BLOCK.TRACK.CHANGE *---- Check if change affects both pointers. IF BLOCK.TRACK.LNUM < MFROM THEN MFROM += BLOCK.TRACK.CHANGE ; MTHRU += BLOCK.TRACK.CHANGE RETURN END *---- Check if change affects just MTHRU (change inside BLOCK). IF BLOCK.TRACK.LNUM < MTHRU THEN MTHRU += BLOCK.TRACK.CHANGE RETURN END *---- Change must have been after BLOCK; no effect on pointers. RETURN BLOCK.KILL: ; * Kill BLOCK pointers. MFROM = 0 ; MTHRU = 0 ; RETURN BLOCK.CHECK: ; * Check BLOCK pointers ('<' and '>'). IF MFROM = 0 OR MTHRU = 0 THEN * BLOCK not set up CALL *UVPRINTMSG(001219,"") RETURN TO CMD.ERR END IF UPCMD1 = "G" THEN RETURN ; * DO NOT DISPLAY MESSAGE ON 'G< OR G>' COMMAND IF MTHRU < MFROM THEN * BLOCK from %i through %i is in the wrong order. CALL *UVPRINTMSG(001201,MFROM:@FM:MTHRU) RETURN TO CMD.ERR END IF MFROM < LNUM AND LNUM < MTHRU THEN PRINT ' encloses the destination line.' RETURN TO CMD.ERR END IF MTHRU > BOT THEN PRINT ' extends beyond the bottom.' RETURN TO CMD.ERR END IF BLOCK.VERIFY.FLAG THEN * BLOCK from %i through %i. OK (Y) CALL *UVPRINTMSG(001202,MFROM:@FM:MTHRU) GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS # 'Y' THEN * Command not done!^G\n\r CALL *UVPRINTMSG(001203,"") RETURN TO GET.CMD END END ELSE * BLOCK from %i through %i. CALL *UVPRINTMSG(001204,MFROM:@FM:MTHRU) END RETURN INPUT.LINE: ; * Input a line, convert '^' to character. IF ED.CMD.STRING.ACTIVE AND NOT(ED.CMD.STRING.SUSPENDED) THEN GOSUB ABORT.CHECK IF ABORT = 'Q' THEN ED.CMD.STRING.ACTIVE = FALSE J = 0 PRINT STARS:' Aborted ':PRE.STORE:' execution.' PRINT RETURN TO END.CMD END J += 1 IF ED.CMD.STRING (J) = '$' THEN ED.CMD.STRING.ACTIVE = FALSE J = 0 CALL *UVPRINTMSG(001227,"") RETURN TO END.CMD END INPUT.LINE = ED.CMD.STRING (J) END ELSE IF INPUT.LINE = ERROR.COND THEN PRINT STR('0',4 - LEN(LNUM)):LNUM:'=': INPUT.LINE = '' END INPUT INPUT.LINE END GOSUB CONV.FROM.UP.ARROW IF INPUT.LINE = ERROR.COND THEN GOTO INPUT.LINE INPUT.MODE = FALSE RETURN CONV.FROM.UP.ARROW: ; * Convert 'INPUT.LINE' from '^' to the specified characters. X = INDEX(INPUT.LINE, UP.ARROW, 1) IF X = 0 THEN RETURN IF LEN(INPUT.LINE) =< LEN.UP.ARROW.UNIC THEN IF INPUT.LINE = UP.ARROW OR UPCASE(INPUT.LINE) = UP.ARROW.UNIC.UP THEN * Allow ^ and ^X through if in command mode (for speed, don't * UPCASE the line unless a possible match is there): IF INPUT.MODE = TRUE THEN GOSUB PRINT.INVALID.UP.ARROW ;* error message INPUT.LINE = ERROR.COND END RETURN END END II = INPUT.LINE [1, X - 1] LOOP X += 1 IF INPUT.LINE [X, 1] = UP.ARROW THEN * ^^ replaced by single ^: II := UP.ARROW X += 1 END ELSE IF UPCASE(INPUT.LINE[X - 1, 2]) = UP.ARROW.UNIC.UP THEN * Attempt to enter 4-digit hex unicode string - check it's allowed: IF NOT(NLS.ON.FLAG) THEN * '%s UP ARROW mode is not allowed unless NLS support is ON.' * CALL *UVPRINTMSG('970015',UP.ARROW.UNIC.UP) GOSUB PRINT.INVALID.UP.ARROW ;* replace with line above after 8.3.3 GOTO CONV.FROM.UP.ARROW.ERR.EXIT END * Check 4 hex digits actually entered: X += 1 CX = INPUT.LINE[X, 4] DEC.CX = ICONV(CX, 'MX') IF STATUS() # 0 OR LEN(CX) # 4 OR DEC.CX = UNI$FM THEN * '%s must be followed by 4 hex digits.' * Also, can't allow field mark though (equivalent to ^254). CALL *UVPRINTMSG('970016',UP.ARROW.UNIC.UP) GOTO CONV.FROM.UP.ARROW.ERR.EXIT END * Convert character to UTF and insert back into line: II := UNICHAR(DEC.CX) X += 4 END ELSE CX = INPUT.LINE [X, 3] ******************************************************************************* * * Old code read as follows: *---------- PCC. Make sure we get ALL numbers! * IF NOT(NUM(CX)) OR CX<0 OR CX>255 OR CX = 254 OR LEN(CX) NE 3 THEN * Changed to check for '3N' to not allow things like '^-001' to pass the * NUM() test. ******************************************************************************* IF NOT(CX MATCHES '3N') OR CX>255 OR CX = 254 THEN GOSUB PRINT.INVALID.UP.ARROW GOTO CONV.FROM.UP.ARROW.ERR.EXIT END * In NLS mode, note that ^248-^250 go in as the pseudo-mark * characters below @TM, which is what CHAR(248) etc. returns. * If you want to enter the Unicode characters with values * >= 248 decimal, you must use ^X00F8 etc. II := CHAR(CX) X += 3 END END INPUT.LINE = INPUT.LINE [X, 999999] X = INDEX(INPUT.LINE, UP.ARROW, 1) IF X = 0 THEN INPUT.LINE = II:INPUT.LINE RETURN END II := INPUT.LINE [1, X - 1] REPEAT * Never falls through! CONV.FROM.UP.ARROW.ERR.EXIT: ;* common way out of above routine with error IF INPUT.MODE THEN INPUT.LINE = ERROR.COND ; * SET ERROR CONDITIONS END ELSE INPUT.LINE = '' RETURN TO CMD.ERR END RETURN PRINT.INVALID.UP.ARROW: ;* Message about use of "^" command * (Illegal up-arrow character code. ) * (Range is "000" through "255", excluding "254".) MSG.TEXT = UVREADMSG(001192,"") IF NOT(@SYS.BELL) THEN MSG.TEXT = CONVERT(CHAR(7),"",MSG.TEXT) END PRINT MSG.TEXT<1> PRINT MSG.TEXT<2> RETURN PRINT.LINE: ; * Print the current line. LINEX = LINE IF UP.ARROW.FLAG THEN GOSUB CONV.LINEX.TO.UP.ARROW IF LEN(LINEX) <= LINE.LENGTH THEN PRINT STR('0', 4 - LEN(LNUM)):LNUM:': ':LINEX END ELSE PRINT STR('0', 4 - LEN(LNUM)):LNUM:': ': PRINT LINEX [1, LINE.LENGTH] LOOP LINEX = LINEX [LINE.LENGTH + 1, 999999] UNTIL LEN(LINEX) = 0 PRINT ' ':LINEX [1, LINE.LENGTH] REPEAT END RETURN PL.CMD: IF LEN(UPCMD) > 2 THEN X = TRIM(UPCMD [3, 9999]) IF NOT(NUM(X)) THEN GOTO PL.ERROR IF X # INT(X) THEN GOTO PL.ERROR PL.LINES = X END ELSE X = PL.LINES ; * Use last value for PL command. IF X > 0 THEN LINE1 = LNUM LINE2 = LNUM + X IF LINE2 > BOT THEN LINE2 = BOT END ELSE LINE1 = LNUM + X IF LINE1 < 1 THEN LINE1 = 1 LINE2 = LNUM END LNUMX = LNUM GOSUB PRINT.GROUP ; PRINT LNUM = LNUMX GOTO END.NOCHANGE PL.ERROR: PRINT LINES.MESSAGE:'n integer.' GOTO END.NOCHANGE PP.CMD: ; * Print a page enclosing current line. IF LEN(UPCMD) > 2 THEN X = TRIM(UPCMD [3, 9999]) IF NOT(NUM(X)) THEN GOTO PP.ERROR IF X # INT(X) THEN GOTO PP.ERROR IF X < 1 THEN GOTO PP.ERROR PP.LINES = X END ELSE X = PP.LINES ; * Use last value for PP command. IF MOD(X, 2) # 0 THEN X += 1 LINE1 = LNUM - (X / 2) IF LINE1 < 1 THEN LINE1 = 1 LINE2 = LNUM + (X / 2) IF LINE2 > BOT THEN LINE2 = BOT LNUMX = LNUM GOSUB PRINT.GROUP ; PRINT LNUM = LNUMX GOTO END.NOCHANGE PP.ERROR: PRINT LINES.MESSAGE:' positive integer.' GOTO END.NOCHANGE CONV.LINEX.TO.UP.ARROW: ; * Convert 'LINEX' to '^' format. LL = '' ; X = 0 * In NLS mode, check all characters on line are valid UTF, otherwise * you can't trust the ^nnnn output (usually see ^x0000 for bad UTF): IF NLS.ON.FLAG THEN BAD.CHARS.IN.LINEX = FALSE DUMMY = OCONV(LINEX, 'NLSUTF8') IF STATUS() # 0 THEN * WARNING: Line has invalid internal characters, and may * display incorrectly. CALL *UVPRINTMSG(970017,'') BAD.CHARS.IN.LINEX = TRUE END END IF LINEX = @NULL.STR THEN * Print line as ^128 on its own: LINEX = UP.ARROW:SEQ(@NULL.STR) END ELSE LOOP X += 1 CX = LINEX [X, 1] UNTIL LEN(CX) = 0 AND NOT(ISNULL(CX)) DO IF NLS.ON.FLAG THEN * Don't convert unless ^ mode is actually set - may be displayable: IF NOT(UP.ARROW.FLAG) THEN RETURN * In NLS mode: * - The "^" character and the marks 248-255 always print as ^ddd. * - If Unicode ^x mode is on, all non-ASCII-printable chars * (127 upwards) will print as ^xhhhh. * - If Unicode ^x mode is off, 127-247 print as ^ddd, * 248 upwards print as ^xhhhh (but note that single-byte * marks 248-255 are still printed as ^xxx). * Note that a null line already got printed as ^128 above. BEGIN CASE CASE CX = UP.ARROW ;* "^" GOSUB PRINT.UP.ARROW.DEC CASE UNISEQ(CX) = UNI$SQLNULL OR (UNISEQ(CX) >= UNI$SYSDEL AND UNISEQ(CX) =< UNI$IM) ;* 128, 248-255 * Check whether it's really a mark, or the Unicode value * that UNISEQ returns for a mark - note we can't use SEQ() * for this, as it may give a runtime warning with NLS on: IF BYTELEN(CX) = 1 THEN GOSUB PRINT.UP.ARROW.DEC ;* genuinely a mark END ELSE GOSUB PRINT.UP.ARROW.HEX ;* actually Unicode F8Fx char END CASE UNISEQ(CX) < 32 OR UNISEQ(CX) > 126 ;* non-ASCII-printing chars BAD.CHAR.IN.LINEX.FOUND = FALSE IF BAD.CHARS.IN.LINEX THEN * NLS mode - check if we got an invalid character here, * which SEQ() cannot print - display something else instead: DUMMY = OCONV(CX, 'NLSUTF8') IF STATUS() # 0 THEN BAD.CHAR.IN.LINEX.FOUND = TRUE END BEGIN CASE CASE BAD.CHAR.IN.LINEX.FOUND GOSUB PRINT.UP.ARROW.BAD.UTF CASE UP.ARROW.UNIC.FLAG OR UNISEQ(CX) > 247 GOSUB PRINT.UP.ARROW.HEX CASE 1 GOSUB PRINT.UP.ARROW.DEC END CASE END CASE END ELSE *************************************************************************** * * THIS WAS THE OLD DEFINITION OF NON-PRINTING CHARACTERS UNDER PI * * A non-printing char is defined as: * - char in C0 set excluding the 5 chars where the displaced * graphics (clashed with the mark chars) are mapped to. * ( CX < CHAR(28) AND CX # CHAR(26)) * - the DEL char ( CHAR(127) ) or chars in C1 set. * ( CX > CHAR(126) AND CX < CHAR(160) ) * - the 5 mark chars or the up arrow * ( CX >= @TM ) * * NON.PRINTING = ((CX < CHAR(28) AND CX # CHAR(26)) OR (CX >= @TM) OR (CX = UP.ARROW) OR (CX > CHAR(126) AND CX < CHAR(160))) * *************************************************************************** * * THIS HAS BEEN CHANGED TO BE COMPATIBLE WITH THE RELEASE 6 * VERSION OF THE UNIVERSE EDITOR * (Change was agreed to by Len Greenwood and Jim T.) * * A non-printing character is defined as: * - CHAR(0) thru CHAR(31) * - CHAR(127) thru CHAR(255), but not CHAR(254) or UP.ARROW * * NON.PRINTING = (CX < CHAR(32)) OR (CX > CHAR(126)) * Note: don't compare CHARs, since may be localized - use SEQs instead. * *************************************************************************** NON.PRINTING = (SEQ(CX) < 32) OR (SEQ(CX) > 126) OR (CX = UP.ARROW) IF NON.PRINTING THEN GOSUB PRINT.UP.ARROW.DEC END END REPEAT LINEX = LL:LINEX END RETURN PRINT.UP.ARROW.BAD.UTF: * No input: always print a recognizable string for a "bad" utf character: LL := LINEX[1, X - 1]:UP.ARROW:'!!!!' LINEX = LINEX [X + 1, 999999] X = 0 RETURN PRINT.UP.ARROW.DEC: * Input: CX is character to be printed CX = SEQ(CX) LL := LINEX [1, X - 1] :UP.ARROW:STR('0', 3 - LEN(CX)) :CX LINEX = LINEX [X + 1, 999999] X = 0 RETURN PRINT.UP.ARROW.HEX: * Input: CX is character to be printed HEX.CX = OCONV(UNISEQ(CX), 'MX') LL := LINEX [1, X - 1] :UP.ARROW.UNIC:STR('0', 4 - LEN(HEX.CX)) :HEX.CX LINEX = LINEX [X + 1, 999999] X = 0 RETURN GET.RECORD: ; * Get record name and read the record. RECORD.NAME = RECORD.LIST <1> RECORD.LIST = DELETE(RECORD.LIST, 1, 0, 0) IF RECORD.NAME = '' AND NUM.REMAINING NE '' AND NUM.REMAINING GT 0 THEN NULL.ID.INLIST=TRUE ELSE NULL.ID.INLIST=FALSE IF NUM.REMAINING # '' THEN NUM.REMAINING=NUM.REMAINING-1 IF (LEN(RECORD.NAME) # 0 OR (NULL.ID.INLIST) OR (FIRST.RECORD AND (NULL.ID OR SELECT.LIST.FLAG))) THEN LINEX = RECORD.NAME GOSUB CONV.LINEX.TO.UP.ARROW DISPLAY.RECORD.NAME = LINEX IF SELECT.LIST.FLAG AND NOT(ONLY.ONE.RECORD.FLAG) THEN CALL *UVPRINTMSG(001291,DISPLAY.RECORD.NAME) END GOTO INITIALIZE END SELECT.LIST.FLAG = FALSE ONLY.ONE.RECORD.FLAG = FALSE ED.CMD.STRING.ACTIVE = FALSE ED.CMD.STRING.SUSPENDED = FALSE J = 0 IF NOT(FIRST.RECORD) THEN PRINT CALL *UVPRINTMSG(001018,"") PRINT DICT.TEXT:FILE.NAME END FIRST.RECORD = FALSE CALL *UVPRINTMSG(001290,"") GOSUB INPUT.LINE FIRST.CHAR = INPUT.LINE [1, 1] IF FIRST.CHAR = '"' OR FIRST.CHAR = "'" THEN INPUT.LINE = INPUT.LINE [2, INDEX(INPUT.LINE, FIRST.CHAR, 2) - 2] END ELSE INPUT.LINE = TRIM(INPUT.LINE) END RECORD.NAME = INPUT.LINE LINEX = RECORD.NAME GOSUB CONV.LINEX.TO.UP.ARROW DISPLAY.RECORD.NAME = LINEX IF LEN(RECORD.NAME) = 0 THEN GOTO STOP INITIALIZE: ; * Initialize for each record. FIRST.RECORD = FALSE X = '@ID' ; Y = RECORD.NAME ; GOSUB AT.INSERT BLOCK.LOGIC = FALSE ; * BLOCK LOGIC FLAG BOT = 0 ; * BOTTOM LINE NUMBER CELL = 1 ; * CURRENT CELL OF MEMORY CELL.FIRST.LINE = 1 ; * LINE NUM OF 1ST LINE IN CURRENT CELL CHANGE.FLAG = FALSE ; * RECORD CHANGED FLAG CHANGE.DURING.CMD.STRING = FALSE ; * RECORD CHANGED DURING CMD STRING XEQ LAST.CELL = 0 ; * LAST ACTIVE CELL IN MEMORY LINE = '' ; * CURRENT LINE LINE.LENGTH = CRT.WIDTH - 7 ; * LENGTH OF LINE TO FOLD ON LNUM = 0 ; * CURRENT LINE NUMBER LNUM.SAVE = 0 ; * SAVE OF LNUM MAT LPC = 0 ; * MATRIX OF LINES PER CELL OF MEMORY MAT MEMORY = '' ; * BLOCKED MEMORY OF RECORD BEING EDITTED MAT PRIOR.MEMORY = '' ; * OOPS MEMORY MAT PRIOR.LPC = 0 ; * OOPS MEMORY MAT SAVED.MEMORY = '' ; * OOPS MEMORY MAT SAVED.LPC = 0 ; * OOPS MEMORY MFROM = 0 ; * BLOCK 'FROM' POINTER MTHRU = 0 ; * BLOCK 'THRU' POINTER RECORD.CHANGE.FLAG = FALSE ; * SET TO TRUE IF RECORD CHANGED SAVED.CMD = '' ; * LAST CMD THAT CHANGED THE RECORD GOSUB CLEAR.NEW.MEMORY ; * CLEAR NEW MEMORY AND KEY VARIABLES I.TYPE.EXPR = '' READ.2: ; * Try to read record from file. RECORD.NAME.LOCKED = TRUE EDITING.VOC.FPTR = FALSE READU RECORD FROM EDIT.FILE, RECORD.NAME * ON ERROR * CALL *UVPRINTMSG(STATUS(),"") * RETURN TO DONE.WITH.RECORD * END LOCKED RECORD.NAME.LOCKED = FALSE CALL *UVPRINTMSG(001191,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS = 'Y' THEN GOTO READ.2 ELSE RETURN TO DONE.WITH.RECORD END THEN IF EDIT.READ.ONLY THEN CALL *UVPRINTMSG(001398,DICT.TEXT:FILE.NAME) END ELSE IF ((FILE.NAME = 'VOC') AND (RECORD[1,1]='F' OR RECORD[1,1]='f')) THEN EDITING.VOC.FPTR = TRUE END END ELSE DF.ERROR = STATUS() IF DF.ERROR = 1 OR DF.ERROR = 2 THEN STATUS TEMP.INFO FROM EDIT.FILE ELSE TEMP.INFO = "" IF TEMP.INFO<21> = 27 THEN CALL *UVPRINTMSG(970013,RECORD.NAME) END ELSE CALL *UVPRINTMSG(970012,RECORD.NAME) END RETURN TO DONE.WITH.RECORD END ELSE IF DF.ERROR = 3 THEN CALL *UVPRINTMSG(47007,RECORD.NAME) RETURN TO DONE.WITH.RECORD END ELSE IF DF.ERROR = 4 THEN * Warning message already issued - no need to repeat ourselves * CALL *UVPRINTMSG(47006,RECORD.NAME) RETURN TO DONE.WITH.RECORD END IF EDIT.READ.ONLY THEN CALL *UVPRINTMSG(001396,DICT.TEXT:FILE.NAME:@FM:RECORD.NAME) RETURN TO DONE.WITH.RECORD END ELSE GOTO NEW.RECORD END END *---- Check if reading an I-TYPE record from a DICTIONARY. IF DICT AND RECORD [1, 1] = 'I' THEN I.TYPE.EXPR = RECORD <2> I.TYPE.DATE = OCONV(RECORD , 'D2/') IF LEN(I.TYPE.DATE) # 0 THEN PRINT 'This is a Type "I" Descriptor last compiled on ': PRINT I.TYPE.DATE:' at ':OCONV(RECORD , 'MT:'):'.' END ELSE PRINT 'This Type "I" Descriptor must be compiled before use.' END *---- Record already exists. BOT = IF LEN(RECORD) = 0 THEN 0 ELSE COUNT(RECORD, @FM) + 1 X = INT((BOT - 1) / LINES.PER.CELL) ; * DETERMINE NUM OF FULL CELLS REQUIRED IF X + 1 > MEMORY.DIM THEN MEMORY.DIM = X + 20 DIM MEMORY (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM LPC (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM PRIOR.MEMORY (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM PRIOR.LPC (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM SAVED.MEMORY (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 DIM SAVED.LPC (MEMORY.DIM) ; * RE-DIMENSION IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84 FOR XX = MEMORY.DIM - 19 TO MEMORY.DIM SAVED.LPC (XX) = 0 ; MEMORY (XX) = '' ; LPC (XX) = 0 ; PRIOR.LPC (XX) = 0 PRIOR.MEMORY (XX) = '' ; SAVED.MEMORY (XX) = '' NEXT XX END *---- The following code sets up * to make a BLOCK of each element of the array. The size of the * BLOCK is defined by LINES.PER.CELL. *** MATBLOCK MEMORY FROM RECORD, @FM, LINES.PER.CELL CALL @MATBLOCK(MAT MEMORY,RECORD,@FM,LINES.PER.CELL) FOR XX = 1 TO X LPC (XX) = LINES.PER.CELL NEXT XX LAST.CELL = X + (BOT > 0) ; * =0 IF BOT = 0 IF LAST.CELL > 0 THEN LPC (LAST.CELL) = MOD(BOT - 1, LINES.PER.CELL) + 1 END RECORD = '' ; * RETURN DMR SPACE * %i lines long CALL *UVPRINTMSG(001207,BOT) RETURN NEW.RECORD: * New record. CALL *UVPRINTMSG(001206,"") RETURN FILE.IT: ; * File the record. GOSUB routine. WRITEERROR = FALSE ; *026 OUT.DICT = DICT ; OUT.FILE.NAME = FILE.NAME ; OUT.FILE = EDIT.FILE IF (NOT(SYSTEM(62)) AND (EDITING.VOC.FPTR)) THEN CALL *UVPRINTMSG(020553,"") RETURN TO GET.CMD END ************************************************************************ * 'READU LOCK.AGAIN FROM EDIT.FILE,RECORD.NAME THEN NULL' BELOW IS DONE * TO RESET READLOCK INITIALLY SET BY FIRST TCL EDIT. THIS IS IN PLACE TO * FIX PROBLEM OF LOCK BEING RELEASED WHEN ACTIVE FILE VARIABLE 'OUT.FILE' * GETS REASSIGNED MULTIPLE TIMES (ABOVE). ************************************************************************ READU LOCK.AGAIN FROM EDIT.FILE,RECORD.NAME * ON ERROR * CALL *UVPRINTMSG(STATUS(),"") * RETURN TO GET.CMD * END THEN NULL ;*SEE ABOVE END OUT.DICT.TEXT = DICT.TEXT IF LEN(CMD [6, 99]) = 0 THEN OUT.REC.NAME = RECORD.NAME IF EDIT.READ.ONLY THEN CALL *UVPRINTMSG(001398,OUT.DICT.TEXT:OUT.FILE.NAME) RETURN TO GET.CMD END END ELSE SENT = TRIM(CMD [6,99]) IF COUNT(SENT, ' ') > 2 THEN RETURN TO CMD.ERR IF COUNT(SENT, ' ') THEN PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE OUT.FILE.NAME = '' ; OUT.DICT = '' ; OUT.DICT.TEXT = '' SINGLE.FILE.ONLY = TRUE CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, OUT.DICT, OUT.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY) IF OUT.DICT = '' ELSE OUT.DICT.TEXT = OUT.DICT:' ' IF LEN(OUT.FILE.NAME) = 0 THEN RETURN TO CMD.ERR IF OUT.FILE.NAME # OUT.FILE.NAME <1> THEN RETURN TO CMD.ERR OUT.REC.NAME = SENT OPENCHECK OUT.DICT, OUT.FILE.NAME TO OUT.FILE ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,OUT.FILE.NAME THEN IF OUT.DICT = "" THEN PathName = FileRec<2> END ELSE PathName = FileRec<3> END RELEASE DEVSYS.VOC.FILE,OUT.FILE.NAME END ELSE PathName = "" END IF OUT.DICT = "" THEN FileName = OUT.FILE.NAME END ELSE FileName = "DICT,":OUT.FILE.NAME END CALL @OpenError(ErrorCode,FileName,PathName) RETURN TO CMD.ERR END END ELSE OUT.REC.NAME = FIELD(SENT, ' ', 1) IF LEN(OUT.REC.NAME) = 0 THEN PRINT 'Too many parameters. Expected (at most) a file name and record name.' RETURN TO CMD.ERR END READ.3: OUT.PERM.MODE = 1 OUT.PERM.IN = 6 OUT.PERM.OUT = '' CALL @PERMISSIONS(OUT.FILE,OUT.PERM.MODE,OUT.PERM.IN,OUT.PERM.OUT) IF NOT(OUT.PERM.OUT) THEN CALL *UVPRINTMSG(001398,OUT.DICT.TEXT:OUT.FILE.NAME) RETURN TO GET.CMD END READU SENT FROM OUT.FILE, OUT.REC.NAME * ON ERROR * CALL *UVPRINTMSG(STATUS(),"") * GOTO GET.CMD * END LOCKED CALL *UVPRINTMSG(001191,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS = 'Y' THEN GOTO READ.3 ELSE GOTO GET.CMD END ELSE DF.ERROR = STATUS() IF DF.ERROR = 1 OR DF.ERROR = 2 THEN STATUS TEMP.INFO FROM OUT.FILE ELSE TEMP.INFO = "" IF TEMP.INFO<21> = 27 THEN CALL *UVPRINTMSG(970013,OUT.REC.NAME) END ELSE CALL *UVPRINTMSG(970012,OUT.REC.NAME) END GOTO GET.CMD END ELSE IF DF.ERROR = 3 THEN CALL *UVPRINTMSG(47007,OUT.REC.NAME) GOTO GET.CMD END ELSE IF DF.ERROR = 4 THEN * Warning message already issued - no need to repeat ourselves * CALL *UVPRINTMSG(47006,OUT.REC.NAME) GOTO GET.CMD END GOTO FILE.IT.2 END SENT = '' ; * RETURN DMR STRING SPACE * already exists IF STACK.MODE THEN CALL *UVPRINTMSG(001197,"") END ELSE CALL *UVPRINTMSG(001110,"") END GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS # 'Y' THEN CALL *UVPRINTMSG(001220,"") GOSUB RELEASE.IF.OK RETURN TO GET.CMD END END FILE.IT.2: LNUMX = LNUM ; * SAVE LNUM LINE1 = '' ; LINE2 = '' ; LINE.OBJ.FMC = '' IF BOT => 1 THEN LNUM = 1 ; GOSUB GET.LINE ; LINE1 = LINE END IF BOT => 2 THEN LNUM = 2 ; GOSUB GET.LINE ; LINE2 = LINE END IF BOT => OBJ.FMC THEN LNUM = OBJ.FMC ; GOSUB GET.LINE ; LINE.OBJ.FMC = LINE END IF OUT.DICT AND LINE1 [1, 1] = 'I' AND (I.TYPE.EXPR # LINE2 OR LEN(LINE.OBJ.FMC) = 0) THEN IF BOT => OBJ.FMC - 4 THEN LNUM = OBJ.FMC - 4 ; * DELETE EXPRESSION OBJECT CODE GOSUB GET.LINE NUM.OF.LINES.TO.DELETE = BOT - LNUM + 1 GOSUB DELETE.MEMORY END PRINT 'This Type "I" Descriptor must be compiled before use.' END SQL.ERROR = FALSE NLS.ERROR = FALSE MATWRITEU MEMORY ON OUT.FILE, OUT.REC.NAME ON ERROR WRITEERROR = TRUE STATUS.CODE = STATUS() IF STATUS.CODE = 47006 OR STATUS.CODE = 47007 THEN CALL *UVPRINTMSG(STATUS.CODE,OUT.REC.NAME) NLS.ERROR = TRUE END END ELSE WRITEERROR = TRUE ; STATUS.CODE = STATUS() IF STATUS.CODE = IntegrityViolation THEN SQL.ERROR = TRUE IO.VAR = 2 MATBUILD DYN.ARRAY FROM MEMORY CALL @SQLINTCHK(DYN.ARRAY,OUT.FILE,OUT.REC.NAME,OUT.DICT.TEXT:OUT.FILE.NAME,IO.VAR) END END IF NOT(WRITEERROR) AND (UPCMD4 <> 'SAVE' OR LEN(CMD [6, 99]) <> 0) THEN ; *026 GOSUB RELEASE.IF.OK ; *REPLACED *026 UNCONDITIONAL RELEASE * * Convert numeric string to character to prevent the problem * when the key string is 15+ byte numeric. * TEMP.OUT.REC.NAME = 'N':OUT.REC.NAME TEMP.RECORD.NAME = 'N':RECORD.NAME IF TEMP.OUT.REC.NAME = TEMP.RECORD.NAME THEN RECORD.NAME.LOCKED = FALSE * END ; *026 LINEX = OUT.REC.NAME GOSUB CONV.LINEX.TO.UP.ARROW IF WRITEERROR THEN ; *026 IF NOT(SQL.ERROR) AND NOT(NLS.ERROR) THEN PRINT @SYS.BELL:'Failed to file "':LINEX:'"':IN.FILE:OUT.DICT.TEXT:OUT.FILE.NAME:'". STATUS = ':STATUS.CODE END END ELSE ; *026 CALL *UVPRINTMSG(001238,LINEX) CALL *UVPRINTMSG(001286,OUT.DICT.TEXT:OUT.FILE.NAME) END ; *026 LNUM = LNUMX ; * RESTORE LNUM RETURN RELEASE.IF.OK: IF UPCMD5 = 'SAVE ' AND (OUT.REC.NAME = RECORD.NAME) AND (OUT.DICT = DICT) THEN REL.OUTREC=0 IF OUT.FILE.NAME # '' AND OUT.FILE.NAME # FILE.NAME THEN STATUS OUTFLSTAT FROM OUT.FILE THEN STATUS ORIGFLSTAT FROM EDIT.FILE THEN IF (OUTFLSTAT<10> = ORIGFLSTAT<10>) AND (OUTFLSTAT<11> = ORIGFLSTAT<11>) THEN NULL ELSE REL.OUTREC=1 END END END IF REL.OUTREC THEN RELEASE OUT.FILE, OUT.REC.NAME END ELSE RELEASE OUT.FILE, OUT.REC.NAME END RETURN ! * Command stack and pre-stored command routines. ! STACK.PROCESSOR: STACK.MODE = TRUE SV.CMD = CMD CMD = TRIM(CMD) IF UPCMD3 = '.XK' OR UPCMD3 = '.XR' THEN GOTO STACK.EXECUTE IF UPCMD4 = 'LOOP' THEN GOTO STRING.LOOP IF UPCMD5 = 'PAUSE' THEN GOTO STRING.PAUSE TOKEN1 = FIELD(CMD, ' ', 2) TOKEN2 = FIELD(CMD, ' ', 3) TOKEN3 = FIELD(CMD, ' ', 4) TOKEN4 = FIELD(CMD, ' ', 5) GOSUB SET.UP.NN IF UPCMD2 = '.A' THEN GOTO STACK.APPEND IF UPCMD2 = '.C' THEN GOTO STACK.CHANGE IF UPCMD2 = '.D' THEN GOTO STACK.DELETE IF UPCMD2 = '.X' THEN GOTO STACK.EXECUTE IF UPCMD2 = '.I' THEN GOTO STACK.INSERT IF UPCMD2 = '.L' THEN GOTO STACK.LIST IF UPCMD2 = '.R' THEN GOTO STACK.RECALL IF UPCMD2 = '.S' THEN GOTO STACK.SAVE IF UPCMD2 = '.U' THEN GOTO STACK.UPCASE GOTO CMD.ERR DISPLAY.CURRENT.LINE: IF UNASSIGNED(DISPLAY.CURRENT.LINE) THEN DISPLAY.CURRENT.LINE = TRUE IF UNASSIGNED(COMMAND.SUCCESSFUL) THEN COMMAND.SUCCESSFUL = TRUE IF DISPLAY.CURRENT.LINE OR COMMAND.SUCCESSFUL THEN IF LNUM = 0 THEN CALL *UVPRINTMSG(001190,"") END ELSE IF BOT THEN GOSUB GET.LINE IF COMMAND.SUCCESSFUL THEN GOSUB PRINT.LINE END END END END DISPLAY.CURRENT.LINE = TRUE COMMAND.SUCCESSFUL = TRUE RETURN STACK.APPEND: ; * '.A': append to a stack command. CMD.STACK (NN) := SV.CMD [INDEX(SV.CMD, ' ', 1) + 1, 9999] PRINT NN "R%2":" ":CMD.STACK (NN) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STACK.CHANGE: ; * '.C': change a stack command. DELIM = CMD [LEN(NN) + 3, 1] FROM.STRING = FIELD(SV.CMD [2, 9999], DELIM, 2) LEN.FROM = LEN(FROM.STRING) TO.STRING = FIELD(SV.CMD [2, 9999], DELIM, 3) IF COL2() = 0 THEN PRINT 'Missing required TO field (for "CHANGE/FROM/TO").' PRINT GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END IF LEN(FROM.STRING) = 0 THEN CMD.STACK (NN) = TO.STRING:CMD.STACK (NN) PRINT NN "R%2":" ":CMD.STACK (NN) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD END GLOBAL = FIELD(SV.CMD[2,9999], DELIM, 4) ; GLOBAL = UPCASE(GLOBAL) ; GLOBAL.FLAG = FALSE IF GLOBAL[1,1] = "G" THEN GLOBAL = GLOBAL[2,99] ; GLOBAL.FLAG = TRUE STACK.CHANGED = FALSE STACK.CHANGE.1: START.POS = INDEX(CMD.STACK (NN), FROM.STRING, 1) IF START.POS NE 0 THEN STACK.CHANGED = TRUE CMD.STACK (NN) [START.POS, LEN.FROM] = '' CMD.STACK (NN) = CMD.STACK (NN) [1, START.POS - 1]:TO.STRING:CMD.STACK (NN) [START.POS + LEN.FROM, 9999] IF GLOBAL.FLAG THEN GOTO STACK.CHANGE.1 END IF STACK.CHANGED THEN PRINT NN "R%2":" ":CMD.STACK (NN) PRINT GOSUB DISPLAY.CURRENT.LINE END GOTO GET.CMD STACK.DELETE: ; * '.D': delete a stack command or a pre-stored command string. IF TOKEN1 THEN GOTO STRING.DELETE CALL *UVPRINTMSG(001077,NN) PRINT NN -= 1 GOSUB PUSH.DOWN GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STRING.DELETE: GOSUB STRING.WRITE SD.1: IF REC.TYPE.CODE # 'E' THEN CALL *UVPRINTMSG(001108,WRITE.REC.NAME) GOTO CMD.ERR END DELETE WRITE.FILE, WRITE.REC.NAME CALL *UVPRINTMSG(970003,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STACK.EXECUTE: ; * '.X': execute one stack command, or load (not into the stack) and * execute a pre-stored string. IF UPCMD3 = '.XK' THEN IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR ED.CMD.STRING.ACTIVE = FALSE ED.CMD.STRING.SUSPENDED = FALSE J = 0 ED.CMD.STRING (1) = '$' GOTO GET.CMD END IF UPCMD3 = '.XR' THEN IF ED.CMD.STRING.SUSPENDED THEN ED.CMD.STRING.SUSPENDED = FALSE GOTO GET.CMD END ELSE GOTO CMD.ERR END IF TOKEN1 THEN GOTO STRING.EXECUTE PRINT NN "R%2":" ":CMD.STACK (NN + 1) INPUT.LINE = CMD.STACK (NN + 1) IF NN = 1 THEN FOR IJ = 1 TO 2 NN = 0 GOSUB PUSH.DOWN NEXT IJ END ELSE NN = 0 GOSUB PUSH.DOWN END GOTO GET.CMD.1 STRING.EXECUTE: J = 0 IF ED.CMD.STRING.SUSPENDED THEN IF CHANGE.DURING.CMD.STRING THEN GOSUB OOPS.AFTER.CHANGE.CMD CHANGE.DURING.CMD.STRING = FALSE END GOSUB OOPS.BEFORE.EACH.CMD ED.CMD.STRING.SUSPENDED = FALSE END MAT ED.CMD.STRING = '$' GOTO LOAD.ANY STACK.INSERT: ; * '.I': insert one or more commands into the stack. IF TOKEN1 OR LEN(SV.CMD) > 4 THEN GOTO SI.3 NUM.CMDS = 0 ; NEW.CMD = '' SI.1: PRINT ' =': GOSUB INPUT.LINE ED.CMD = INPUT.LINE IF LEN(ED.CMD) = 0 THEN GOTO SI.2 IF ED.CMD = ' ' THEN ED.CMD = '' NEW.CMD := ED.CMD:@FM NUM.CMDS += 1 IF NN + NUM.CMDS => STACK.LIMIT THEN PRINT @SYS.BELL:'Can only accept 99 commands.' GOTO SI.2 END GOTO SI.1 SI.2: BLOCK.END = NN GOSUB POP.UP FIELD.CTR = 1 FOR I = NN + NUM.CMDS - 1 TO NN STEP -1 CMD.STACK (I) = FIELD(NEW.CMD, @FM, FIELD.CTR) FIELD.CTR += 1 NEXT I PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD SI.3: BLOCK.END = NN NUM.CMDS = 1 GOSUB POP.UP IF LEN(TOKEN1) = 0 THEN IF SV.CMD [LEN(NN) + 4, 9999] = ' ' THEN CMD.STACK (NN) = '' END ELSE CMD.STACK (NN) = SV.CMD [LEN(NN) + 4, 9999] END END ELSE CMD.STACK (NN) = SV.CMD [INDEX(SV.CMD, ' ', 1) + 1, 9999] PRINT NN "R%2":" ":CMD.STACK(NN) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STACK.LIST: ; * '.L': list all or part of the stack, pre-stored string, or * pre-stored record names. IF TOKEN1 THEN GOTO STRING.LIST IF NN => END.STACK THEN NN = END.STACK - 1 NUM.LINES = 0 FOR I = NN TO 1 STEP -1 PRINT I "R%2":" ":CMD.STACK (I) GOSUB PN.1 NEXT I PRINT GOTO END.NOCHANGE STRING.LIST: LEN.CMD = LEN(CMD) IF CMD [LEN.CMD - 1, 2] = ' *' THEN GOTO SL.2 GOTO LOAD.ANY SL.1: PRINT PRINT SPACE(5):LOAD.REC.NAME ERROR.FORMAT = FALSE GOSUB PRINT.CMD.STRING PRINT GOTO END.NOCHANGE SL.2: L.SELECT.FLAG = TRUE CMD = CMD [1, LEN.CMD - 2] GOTO LOAD.ANY SL.3: L.SELECT.FLAG = FALSE MAT CMD.NAME = '' SELECT LOAD.FILE NUM.LINES = 0 PRINT ; PRINT 'File is "':DICT:LOAD.FILE.NAME:'".' ; PRINT SL.3A: FOR K = 1 TO 5 SL.3B: READNEXT CMD.NAME (K) ELSE GOTO SL.4 READ COMMAND.RECORD FROM LOAD.FILE, CMD.NAME (K) ELSE PRINT 'Selected ':REC:' "':CMD.NAME (K):'"':IN.FILE:DICT:LOAD.FILE.NAME:'" not found.' GOTO SL.3B END IF COMMAND.RECORD <1> [1, 1] # 'E' THEN GOTO SL.3B NEXT K GOSUB PRINT.NAMES GOTO SL.3A SL.4: GOSUB PRINT.NAMES ; GOTO END.NOCHANGE STACK.RECALL: ; * '.R': recall a stack command to the bottom of the stack. ; * or load a pre-stored string into the stack. IF TOKEN1 THEN GOTO LOAD.ANY IF END.STACK = 1 THEN CALL *UVPRINTMSG(001071,1) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END BLOCK.END = 1 ; NUM.CMDS = 1 GOSUB POP.UP CMD.STACK (1) = CMD.STACK (NN + 1) PRINT NN "R%2":" ":CMD.STACK (1) ** retain copy of command ** GOSUB PUSH.DOWN PRINT GOTO END.NOCHANGE SR.1: FWD.PTR = 1 ; BLOCK.END = 1 NUM.CMDS = BOT.STRING - 2 GOSUB POP.UP FOR I = NUM.CMDS TO 1 STEP -1 CMD.STACK (I) = ED.CMD.STRING (FWD.PTR) FWD.PTR += 1 NEXT I GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STACK.SAVE: ; * '.S': save one or more commands as a pre-stored string. IF LEN(CMD) = 2 THEN CALL *UVPRINTMSG(020072,"") PRINT GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END IF END.STACK = 1 THEN CALL *UVPRINTMSG(001071,1) GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END COMMA = INDEX(CMD, ',', 1) IF COMMA THEN IF COUNT(CMD, ' ') < 2 THEN CALL *UVPRINTMSG(020073,"") PRINT GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END FIRST.CMD = CMD [COMMA-2, 2] IF NOT(NUM(FIRST.CMD)) THEN CALL *UVPRINTMSG(020073,"") PRINT GOSUB DISPLAY.CURRENT.LINE GOTO CMD.ERR END LAST.CMD = CMD [COMMA + 1, 2] IF NOT(NUM(LAST.CMD)) THEN CALL *UVPRINTMSG(020073,"") GOTO CMD.ERR END IF FIRST.CMD < LAST.CMD THEN SWAP.CMD = FIRST.CMD FIRST.CMD = LAST.CMD LAST.CMD = SWAP.CMD END CMD = CMD [1, COMMA-3] END ELSE FIRST.CMD = NN ; LAST.CMD = 1 GOSUB STRING.WRITE PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STACK.UPCASE: CMD.STACK (NN) = UPCASE( CMD.STACK (NN) ) PRINT NN "R%2":" ":CMD.STACK (NN) PRINT GOSUB DISPLAY.CURRENT.LINE GOTO GET.CMD STRING.LOOP: ; * LOOP: loop within a pre-stored command string. IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR ; * DON'T TAKE 'LOOP' FROM KEYBOARD IF LOOP.FLAG THEN GOTO TEST.LOOP.CTR SETUP.LOOP: SAVE.J = J LOOP.FLAG = TRUE STMT.NR = FIELD(TRIM(UPCMD), ' ', 2) IF STMT.NR = '' THEN STMT.NR = 1 IF NOT(NUM(STMT.NR)) THEN LOOP.FLAG = FALSE GOTO CMD.ERR END STMT.NR = STMT.NR - 1 IF STMT.NR < 0 OR STMT.NR > SAVE.J - 1 THEN LOOP.FLAG = FALSE GOTO CMD.ERR END NR.TIMES = FIELD(TRIM(UPCMD), ' ', 3) IF NR.TIMES = '' THEN NR.TIMES = 1 IF NOT(NUM(NR.TIMES)) THEN LOOP.FLAG = FALSE GOTO CMD.ERR END IF NR.TIMES < 1 THEN NR.TIMES = 1 IF STMT.NR > 0 THEN STMT.NR = STMT.NR - 1 J = STMT.NR GOTO GET.CMD TEST.LOOP.CTR: NR.TIMES -= 1 IF NR.TIMES = 0 THEN LOOP.FLAG = FALSE ; J = SAVE.J ; GOTO GET.CMD END J = STMT.NR GOTO GET.CMD STRING.PAUSE: ; * PAUSE: suspend execution of a pre-stored command string. IF ED.CMD.STRING (1) = '$' THEN GOSUB SP.2 ; GOTO END.CMD IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR ED.CMD.STRING.SUSPENDED = TRUE CALL *UVPRINTMSG(001261,J) GOTO END.CMD ! * Command stack and pre-stored command subroutines. ! GET.CMD.FROM.BLOCK: ; * Get pre-stored commands from record block into string. IF BLOCK <1> [1, 1] = 'E' AND UPCMD2 # '.L' THEN BLOCK = DELETE(BLOCK, 1, 0, 0) END ELSE IF UPCMD2 # '.L' THEN CALL *UVPRINTMSG(001108,LOAD.REC.NAME) GOTO CMD.ERR END END DIM.SIZE = COUNT(BLOCK, @FM) DIM ED.CMD.STRING (DIM.SIZE + 2) IF INMAT() THEN GOSUB OVERFLOW ; GOTO GET.CMD ; * SJE 23 Apr 84 MATPARSE ED.CMD.STRING FROM BLOCK, @FM ED.CMD.STRING (INMAT() + 1) = '$' BOT.STRING = INMAT() + 2 BLOCK = '' IF UPCMD2 = '.L' THEN GOTO SL.1 IF INMAT() > 99 THEN PRINT 'This ':PRE.STORE:' string exceeds 99 commands.' GOTO CMD.ERR END IF UPCMD2 = '.R' THEN PRINT ; PRINT STARS:' Loaded ':INMAT():' command(s).' ; PRINT GOTO SR.1 END CURR.CMD.NAME = LOAD.REC.NAME ED.CMD.STRING.ACTIVE = TRUE GOTO GET.CMD POP.UP: ; * Move stack commands up a given number of slots. IF END.STACK + NUM.CMDS > 100 THEN END.STACK = 100 ES = 101-NUM.CMDS CMD.STACK (END.STACK) = '$' END ELSE ES = END.STACK END.STACK = END.STACK + NUM.CMDS END FOR I = ES TO BLOCK.END STEP -1 CMD.STACK (I + NUM.CMDS) = CMD.STACK (I) NEXT I RETURN PRINT.CMD.STRING: ; * Print a pre-stored string on the CRT. JJ = 1 ; KK = 20 SP.1: FOR INDEX = JJ TO KK UNTIL ED.CMD.STRING (INDEX) = '$' IF ERROR.FORMAT THEN PRINT " ":INDEX "R%2":": ":ED.CMD.STRING(INDEX) END ELSE PRINT FMT(INDEX, 'R%3'):' ':ED.CMD.STRING (INDEX) END NEXT INDEX IF ED.CMD.STRING (1) # '$' THEN GOTO SP.3 SP.2: ; * NOTE: 'SP.2' also used via GOSUB. PRINT STARS:'The ':PRE.STORE:' string is empty.' RETURN SP.3: IF ED.CMD.STRING (INDEX) = '$' THEN RETURN END JJ += 20 ; KK += 20 CALL *UVPRINTMSG(001142,"") INPUT Q, 1 ; Q = UPCASE(Q) IF Q = 'Q' THEN RETURN GOTO SP.1 PRINT.NAMES: ; * Print pre-stored record names in a given file. PRINT CMD.NAME (1), CMD.NAME (2), CMD.NAME (3), CMD.NAME (4), CMD.NAME (5) MAT CMD.NAME = '' PN.1: NUM.LINES += 1 IF NUM.LINES > (@CRTHIGH - 4) THEN NUM.LINES = 0 CALL *UVPRINTMSG(001142,"") INPUT Q, 1 ; Q = UPCASE(Q) IF Q = 'Q' THEN RETURN TO END.NOCHANGE END RETURN PUSH.DOWN: ; * Push stack commands down a given number of slots. FOR I = NN + 1 TO END.STACK CMD.STACK (I) = CMD.STACK (I + 1) NEXT I END.STACK -= 1 RETURN PUT.ON.STACK: ; * Put commands onto the command stack. IF LEN(CMD) = 0 AND NULL.CTR THEN NULL.CTR += 1 CMD.STACK (1) = '+':NULL.CTR RETURN END IF UPCASE(CMD [1, 3]) = '.XR' THEN RETURN IF UPCASE(CMD [1, 3]) = '.XK' THEN RETURN IF UPCASE(CMD [1, 2]) = '.X' THEN GOTO STASH.IT IF UPCASE(CMD [1, 4]) = 'HELP' THEN RETURN IF CMD [1, 1] = '.' THEN RETURN IF CMD [1, 1] = '?' THEN RETURN IF ED.CMD.STRING.ACTIVE AND NOT(ED.CMD.STRING.SUSPENDED) THEN RETURN STASH.IT: NUM.CMDS = 1 ; BLOCK.END = 1 GOSUB POP.UP IF LEN(CMD) = 0 THEN NULL.CTR = 1 ; CMD.STACK (1) = '+':1 ELSE CMD.STACK (1) = ORIGINAL.CMD RETURN SET.UP.NN: ; * Find which stack command is to be operated on. MATCH.CHAR = MATCHFIELD(UPCMD [3, 1], '1N', 1) IF LEN(MATCH.CHAR) # 0 THEN NN = UPCMD [3, 1] MATCH.CHAR = MATCHFIELD(UPCMD [4, 1], '1N', 1) IF LEN(MATCH.CHAR) # 0 THEN NN := UPCMD [4, 1] MATCH.CHAR = MATCHFIELD(UPCMD [5, 1], '1N', 1) IF LEN(MATCH.CHAR) # 0 THEN NN := UPCMD [5, 1] END END ELSE IF UPCMD2 # '.C' THEN IF CMD [3, 1] # ' ' AND LEN(CMD [3, 1]) # 0 THEN RETURN TO CMD.ERR END IF UPCMD2 = '.L' THEN NN = 9 ELSE NN = 1 IF UPCMD2 = '.C' THEN CMD = CMD [1, 2]:1:CMD [3, 9999] IF UPCMD2 = '.I' THEN SV.CMD = SV.CMD [1, 2]:1:SV.CMD [3, 9999] IF END.STACK = 1 THEN IF UPCMD2 = '.D' AND TOKEN1 THEN RETURN IF UPCMD2 = '.I' OR UPCMD2 = '.R' OR UPCMD2 = '.X' THEN RETURN END END IF NN = 0 THEN RETURN TO CMD.ERR IF NN => END.STACK - 1 AND UPCMD2 = '.X' AND NOT(TOKEN1) THEN CALL *UVPRINTMSG(001071,NN) PRINT NN = 0 GOSUB PUSH.DOWN GOSUB DISPLAY.CURRENT.LINE RETURN TO CMD.ERR END IF NN = STACK.LIMIT AND UPCMD2 # '.L' THEN RETURN TO CMD.ERR IF NN = END.STACK AND UPCMD2 = '.I' THEN RETURN IF NN => END.STACK AND UPCMD2 # '.L' THEN CALL *UVPRINTMSG(001071,NN) PRINT GOSUB DISPLAY.CURRENT.LINE RETURN TO CMD.ERR END RETURN STRING.WRITE: ; * Write stack to a pre-stored command record, or unload lines. WRITE.FILE.DICT = '' IF NOT(COUNT(CMD, ' ')) THEN RETURN TO CMD.ERR SENT = TRIM(CMD [INDEX(CMD, ' ', 1) + 1, 99]) IF COUNT(SENT, ' ') > 2 THEN RETURN TO CMD.ERR IF COUNT(SENT, ' ') THEN PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE WRITE.FILE.NAME = '' ; WRITE.FILE.DICT = '' SINGLE.FILE.ONLY = TRUE CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, WRITE.FILE.DICT, WRITE.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY) IF LEN(WRITE.FILE.NAME) = 0 THEN RETURN TO CMD.ERR IF WRITE.FILE.NAME # WRITE.FILE.NAME <1> THEN RETURN TO CMD.ERR LOAD.REC.NAME = SENT OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN IF WRITE.FILE.DICT = "" THEN PathName = FileRec<2> END ELSE PathName = FileRec<3> END RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME END ELSE PathName = "" END IF WRITE.FILE.DICT = "" THEN FileName = WRITE.FILE.NAME END ELSE FileName = "DICT,":WRITE.FILE.NAME END CALL @OpenError(ErrorCode,FileName,PathName) RETURN TO CMD.ERR END WRITE.REC.NAME = SENT END ELSE IF UNLOAD.FLAG THEN WRITE.FILE.NAME = FILE.NAME ; WRITE.FILE.DICT = DICT WRITE.FILE = EDIT.FILE END ELSE WRITE.FILE.NAME = '&ED&' ; WRITE.FILE.DICT = '' OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN PathName = FileRec<2> RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME END ELSE IF ErrorCode = -1 THEN AcctFlavor = SYSTEM(1001) IF AcctFlavor = 2 OR AcctFlavor = 8 OR AcctFlavor = 16 THEN CreateArgs = "1,1,3 1,1,1" END ELSE CreateArgs ="1 0 0" END EXECUTE "CREATE-FILE &ED& ":CreateArgs OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE THEN GOTO WRITE.OKAY END ELSE ErrorCode = STATUS() READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN PathName = FileRec<2> RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME END ELSE PathName = "" END END END ELSE PathName = "" END END FileName = WRITE.FILE.NAME CALL @OpenError(ErrorCode,FileName,PathName) RETURN TO CMD.ERR END END WRITE.OKAY: WRITE.REC.NAME = FIELD(SENT, ' ', 1) END IF LEN(SENT) = 0 THEN RETURN TO CMD.ERR IF LEN(WRITE.REC.NAME) = 0 THEN RETURN TO CMD.ERR IF UNLOAD.FLAG THEN * Starting line/field number - CALL *UVPRINTMSG(001193,"") GOSUB INPUT.LINE START = INPUT.LINE IF NOT(NUM(START)) THEN PRINT 'Starting line/field must be numeric ; you entered "':START:'".' RETURN TO CMD.ERR END IF START < 1 THEN CALL *UVPRINTMSG(001231,"") RETURN TO CMD.ERR END IF START > BOT THEN CALL *UVPRINTMSG(001230,BOT:@FM:START) RETURN TO CMD.ERR END * Ending line/field number - CALL *UVPRINTMSG(001195,"") GOSUB INPUT.LINE ENDING = INPUT.LINE IF NOT(NUM(ENDING)) THEN PRINT 'Ending line/field must be numeric ; you entered "':ENDING:'".' RETURN TO CMD.ERR END IF ENDING < START THEN CALL *UVPRINTMSG(001233,ENDING:@FM:START) RETURN TO CMD.ERR END END CHECK.FOR.LOCK: READU COMMAND.RECORD FROM WRITE.FILE, WRITE.REC.NAME * ON ERROR * CALL *UVPRINTMSG(STATUS(),"") * RETURN TO GET.CMD * END LOCKED CALL *UVPRINTMSG(001191,"") GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS = 'Y' THEN GOTO CHECK.FOR.LOCK ELSE RETURN TO GET.CMD END ELSE IF UPCMD2 = '.D' THEN CALL *UVPRINTMSG(970004,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME) PRINT GOSUB DISPLAY.CURRENT.LINE RETURN TO GET.CMD END DF.ERROR = STATUS() IF DF.ERROR = 1 OR DF.ERROR = 2 THEN STATUS TEMP.INFO FROM WRITE.FILE ELSE TEMP.INFO = "" IF TEMP.INFO<21> = 27 THEN CALL *UVPRINTMSG(970013,WRITE.REC.NAME) END ELSE CALL *UVPRINTMSG(970012,WRITE.REC.NAME) END RETURN TO GET.CMD END ELSE IF DF.ERROR = 3 THEN CALL *UVPRINTMSG(47007,WRITE.REC.NAME) RETURN TO GET.CMD END ELSE IF DF.ERROR = 4 THEN * Warning message already issued - no need to repeat ourselves * CALL *UVPRINTMSG(47006,WRITE.REC.NAME) RETURN TO GET.CMD END GOTO WRITE.IT.OUT END REC.TYPE.CODE = COMMAND.RECORD <1> [1, 1] COMMAND.RECORD = '' ; * RETURN STRING SPACE IF UPCMD2 = '.D' THEN RETURN TO SD.1 * already exists overwrite IF STACK.MODE THEN CALL *UVPRINTMSG(001110,"") CALL *UVPRINTMSG(001200,"") END ELSE CALL *UVPRINTMSG(001197,"") END GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS) IF ANS # 'Y' THEN IF STACK.MODE THEN CALL *UVPRINTMSG(001111,WRITE.REC.NAME) END ELSE CALL *UVPRINTMSG(001198,"") DISPLAY.CURRENT.LINE = FALSE END RETURN END WRITE.IT.OUT: WRITE.PERM.MODE = 1 WRITE.PERM.IN = 2 WRITE.PERM.OUT = '' CALL @PERMISSIONS(WRITE.FILE,WRITE.PERM.MODE,WRITE.PERM.IN,WRITE.PERM.OUT) IF NOT(WRITE.PERM.OUT) THEN CALL *UVPRINTMSG(001398,WRITE.FILE.DICT:WRITE.FILE.NAME) RETURN TO GET.CMD END IF UNLOAD.FLAG THEN GOTO UNLOAD CMD.STRING = UVREADMSG(010239,"") CMD.STRING = 'E':CMD.STRING:TIMEDATE():@FM IF NN = 1 AND NOT(COMMA) THEN LAST.CMD = 1 ELSE IF CMD.STACK (FIRST.CMD) [1, 1] = 'E' THEN CMD.STRING = '' ; * USER PUT OWN 'E' FIELD FOR JJ = FIRST.CMD TO LAST.CMD + 1 STEP -1 CMD.STRING := CMD.STACK (JJ):@FM NEXT JJ END CMD.STRING := CMD.STACK (LAST.CMD) WRITE CMD.STRING TO WRITE.FILE, WRITE.REC.NAME ELSE WRITE.STATUS = STATUS() IF WRITE.STATUS = IntegrityViolation THEN IO.VAR = 2 CALL @SQLINTCHK(CMD.STRING,WRITE.FILE,WRITE.REC.NAME,WRITE.FILE.DICT:" ":WRITE.FILE.NAME,IO.VAR) END ELSE CALL *UVPRINTMSG(001236,WRITE.STATUS) END END IF STACK.MODE THEN CALL *UVPRINTMSG(970005,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME) END ELSE CALL *UVPRINTMSG(001112,WRITE.REC.NAME) END RETURN UNLOAD: IF ENDING > BOT THEN ENDING = BOT UN.RECORD = '' FOR LNUM = START TO ENDING - 1 GOSUB GET.LINE UN.RECORD := LINE:@FM NEXT LNUM LNUM = ENDING GOSUB GET.LINE UN.RECORD := LINE WRITE UN.RECORD TO WRITE.FILE, WRITE.REC.NAME ELSE WRITE.STATUS = STATUS() IF WRITE.STATUS = IntegrityViolation THEN IO.VAR = 2 CALL @SQLINTCHK(UN.RECORD,WRITE.FILE,WRITE.REC.NAME,WRITE.FILE.DICT:" ":WRITE.FILE.NAME,IO.VAR) END ELSE CALL *UVPRINTMSG(001236,WRITE.STATUS) END RETURN END * IF STACK.MODE THEN * CALL *UVPRINTMSG(970005,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME) * END UN.RECORD = '' * %i lines/fields unloaded. CALL *UVPRINTMSG(001199,ENDING - START + 1) DISPLAY.CURRENT.LINE = FALSE RETURN READ.HELP.RECORD: IF LEN(HELP.RECORD) = 0 THEN READ HELP.RECORD FROM SYS.MESSAGE,970000 ELSE CALL *UVPRINTMSG(970002,"") RETURN TO HELP.END END READ HELP.RECORD.2 FROM SYS.MESSAGE,970001 ELSE CALL *UVPRINTMSG(970002,"") RETURN TO HELP.END END HELP.RECORD = HELP.RECORD:@FM:HELP.RECORD.2 HELP.RECORD = CHANGE(HELP.RECORD,'_':@FM,@VM) * Ignore standard header (top three lines) of help file. * HELP.RECORD = FIELD(HELP.RECORD, @FM, 4, 9999) ;* not on uniVerse! * Following code to be removed post-8.3.3. * Remove references to NLS and Unicode functionality if NLS mode is off. NUM.HELP.LINES = DCOUNT(HELP.RECORD, @FM) HELP.RECORD.ORIG = HELP.RECORD HELP.RECORD = '' SKIP.HELP.LINE = @FALSE FOR N = 1 TO NUM.HELP.LINES HELP.LINE = HELP.RECORD.ORIG IF NLS.ON.FLAG THEN ;* just remove the NLS marker lines IF HELP.LINE[1,3] # 'NLS' THEN HELP.RECORD<-1> = HELP.LINE END ELSE ;* remove all lines between as well BEGIN CASE CASE HELP.LINE = 'NLSBEGIN' SKIP.HELP.LINE = @TRUE CASE HELP.LINE = 'NLSEND' SKIP.HELP.LINE = @FALSE CASE SKIP.HELP.LINE = @FALSE HELP.RECORD<-1> = HELP.LINE END CASE END NEXT N * End 8.3.3 special - remove NLSBEGIN/NLSEND lines from messages 970000/970001 END RETURN ABORT.CHECK: ABORT = FALSE IF NOT(ABORT.FLAG) THEN RETURN INPUT ABORT, -1 IF NOT(ABORT) THEN RETURN INPUT ABORT, 1 ABORT = UPCASE(ABORT) IF ABORT = 'Q' THEN RETURN * Stopped at line %i CALL *UVPRINTMSG(001229,LNUM) INPUT ABORT, 1 ABORT = UPCASE(ABORT) IF ABORT = 'Q' THEN RETURN ABORT = FALSE RETURN AT.INSERT: LOCATE X IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE AT.LIST = INSERT(AT.LIST, AT.LOC, 0, 0, X) AT.SUB = INSERT(AT.SUB, AT.LOC, 0, 0, Y) RETURN END AT.SUB = REPLACE(AT.SUB, AT.LOC, 0, 0, Y) RETURN * SJE SPARs 3002891 and 3004396 23 Apr 84 * Give warning message and return to caller who will return to GET.CMD ASAP. OVERFLOW: PRINT PRINT @SYS.BELL:'Memory overflow, one line of data may be lost. FILE as soon' PRINT 'as possible to prevent further loss and re-EDit.' OVERFLOW.FLAG = 1 RETURN * END