Trailing-Edge
-
PDP-10 Archives
-
TRAFFIC-20_V4_840514
-
traffic-source/tfrcob.mac
There are 2 other files named tfrcob.mac in the archive. Click here to see a list.
TITLE TFRCOB - COBOL ROUTINES FOR TFR
;COPYRIGHT (C) 1980, 1981, 1983 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
IF1 <PRINTX TFRCOB-20 Version 4(200)>
SEARCH MONSYM,MACSYM
SEARCH TFRUNV
IFNDEF SEG%LOW,< TWOSEG 400000>
SALL
;INTERNALS AVAILABLE TO MACRO PROGRAMS
INTERN OLDTT,OLDCR,OLDAR,OLDMD,OLDPR,OLDRN,OLDLC,OLDCC,OLDUD
INTERN NEWRND,SCNUPD,NEWMMS,NEWNSJ,NEWCHM,HIFLD
REMARK ASSEMBLY SWITCHES
IFNDEF FT%LAN, <FT%LAN==0> ;DEFAULT TO ENGLISH MESSAGES
;SEE MESSAGE STRINGS FOR OTHER VALUES
IFNDEF FT%ARG, <FT%ARG==1> ;CHECK NUMBER OF ARGUMENTS IF 1
;DON'T CHECK IF 0
IFNDEF FT%V05, <FT%V05==0> ;SET FT%V05 TO 1 TO ENABLE VT05
;CODE - NOTE - THIS IS NOT SUPPORTED.
IFNDEF FT%V50, <FT%V50==0> ;SET FT%V50 TO 1 TO ENABLE VT50H
;CODE - NOTE - THIS IS NOT SUPPORTED.
IFNDEF FT%V52, <FT%V52==0> ;SET FT%V52 TO 1 TO ENABLE VT52
;CODE - THIS IS SUPPORTED.
IFNDEF FT%V10, <FT%V10==1> ;SET FT%V10 TO 1 TO ENABLE VT100
;CODE - THIS IS SUPPORTED.
IFE FT%V05+FT%V50+FT%V52+FT%V10,<PRINTX ?No terminal support selected>
;The following defines the default terminal. If not
;defined in a prefix file, this is taken to be the
;most sofisticated of the terminals allowed.
IFNDEF %VTDEF,<
IFN FT%V05,<%VTDEF==%VT05>
IFN FT%V50,<%VTDEF==%VT50H>
IFN FT%V52,<%VTDEF==%VT52>
IFN FT%V10,<%VTDEF==%VT100>
>
;The following swithces represent default settings and some can be
;changed with a call to TFRSYS.
IFNDEF OLD%TT, <OLD%TT==0> ;0 = Only set the terminal
; characteristics on startup or
; on demand from the user.
;-1 = Set terminal characteristics
; on every call to TFRCOB.
IFNDEF OLD%CR, <OLD%CR==0> ;0 = Use an END-INDICATOR of 5
; for carriage return.
;-1 = Use an END-INDICATOR of 3.
IFNDEF OLD%AR, <OLD%AR==0> ;0 = Left arrow acts as backspace
; Right arrow acts as tab.
;-1 = Arrows acts as carriage return.
IFNDEF OLD%UD, <OLD%UD==0> ;0 = Up/down arrows act as carriage
; return.
;-1 = Arrows give separate terminators.
IFNDEF OLD%MD, <OLD%MD==0> ;0 = Do not declare a MASTER-DUPE
; field filled if OPTIONAL and
; tabbed over.
;-1 = Always flag MASTER-DUPE
IFNDEF OLD%PR, <OLD%PR==0> ;0 = Reset field parameters from the
; form file on each init.
;-1 = Make all changes to a field
; permanent.
IFNDEF OLD%RN, <OLD%RN==0> ;0 = Rewrite numeric fields right
; justified.
;-1 = Do not justify numeric fields.
;(This is useful for experienced users
;or on slow terminals.)
IFNDEF OLD%LC, <OLD%LC==-1> ;0 = Lower case is not allowed
;-1 = Lower case is allowed.
IFNDEF OLD%CC, <OLD%CC==0> ;0 = Don't trap control-C.
;-1 = Control-C can be trapped.
IFNDEF BRK%128, <BRK%128==-1> ;0 = Do not use 128 break set.
;-1 = Use 128 break set (TOPS-20 V4)
IFNDEF NEW%RND, <NEW%RND==0> ;0 = Allow rendition to happen.
;-1 = Don't do rendition.
IFNDEF NEW%MNY, <NEW%MNY==0> ;0 = Full version 4 operation in
; MONEY fields etc.
;-1 = V2A operation (ignore D.P.)
IFNDEF NEW%MMS, <NEW%MMS==0> ;0 = Prompt and wait during MS write
;-1 = Write all in one go
IFNDEF NEW%CHM, <NEW%CHM==-1> ;0 = Cursor home after every operation
;-1 = Don't home cursor.
IFNDEF NEW%SUD, <NEW%SUD==-1> ;0 = Update screen on every call.
;-1 = Update screen only when necessary
IFNDEF NEW%NSJ, <NEW%NSJ==0> ;0 = Only justify numeric subfields if
; the whole field is numeric.
;-1 = Always justify numeric subfields.
SUBTTL DEFINITIONS
;OPDEFS
OPDEF PJRST [JRST] ;JRST TO ROUTINE WHICH RET'S
OPDEF EXTEND [123000,,000000] ;FOR KL
OPDEF CVTBDO [012000,,000000] ;CONVERT BINARY TO DEC
OPDEF MOVSLJ [016000,,000000] ;FOR KL
OPDEF MOVSRJ [017000,,000000] ;FOR KL
OPDEF MOVST [015000,,000000] ;TRANSLATE
OPDEF CMPSE [002000,,000000] ;FOR KL
OPDEF CMPSG [007000,,000000]
OPDEF CMPSL [001000,,000000]
OPDEF ADJBP [IBP 0,0(0) ] ;FOR KL
;AC DEFINITIONS
Z=0
A=1
B=2
C=3
D=4
E=5
INT.A=6 ;FIELD SPECIFIER / ARG POINTER
INT.B=7 ;ARG LENGTH
INT.C=10 ;# CHARACTERS READ
PRM=11 ;PARAMETER FLAGS
F=12
G=13
ARG=16 ;ARGUMENT POINTER
P=17
;SOME STANDARD CHARACTERS
BACKSP=10 ;ASCII VALUE FOR BACKSPACE
TAB=11 ;TAB
LF=12 ;LINE FEED
CR=15 ;CARRIAGE RETURN
ESC=33 ;ESCAPE
SPACE=40 ;SPACE
ZERO=60 ;ASCII ZERO
RUBOUT=177 ;ASCII VALUE FOR RUBOUT
;OPTIMIZER PARAMETERS AND FLAGS
%OTAL1==1B18 ;TOP HALF OF TALL LINE
%OTAL2==1B19 ;BOTTOM HALF OF TALL LINE
%OWIDE==1B20 ;WIDE LINE
%OLSET==1B21 ;TALL/WIDE SET FOR LINE
%OLCLR==1B22 ;TALL/WIDE BEING CLEARED
%OMULT==1B23 ;LINE IS IN SCROLLED AREA
%OBLNK==1B27 ;CHARACTER HAS BEEN BLANKED
%OCHNG==1B28 ;CHARACTER HAS CHANGED
%OFRCE==1B0 ;FORCE NEW ATTRIBUTES OUT (SET IN CATTR)
;REDEFINE TXTTAB OFFSETS
.RDDBP=0 ;BYTE POINTER
.RDDBC=1 ;BYTE COUNT
.RDBFP=2 ;BACKUP BYTE POINTER
SUBTTL MACROS
;LOAD - This macro loads register REX with the data in the byte
;pointed to by PTR using temporary register TMP. If a base pointer,
;SRC, is not specified, FLDPTR will be used as the offset.
DEFINE LOAD(REX,PTR,TMP<E>,SRC<FLDPTR>)
<
MOVE TMP,PTR
ADD TMP,SRC
LDB REX,TMP
>
;STORE - store the contents of register REG in the byte pointed
;to by PTR using TMP as the temporary register and FLDPTR as the
;offset.
DEFINE STORE(REG,PTR,TMP<E>) ;STORE A VALUE AWAY
<
MOVE TMP,PTR ;GET PTR AGAIN
ADD TMP,FLDPTR ;POINT TO CORE TABLE
DPB REG,TMP ;& SAVE THERE TOO.
>
;TBL - define table entries for use by TFRCHG.
DEFINE TBL(ENT,PTR)
< [ASCIZ ^ENT^],,PTR >
;.CALL. - This allows a routine to be CALLed from a COBOL program.
DEFINE .CALL.
< SKIPA 777 ;ALLOW 'CALL' STATEMENTS
XWD [0],%FILES> ;TO WORK.
;ENTER - allows a routine to be CALLed from a COBOL program,
;checks that the number of arguments supplied is in the range
;NUMARG to NUMAR2 or is equal to NUMARG if NUMAR2 is zero, and
;finally, if VETCHK is not blank, checks to see if the routine
;is being called from a VET subroutine.
DEFINE ENTER(NAME,NUMARG,NUMAR2,VETCHK)
<
IFNB <NAME>,<
ENTRY TFR'NAME,FRM'NAME
TFR'NAME:: ;DEFINE ENTRY POINT
FRM'NAME::
>
.CALL. ;COBOL 'CALL' ENTRY.
IFNB <NUMARG>,<
JSP E,TFRENT ;CALL COMMON ENTRY CHECKER
[ASCIZ /NAME/] ;NAME FOR ERROR MESSAGES
X=0
IFNB <NUMAR2>,<X=NUMAR2>
IFNB <VETCHK>,<X=X+400000>
XWD X,NUMARG ;ARGUMENT COUNT AND VET FLAG
>> ;END ENTER
;GETITM - calls a subroutine to retrieve the required string item
;from the argument list. The argument is given by OFFSET and is
;assumed to be a string unless ANY is non-blank in which case only
;string descriptors produce a string and other argument types
;produce a number.
DEFINE GETITM(OFFSET,ANY)
<
IFB <OFFSET>,<SETZ INT.A,>
IFNB <OFFSET>,<
IFB <ANY>,<HRRZI INT.A,OFFSET>
IFNB <ANY>,<HRROI INT.A,OFFSET>>
CALL GETARG
>
;DISPATCH - causes a subroutine to be called depending on the
;terminal type being used. The subroutine called is $type'RTN.
DEFINE DISPATCH(RTN)
<
PUSH P,ARG
JSP ARG,$DISPAT
$00'RTN
IFN FT%V05,< $10'RTN > ;VT05
IFE FT%V05,< [RET] >
IFN FT%V50,< $20'RTN > ;VT50H
IFE FT%V50,< [RET] >
IFN FT%V52,< $20'RTN > ;VT52
IFE FT%V52,< [RET] >
IFN FT%V10,< $30'RTN
$30'RTN > ;VT132 = VT100
IFE FT%V10,< [RET]
[RET] >
>
SUBTTL FORM DATA POINTERS
PTRGEN
CURFRM: POINT 7,FRMFIL ;POINTER TO CURRENT FORM STRING.
;THE FOLLOWING BREAK MASKS HAVE BEEN DEFINED FOR TOPS-20 VERSION 4
;AND USE THE 128 CHARACTER BREAK FACILITY.
;CONSTANTS:
ALLMSK=777777,,777777 ;NOTHING LEGAL
NUMMSK=777774,,001777 ;NUMBERS ONLY LEGAL
LETMSK=400000,,000777 ;LETTERS ONLY
SPCMSK=377777,,777777 ;ALLOW BLANK TO BE LEGAL
MNZMSK=000000,,001777 ;SPACE OR NUMBERS ARE LEGAL
YNFMSK=777767,,775777 ;Y OR N ONLY
MSK.NO: 4 ;MASK FOR NUMBERS ONLY
ALLMSK
NUMMSK
ALLMSK
ALLMSK
MSK.AO: 4 ;ALPHABETIC ONLY
ALLMSK
ALLMSK
LETMSK
LETMSK
MSK.AB: 4 ;MASK FOR ALPHABETICS ONLY WITH SPACE
ALLMSK
SPCMSK
LETMSK
LETMSK
MSK.AN: 4 ;MASK FOR ALPHANUMERIC ONLY
ALLMSK
NUMMSK
LETMSK
LETMSK
MSK.AZ: 4 ;MASK FOR ALPHANUMERIC AND SPACE
ALLMSK
MNZMSK
LETMSK
LETMSK
MSK.XX: 4 ;MASK FOR ALPHANUMERICS & PUNCTUATION
ALLMSK
0
0
37
MSK.YN: 4 ;MASK FOR YES/NO FIELD
ALLMSK
ALLMSK
YNFMSK
YNFMSK
MSKTAB: ;TABLE OF ADDRESS AND FLAGS
XWD MSK.XX,CONCHR+FCCCHR ;A-N-P
XWD MSK.NO,CONCHR+FCCCHR+PNCCHR+ALPCHR+SPCCHR ;NUMERIC
XWD MSK.AO,CONCHR+FCCCHR+PNCCHR+NUMCHR+SPCCHR ;ALPHA
XWD MSK.AN,CONCHR+FCCCHR+PNCCHR+SPCCHR ;A-N
XWD 0,0 ;DUMMY
XWD MSK.NO,CONCHR+FCCCHR+PNCCHR+ALPCHR+SPCCHR ;NUMERIC
XWD MSK.AB,CONCHR+FCCCHR+PNCCHR+NUMCHR ;ALPHA+SPACE
XWD MSK.AZ,CONCHR+FCCCHR+PNCCHR ;A-N +SPACE
MSKYNF: XWD MSK.YN,CONCHR+FCCCHR+PNCCHR+NUMCHR+SPCCHR+100 ;YES/NO
REMARK INTERNALLY GENERATED ERROR MESSAGES FOLLOW (INTERR)
;
;THE FOLLOWING MESSAGES ARE AVAILABLE IN ENGLISH, FRENCH, GERMAN, AND DUTCH.
;THE CHOICE IS MADE BY SETTING FT%LAN TO ONE OF THE FOLLOWING VALUES:
;
; 0 - ENGLISH
; 1 - FRENCH
; 2 - GERMAN
; 3 - DUTCH
;
IFE FT%LAN-0,<
MSG.NN: ASCIZ ^Enter numbers only^
MSG.NA: ASCIZ ^Enter letters or numbers only^
MSG.AO: ASCIZ ^Enter letters only^
MSG.AP: ASCIZ ^Enter any character^
MSG.TO: ASCIZ ^" to "^
MSG.RQ: ASCIZ ^A value must be entered^
MSG.FF: ASCIZ ^Field must be filled^
MSG.ID: ASCIZ ^Incorrect date^
MSG.YN: ASCIZ ^Enter "Y" or "N" only^
MSG.BU: ASCIZ ^Can't back up further^
MSG.ES: ASCIZ ^Invalid character after <ESC>^
MSG.LR: ASCIZ ^Lower limit is ^
MSG.UR: ASCIZ ^Upper limit is ^
MSG.NT: ASCIZ ^This is not an auto-tab field^
MSG.NX: ASCIZ ^Enter "RETURN", "TAB", or "DELETE" only^
MSG.IV: ASCIZ ^Incorrect value entered^
>
IFE FT%LAN-1,<
MSG.NN: ASCIZ ^Donnees numerique uniquement^
MSG.NA: ASCIZ ^Donnees alphabetique ou numerique uniquement^
MSG.AO: ASCIZ ^Donnees alphabetique uniquement^
MSG.AP: ASCIZ ^Tous types de donnees ^
MSG.TO: ASCIZ ^" a "^
MSG.RQ: ASCIZ ^Donnees obligatoires^
MSG.FF: ASCIZ ^Champ obligatoire^
MSG.ID: ASCIZ ^Date erronee^
MSG.YN: ASCIZ ^"Y" ou "N" uniquement^
MSG.BU: ASCIZ ^Pas d'acces au champ precedent^
MSG.ES: ASCIZ ^Caractere invalide suite a <ESC>^
MSG.LR: ASCIZ ^Limite inferieure ^
MSG.UR: ASCIZ ^Limite superieure ^
MSG.NT: ASCIZ ^Ce n'est pas un champ AUTO-TAB^
MSG.NX: ASCIZ ^Donnees "RETURN", "TAB", ou "DELETE" uniquement^
MSG.IV: ASCIZ ^Valeur erronee^
>
IFE FT%LAN-2,<
MSG.NN: ASCIZ ^Nur Ziffern erlaubt^
MSG.NA: ASCIZ ^Nur Zeichern oder Ziffern erlaubt^
MSG.AO: ASCIZ ^Nur Zeichern erlaubt^
MSG.AP:
MSG.TO: ASCIZ ^" zu "^
MSG.RQ: ASCIZ ^Nur Zahlen erlaubt^
MSG.FF: ASCIZ ^Dieses Feld muss ausgefuellt werden^
MSG.ID: ASCIZ ^Ungueltiges Datum^
MSG.YN: ASCIZ ^Erlaubt ist nur "Y" (yes) oder "N" (no)^
MSG.BU: ASCIZ ^Felduebershreitung^
MSG.ES: ASCIZ ^Ungueltiges Zeichen nach <ESC>^
MSG.LR: ASCIZ ^Minimum ist ^
MSG.UR: ASICZ ^Maximum ist ^
MSG.NT: ASCIZ ^Dieses Feld kann nicht automatisch mit <TAB> uerberspungen werden^
MSG.NX: ASCIZ ^Nur "RETURN", "TAB", oder "DELETE" erlaubt^
MSG.IV: ASCIZ ^Ungueltiges Zahl^
>
IFE FT%LAN-3,<
MSG.NN: ASCIZ ^Alleen getallen invullen^
MSG.NA: ASCIZ ^Alleen letters of getallen invullen^
MSG.AO: ASCIZ ^Alleen letters invullen^
MSG.AP: ASCIZ ^Alleen ^
MSG.TO: ASCIZ ^" a "^
MSG.RQ: ASCIZ ^Hier moet iets ingevuld worden^
MSG.FF: ASCIZ ^Veld moet helemaal ingevuld worden^
MSG.ID: ASCIZ ^Ongeldige datum^
MSG.YN: ASCIZ ^Alleen "Y" of "N" invullen^
MSG.BU: ASCIZ ^Sorry, kan niet verder terug^
MSG.ES: ASCIZ ^Ongeldig teken na <ESC>^
MSG.LR: ASCIZ ^Ondergrens is ^
MSG.UR: ASCIZ ^Bovengrens is ^
MSG.NT: ASCIZ ^Dit is geen AUTO-TAB veld^
MSG.NX: ASCIZ ^Alleen "RETURN", "TAB", of "DELETE" invullen^
MSG.IV: ASCIZ ^Ongeldige waarde ingevoerd^
>
SUBTTL ERROR CODES AND TERMINATOR CODES
ERR.BA==1 ;BAD ARGUMENT IN CALL
ERR.UF==2 ;UNDEFINED FILE-NAME
ERR.NF==3 ;FIELD-ID WAS NOT FOUND
ERR.ND==4 ;FIELD-ID IS NOT DISPLAYED
ERR.IA==5 ;INVALID ATTRIBUTE (TFRCHG)
ERR.WL==7 ;WRONG LENGTH RECD DESC IN PGM.
ERR.DP==^D8 ;PMAP FAILURE FROM FORM FILE.
ERR.NC==^D10 ;LIBOL DID NOT RETURN ENOUGH PAGES.
ERR.IV=^D11 ;TFRSYS CALL WITH BAD VARIABLE#
ERR.NV=^D12 ;TFRSYS CALL WITH NEW-VALUE NOT 0,-1.
ERR.VA=^D13 ;VET ROUTINE NOT ALLOWED ACCESS
ERR.EM=^D14 ;END OF MULTIPLE SECTION ON READ AFTER WRITE
ERR.ML==^D15 ;ATTEMPT TO READ OR WRITE FIELDS IN M.S.
ERR.OV==^D16 ;USING OLD VERSION OF TFR COMPILER
ERR.NL==^D17 ;NO TFRLPT: DEFINED ON CALL TO TFRWTL
ERR.NO==^D18 ;OPTIMISER IS TURNED OFF
ERR.TT==^D19 ;TERMINAL TYPE NOT ALLOWED IN FORM
TRM.LN==1
TRM.TB==2
TRM.LF==3
TRM.FF==4
TRM.CR==5
TRM.UA==6 ;UP-ARROW
TRM.DA==7 ;DOWN-ARROW
TRM.VE==10 ;VET ROUTINE FORCED EXIT
SUBTTL TFRCHG ATTRIBUTE TABLES
CGTBL: CGTBLE-.-1,,CGTBLE-.-1
TBL <ALLOW-LOWERCASE>,CGALC
TBL <ALPHABETIC>,CGAB
TBL <ALPHANUMERIC>,CGAN
TBL <ANY-CHARACTER>,CGANY
TBL <AUTO-TAB>,CGAUTO
TBL <BLINKING>,CGBL
TBL <BOLD>,CGBO
TBL <ECHO>,CGECHO
TBL <FILLER>,CGFILL
TBL <FULL-FIELD>,CGFULL
TBL <LEADING-ZEROS>,CGLEAD
TBL <LOWER-RANGE>,CGLR
TBL <MASTER-DUPE>,CGMD
TBL <NO-AUTO-TAB>,CGNATO
TBL <NO-DUPE>,CGND
TBL <NO-ECHO>,CGNE
TBL <NO-LEADING-ZEROS>,CGNLZR
TBL <NO-SPACES>,CGNSPC
TBL <NO-RENDITION>,CGN
TBL <NORMAL-VIDEO>,CGNR
TBL <NOT-FULL-FIELD>,CGNFUL
TBL <NUMERIC>,CGN
TBL <OPTIONAL>,CGO
TBL <PREVIOUS-DUPE>,CGPD
TBL <PROTECTED>,CGP
TBL <RAISE-LOWERCASE>,CGRLC
TBL <REQUIRED>,CGR
TBL <REVERSE-VIDEO>,CGRV
TBL <SECURE>,CGNE
TBL <SPACES>,CGSPC
TBL <UNDERLINED>,CGUS
TBL <UNDERSCORE>,CGUS
TBL <UNPROTECTED>,CGUP
TBL <UPPER-RANGE>,CGUR
CGTBLE:
SUBTTL TERMINAL INFORMATION TABLES
TRMLC: ;MAXIMUM LINES AND COLUMNS FOR TERMINAL
0
^D20,,^D72 ;VT05
^D12,,^D80 ;VT50H
^D24,,^D80 ;VT52
^D24,,^D80 ;VT100
^D24,,^D132 ;VT132 (VT100 IN 132 COLUMN MODE)
TRMDCA: ;CHARACTER COUNT FOR DIRECT CURSOR ADDRESS
0
3 ;VT05
4 ;VT50H
4 ;VT52
7 ;VT100
8 ;VT132
TRMLOG: ;LOGICAL NAMES FOR TERMINALS
IFN FT%V05,< [ASCIZ /VT05/]>
IFE FT%V05,< 0 >
IFN FT%V50,< [ASCIZ /VT50H/]>
IFE FT%V50,< 0 >
IFN FT%V52,< [ASCIZ /VT52/]>
IFE FT%V52,< 0 >
IFN FT%V10,< [ASCIZ /VT100/]
[ASCIZ /VT132/]>
IFE FT%V10,< 0
0 >
NUMTRM=.-TRMLOG
;MAXIMUM SCREEN SIZE FOR OPTIMISER WORK:
MAXCOL=^D132
MAXLIN=^D24
SUBTTL COMMON ENTRY/EXIT ROUTINES
;COMMON ENTRY ROUTINE
TFRENT: ;CHECK NUMBER OF ARGUMENTS ETC
;ON ENTRY E POINTS TO A NAME AND
;THE NUMBER OF ARGUMENTS (SEE ENTER MACRO)
SETZM SUBCNT ;CLEAR A FLAG
SKIPGE 1(E) ;IS VET ACCESS ALLOWED?
JRST [SKIPN VETCAL ; NO - SEE IF WE CAN PROCEED
JRST .+1 ; YES - OK
MOVE A,(E) ; NO - TELL THE USER
PSOUT
TMSG < may not be called from a VET routine
>
RET] ; AND RETURN TO CALLER
SKIPN FTARGS ;ARE WE CHECKING ARGUMENT COUNT?
JRST TFREN2 ; NO
HLRE B,-1(ARG) ;YES - GET THE COUNT
MOVMS B ;POSITIVE
HRRZ D,1(E) ;GET THE FIRST LEGAL COUNT
HLRZ C,1(E) ;THIS IS THE SECOND LEGAL COUNT
TRZ C,(1B0) ;IN CASE VET CHECKING PASSED OK
CAIE B,(C) ;COMPARE AGAINST LEGAL LIMITS
CAIN B,(D)
JRST TFREN2 ;ALL OK
MOVE A,(E) ;POINT TO NAME
PSOUT
TMSG < called with wrong number of arguments
>
RET ;BACK TO CALLER
TFREN2:
SETZM CURFLD ;MAKE SURE FIELD CAN BE FOUND
SKIPE OLDTT ;IF CHECKING EVERY TIME
SETOM DOCHK ;THEN MAKE SURE IT HAPPENS
JRST 2(E) ;RETURN TO MAIN STREAM
;COMMON EXIT ROUTINES
SKPRT3: AOS (P)
SKPRT2: AOS (P)
SKPRET: AOS (P)
RET
;General purpose argument fetch routine. Call with offset from (ARG)
;in INT.A, left half set to -1 if string or value can be returned.
;If the left half of INT.A is positive, the argument should be a data array.
;The routine checks the type of the argument passed and does the following:
;
; Type Expect string only Expect any
; ------ -------------------- -----------------------
; 0 INT.B=len, INT.A=ptr INT.B=0, INT.A=value
; 2 INT.B=len, INT.A=ptr INT.B=0, INT.A=value
; 4 INT.B=len, INT.A=ptr INT.B=0, INT.A=value
; 15 INT.B=len, INT.A=ptr INT.B=len, INT.A=ptr
; 17 INT.B=len, INT.A=ptr INT.B=len, INT.A=ptr
;
;This allows for calls from FORTRAN, MACRO, and COBOL programs.
;When a string argument is passed with a type of 0, 2, 4, or 17 it
;must be ASCIZ.
GETARG:
PUSH P,ARG ;SAVE THE POINTER
ADDI ARG,(INT.A) ;OFFSET TO RIGHT PLACE
LDB INT.B,[POINT 4,(ARG),12] ;GET TYPE
CAIN INT.B,15 ;COBOL STRING?
JRST GTA.3 ; YES - HANDLE IT
CAIN INT.B,17 ;FORTRAN STRING?
JRST GTA.1 ; YES - LIKE ANY STRING
SKIPL INT.A ;EXPECT STRINGS ONLY?
JRST GTA.1 ; YES - GET THE POINTER
MOVE INT.A,@(ARG) ;GET A VALUE
SETZ INT.B,
JRST GTA.4 ;END
GTA.1: ;EXPECT A STRING
SETZ INT.B, ;CLEAR A COUNTER
HRRI INT.A,@(ARG) ;GET THE ADDRESS
TLNE INT.A,377777 ;IS IT A DATA AREA (TFRINI)?
JRST [HRLI INT.A,(POINT 7,0) ;MAKE POINTER
JRST GTA.4]
HRLI INT.A,(POINT 7,0) ;AND MAKE A POINTER
PUSH P,INT.A ;SAVE THE POINTER WHILE WE COUNT
GTA.2:
ILDB ARG,INT.A ;GET A BYTE
SKIPE ARG ;END ON NULL
AOJA INT.B,GTA.2 ;LOOP FOR MORE
POP P,INT.A ;RESTORE THE POINTER
JRST GTA.4
GTA.3: ;COBOL TYPE STRING POINTER
MOVEI INT.B,@(ARG) ;POINT TO THE DESCRIPTOR
MOVE INT.A,0(INT.B) ;GET THE BYTE POINTER
HRRZ INT.B,1(INT.B) ;AND THE LENGTH
GTA.4:
POP P,ARG
RET
SUBTTL TFRSTA - START EXECUTION
; TFRSTA should be called once every time a program executes.
; It presets all variables associated with the optimiser to
; the orriginal state. This routine is required for programs
; which are re-entrant (FORTRAN and MACRO) and is not needed
; for COBOL programs unless a terminal logical name is to be
; passed to TFRCOB for use as the form screen.
;
; CALL TFRSTA ([logical-terminal-name])
ENTER STA,0,1,X ;AN ARGUMENT, NOT CALL. FROM VET
SETZM LOGNAM ;CLEAR THIS FLAG FOR NOW
JUMPE B,STA.1 ;0 = NO ARGUMENT
GETITM ;GET A POINTER TO THE LOGICAL NAME
MOVEM INT.A,LOGNAM ;SAVE IT AS A FLAG
STA.1:
SETZM DATHDR ;RESET MEMORY ALLOCATION STATE
SETZM NUMWDS
SETZM .OSCRN
SETZM GOTFIL ;RESET FORM FILE INDICATORS
SETZM DATJFN
SETZM INIFLG ;INITIALISATION IS REQUIRED
SETZM TTOPN ;FORCE THE TERMINAL OPEN
CALL $TTOPN
SKIPN NOCORE ;ERROR IF NO CORE AVAILABLE
RET
STA.2:
TMSG <
TFRCOB - No core available for dynamic tables>
JRST TFRSTP ;CLOSE IT ALL DOWN
SUBTTL TFRSTP - CLOSE DOWN OPERATION
; TFRSTP is a routine required for the orderly shutdown of
; the screen handling routines. It releases memory, clears
; the screen, and resets the terminal. Whilst it is only
; required for re-entrant programs, it is a good idea to
; call it at the end of any program.
;
; CALL TFRSTP no arguments
ENTER STP
PUSH P,OLDCC
SETZM OLDCC ;SWITCH OFF CONTROL-C
CALL $TTCLS ;CLEAR SCREEN AND RESET TERMINAL
MOVE A,TTJFN ;DEASSIGN THE TERMINAL?
CAIN A,.PRIOU
JRST STP.1
CLOSF ;CLOSE THE FILE
ERJMP .+1 ; DON'T CARE NOW
MOVE A,TRMDES ;GET THE TERMINAL DESIGNATOR
RELD ;RELEASE IT
ERJMP .+1 ;DON'T REALY CARE
STP.1:
POP P,OLDCC
SKIPE A,LPTJFN ;IF THE "LPT" IS STILL OPEN
CLOSF ; THEN CLOSE IT
JFCL
SETZM LPTJFN ;MAKE SURE ITS DEAD
SETZM INIFLG ;INIT REQUIRED FOR FURTHER USE
CALL OPTFRE ;FREE OPTIMISER MEMORY
JFCL
SETZM DATJFN ;FORGET ABOUT ANY FORM FILE
SETZM GOTFIL
MOVE A,NUMWDS ;GET NUMBER OF WORDS OF MEMORY USED
MOVE B,DATHDR ;AND THE STARTING ADDRESS
CALL FREMEM ;AND RETURN IT TO MONITOR
SETZM NUMWDS ;AND REMEMBER THE FACT
SETZM DATHDR
RET
SUBTTL TFRINI - INITAILIZE CALL FROM COBOL
; TFRINI must be called when a new form file is to be displayed
; and at least once in every program.
;
; CALL TFRINI (data-record-pointer,
; form-file-specification,
; field-or-section-identifier,
; error-code)
ENTER INI,4,,X
CALL $TTOPN ; THEN OPEN IT (SETS TTOPN TO -1).
SKIPE NOCORE ;FAIL IF NO CORE AVAILABLE
JRST STA.2
CALL $SBEGIN ;SETUP THE OUTPUT BUFFER
SETZM TOPBOT ;CLEAR TOP/BOTTOM INDICATOR
SETOM COBCAL ;INDICATE COBOL CALL
HRLZI INT.A,1 ;FLAG DATA ARRAY HERE
CALL GETARG ;AND GET ITS ADDRESS
MOVEM INT.A,RECPTR ;AND SAVE IT
HRRZM INT.B,RECLEN ;SAVE THE LENGTH OF THE RECORD
LDB A,[POINT 4,1(ARG),12] ;GET TYPE OF ARGUMENT 1
SETZM COBAPP ;ASSUME ITS NOT COBOL
CAIN A,15 ;IF IT IS COBOL STRING
SETOM COBAPP ; THEN FLAG IT FOR LATER
CALL CHKFORM ;USING CURRENT FORM FILE ?
JRST INI.9 ;GOOD FORM NAME BUT NO FIELDS IN IT.
JRST INI.10 ;COULD NOT LOAD THE FORM.
CALL $TTSTR ;EVERYTHING IS IN GOOD SHAPE.
GETITM 2,ANY ;GET THE FIELD IDENTIFIER
SKIPN INT.A ;IF THIS IS THE WHOLE FORM
CALL INI.14 ; THEN SEE IF WE MUST LOSE A HIDDEN SECT
CALL INI.11 ;REINIT THE MULTIPLE SECTION (MAYBE)
SKIPA
INITAL: ;INTERNAL CALL TO INIT EVERYTHING
;INT.A MUST HAVE FIELD PTR
SETZM COBCAL ;INDICATE INTERNAL CALL
INI.1: ;LOOP HERE ON COBOL CALL
CALL FIND
JRST INI.9 ;NOT FOUND
JRST INI.8 ;NO MORE FIELDS
SKIPE COBCAL ;IF WE ARE IN AN INIT CALL
JRST INI.20 ;CALLED VIA TFRINI
CALL GETFLD ;GET FIELD ATTRIBUTES
SKIPE HXFLAG ;IF HIDDEN FIELDS CAN BE CLEARED
TXZ PRM,%HIDE ; THEN SAY SO
TXNE PRM,%MULT ;IF MULTIPLE,
CALL GETMFD ; THEN SET THE POINTERS CORRECTLY
TXNE PRM,%MSDUP ;IF MASTER DUPE IS ON
TXNN PRM,%HIDE ; AND ITS NOT HIDDEN
SKIPA
TXZ PRM,%PRDUP ; THEN RESET TO INDICATE NOT FILLED.
TXNE PRM,%PROT ;IF PROTECTED OR DEFAULT DATE
JRST INI.2 ; THEN DON'T OVERWRITE THE DATA
TXNE PRM,%DFDT ;IF THIS IS A DISPLAYED, UNPROTECTED
TXNE PRM,%DSPLY ; DEFAULT DATE FIELD
SKIPA ; THEN CLEAR IT
JRST [CALL WRITE ; IF NOT DISPLAYED, THEN WRITE IT
CALL TWRITE ; AND ITS TEXT
JRST INI.5]
TXNE PRM,%HIDE ;IF HIDDEN AND PREVIOUS
TXNN PRM,%PRDUP
SKIPA
JRST [CALL WRITE ; THEN WRITE IT OUT
CALL FILL ; AND FILL IT AS REQUIRED
CALL TWRITE ; ALSO WRITE ITS TEXT
TXO PRM,%DSPLY ;MAKE SURE ITS FLAGGED AS DISPLAYED
JRST INI.7]
CALL FORMAT ;FORMAT FIELD IN WORKING-STORAGE
CALL WS2VAL ; AND THEN REFORMAT INTERNAL VALUE.
TXNN PRM,%DSPLY ;IF FIELD IS NOT ON THE SCREEN
JRST INI.3 ; THEN SET IT UP
CALL BLANK ; MERELY BLANK IT.
JRST INI.6
INI.2:
TXNE PRM,%DSPLY ;IF THE FIELD IS DISPLAYED
JRST INI.6 ; THEN CONTINUE
CALL WRITE ;ELSE WRITE IT OUT
INI.3:
CALL TWRITE ;WRITE TEXT IF AVAILABLE
TXNN PRM,%PROT ;IF NOT PROTECTED
JRST [TXNE PRM,%HIDE ;IF HIDDEN COMING ON LINE
TXNN PRM,%PRDUP ; AND ITS NOT PREVIOUS
SETZM FNUMRD ; THEN ALLOW ALL TO BE FILLED
JRST .+1]
CALL FILL ;FILL THE FIELD IF REQUIRED
INI.5: ;INDICATE FIELD IS ON THE SCREEN
TXO PRM,%DSPLY
INI.6:
SETZ A,
TXNN PRM,%PROT!%DFDT ;DON'T SAY PROT FIELDS ARE EMPTY!!
CALL SV.NUMRD
CALL STRPRM ;STORE PARAMETERS BACK
INI.7:
SKIPE HXFLAG ;IF THE FLAG WAS SET
JRST [LOAD E,.DPARM ;THEN WE MUST MAKE SURE THAT THE
TXNE E,%HIDE ; HIDDEN FLAG IS CORRECTLY SET IN
TXO PRM,%HIDE ; PRM BEFORE WE STORE IT
JRST .+1]
CALL $SCHKPNT ;WRITE OUT BUFFER IN ROOM NEEDED
SKIPE COBCAL ;COBOL CALL ?
JRST INI.1 ;YES--GO FOR MORE FIELDS
JRST INITAL ;NO--RETURN FOR NEXT FIELD,
INI.8: ;NO MORE FIELDS TO INITIALIZE
SKIPN SCNUPD ;IF UPDATING EVERY TIME
CALL $SEND ; THEN SEND TERMINAL MESSAGE.
SETZB Z,CURERR ;INITIALIZE TO 'NO ERROR'.
SKIPE LENERR ;ANY LENGTH ERRORS
JRST [SETZM LENERR
MOVEI Z,ERR.WL
JRST .+1]
SKIPE COBCAL ;SKIP IF NOT COBOL CALL
MOVEM Z,@3(ARG)
RET
INI.9: ;RETURN THE 'NOT FOUND' ERROR
MOVEI Z,ERR.NF
INI.10: ;ERROR RETURN -- CONTENTS OF A INDICATES WHICH.
MOVEM Z,CURERR
SKIPE COBCAL
MOVEM Z,@3(ARG)
RET
INI.11:
SKIPN MSNEW ;IF FIRST TIME
RET
SETZM MSNEW ;NOT FIRST TIME NOW
MOVN A,MLTSEC
SKIPE INT.A ;IF FORM INIT
CAMN INT.A,A ; OR INIT OF M.S.
SKIPN A ; THEN DO THE CLEAR OPERATION
RET
MOVEI B,1
SKIPA A,MLTLOR ;START AT FIRST LINE
INI.12:
ADDI A,1
CAMLE A,MLTHIR ;IF MORE TO DO
PJRST $SEND ;CLEAR IT ON THE SCREEN
CALL $POSIT ;GO TO THE LINE
CALL $ERASE ;CLEAR IT
JRST INI.12 ; THEN CONTINUE
INI.14: ;CLEAR A HIDDEN SECTION ON FORM RE-INIT
SKIPN INT.A,CURHSC ;WAS ONE ON THE SCREEN?
RET ; NO
INI.15:
CALL FIND ;GET THE NEXT FIELD
JRST [ADJSP P,-1
JRST INI.9] ;FIELD NOT FOUND - ERROR
JRST [SETZB INT.A,CURFLD
SETZM CURHSC ;NO HIDDEN SECTIONS AROUND NOW
RET] ;DONE - TIDY UP
CALL GETFLD
TXZ PRM,%DSPLY ;FIELD IS NO LONGER DISPLAYED
CALL STRPRM
CALL ABLANK ;LOSE IT
JRST INI.15 ;AND LOOP
;COME HERE WHEN CALLED VIA TFRINI
INI.20:
CALL GETPRM ;PICK UP PARAMETERS
CALL GETFLD
TXNE PRM,%MSDUP ;IF MASTER DUPE IS ON
TXZ PRM,%PRDUP ;THEN RESET TO INDICATE NOT FILLED
TXNN PRM,%PROT ;IF A PROTECTED FIELD
JRST INI.21 ; NOT
TXNE PRM,%INDEX ;IF INDEX FIELD THEN IT MUST BE CLEARED
JRST INI.22
JRST INI.24 ;THEN CONTINUE
INI.21:
TXNN PRM,%DFDT ;IF DEFAULT DATE (UNPROTECTED)
JRST INI.23 ; NOT
CALL GCURDT ;THEN GET TODAYS DATE
CALL RFORMX ;COPY TO W.S.
TXNE PRM,%HIDE ;IF IT IS HIDDEN
JRST INI.6 ; THEN DON'T WRITE IT
TXNE PRM,%MULT ;IF MULTIPLE
CALL MSDUPL ; THEN DUPLICATE THROUGH THE SECTION
CALL WRITE ;AND WRITE IT ON THE SCREEN
CALL TWRITE ;WRITE TEXT AS WELL IF THERE IS ANY
JRST INI.5 ;AND CONTINUE AS NORMAL
INI.22:
MOVEI A,1 ;PRESET THE BOUNDS FLAGS
MOVEM A,FSTELM
MOVEM A,LSTELM
MOVN A,MLTCNT ;THEN MAKE SURE THAT THE DATA GOES
MOVEM A,MLTELM ;TO THE RIGHT PLACE
MOVE A,MLTLOR ;PRESET TO FIRST LINE
MOVEM A,MLTDSP
CALL GETMFD ;GET CORRECT POINTERS
INI.23:
CALL FORMAT ;FORMAT FIELD IN WORKING-STORAGE
TXNN PRM,%INDEX ;IF NOT INDEX FIELD
SETOM MSINIT ; THEN INDICATE UNPROTECTED INIT
CALL WS2VAL ; REFORMAT INTERNAL VALUE.
TXNE PRM,%MULT ;IF MULTIPLE -
CALL MSDUPL ;THEN DO MOST IN SUBRTN.
SETZM MSINIT
INI.24:
TXNE PRM,%HIDE ;IF EXTERNAL CALL AND HIDDEN
JRST INI.6 ;THEN DON'T WRITE IT OUT
TXNN PRM,%DSPLY ;IF THE FIELD IS NOT ON THE SCREEN
JRST INI.25 ;SET IT UP
TXNN PRM,%PROT ; ELSE IF FIELD IS UNPROTECTED
CALL BLANK ; MERELY BLANK IT.
JRST INI.5
INI.25:
CALL TWRITE ;WRITE TEXT TO SCREEN
TXNE PRM,%PROT ;IF PROTECTED
CALL WRITE ; THEN WRITE THE FIELD AS WELL
TXNN PRM,%PROT ;IF UNPROTECTED
SETZM FNUMRD ; THEN NOTHING READ YET
CALL FILL ;FILL THE FIELD
JRST INI.5
CHKFORM: ;CHECK CALLER'S FORM DESCRIPTION AND OPEN
; NEW FORM FILE IF NECESSARY.
;IF LENGTH = 0, THEN WE HAVE A MEMORY RESIDENT FORM
GETITM 1 ;GET THE POINTER TO THE FILENAME
JUMPE INT.B,CKF.10 ;MEMORY RESIDENT FORM
MOVE B,INT.A ;COPY IT
MOVE A,INT.B ;AND THE LENGTH
SETOM MSNEW ;MAY NEED TO REINIT M.S.
TLNN B,100 ;ASCII ?
JRST CKF.1 ;SIXBIT - SKIP IT
CALL INT72U ;CONVERT ASCII TO U/C
SKIPA
CKF.1:
CALL INT627 ;NO - CONVERT SIXBIT TO ASCII IN INTBUF
MOVEI D,130 ;DEST LENGTH IN BYTES
MOVE E,CURFRM ;BUFFER PTR
SKIPE GOTFIL ;IF NO FILE, THEN NO COMPARE
EXTEND A,[CMPSE ;COMPARE-SKIP EQ
SPACE ;SPACE FILL BOTH
SPACE]
SKIPA ;NOT THE SAME--OPEN NEW FILE.
JRST SKPRT2 ;GIVE GOOD RETURN.
CALL GETFIL ;GET JFN FOR FILE + OPEN
JRST [MOVEI Z,ERR.UF ;UNKNOWN FILE NAME
SETZM GOTFIL ;ON ERROR INDICATE NO FILE NAME.
JRST SKPRET] ;INDICATE UNKNOWN FILE NAME.
CALL MAPIN ;MAPIN THE DATA FILE
JRST SKPRET ;NOT ENOUGH MEMORY FOR FORM.
CKF.1A:
SETZM ISTAB ;CLEAR PREV DUPED TABBED FLAG
CALL INITAB ;INITIALIZE THE SECTION/FIELD TABLES
SETZM CURFLD ;PRESEST
SETZ INT.A, ;FLD-PTR = 0; DO ALL FLDS ON INIT
SETOM NEWFRM ;STARTING ON A NEW FORM
SETZM MSNEW ;FIRST TIME FOR MS ON SCREEN NOW
SETZM CURHSC ;NO HIDDEN SECTION SINCE ITS A NEW FORM
CALL CKF.3 ;COPY TO WORKING STORAGE
RET ; FAILED
SETZM LENERR
LOAD A,.OFFST ;OFFSET OF LAST FIELD
TXNE PRM,%MULT ;IF MULTIPLE AT END OF FORM
JRST [MOVE C,MLTCNT ;GET OCCURS COUNT
SOJ C, ;DONE ONE ALREADY
IMUL C,MLTSIZ ;TIMES LENGTH OF SECTION
ADD A,C ;ADD TO TOTAL SO FAR
JRST .+1] ;BACK TO MAIN LINE
ADD A,LENFLD ;PLUS LENGTH
SKIPLE RECLEN ;IF LENGTH SET
CAMN A,RECLEN ;THEN SEE IF ITS THE SAME
SKIPA ; OK
SETOM LENERR
;CLEAR THE SCREEN AND THE INPUT BUFFER.
CALL $SCLEAR ;CLEAR THE SCREEN
CALL $CLIBF ;CLEAR THE INPUT BUFFER.
CALL .OMSET ;FINALLY - SET UP MULTIPLE FLAGS
SETZM NEWFRM ;THIS IS NOT NOW A NEW FORM
SETZM CURFLD ;RESET THE FLAG
JRST SKPRT2 ;RETURN TO CALLER.
CKF.3: ;COPY ALL DATA TO WORKING-STORAGE
CALL FIND ;FIND A DATA FIELD
RET ;NO FIELDS FOUND -- RETURN AN ERROR.
JRST SKPRET ;NO MORE, WE ARE DONE.
CALL GETPRM ;GET PARAMETERS
CALL GETFLD ;GET FIELD ATTRIBUTES
TXNN PRM,%INDEX ;IS IT AN INDEX FIELD
JRST CKF.4 ;NO
MOVE E,VALFLD ;YES - SET UP MLTIDX
MOVEM E,MLTIDX ;TO BE ADRS OF VALUE
MOVE E,COLFLD ;COPY THE COLUMN NUMBER
MOVEM E,MLTIDC
MOVE E,OFFFLD ;SET UP INDEX FIELD POINTER
MOVEM E,MLTIVP
MOVE E,PRM ;GET RENDITION BITS
ANDX E,%REND ;AND ONLY THOSE BITS
MOVEM E,IDXRND ;AND SAVE THEM FOR LATER
CKF.4:
MOVE E,FULLEN ;GET SIZE OF FIELD
TXNN PRM,%MULT
JRST CKF.5 ; SKIP IF NOT MULTIPLE
SKIPN ALIGN ;IF NOT ALIGNED
JRST CKF.4A ; THEN JUST UPDATE SIZE
PUSH P,INT.A ;PRESERVE THIS FOR LOOP
ADDI E,5 ;ELSE - ROUND UP TO NEXT WORD
IDIVI E,5
IMULI E,5
POP P,INT.A
CKF.4A:
ADDM E,MLTSIZ
MOVE E,CURFLD ;GET FIELD NUMBER
SKIPN MLTBAS ;IF FIRST MULTIPLE FIELD
MOVEM E,MLTBAS ; THEN SAVE IT
TXNE PRM,%PROT ;IF FIELD IS PROTECTED
JRST CKF.5 ; THEN GO ON
SKIPN ML1UNP ;IF FIRST UNPROTECTED FIELD
MOVEM E,ML1UNP ; THEN SAVE IT IF IT IS
CKF.5:
MOVE B,FNUMRD ;GET NUMBER OF CHARS IN FIELD.
MOVE A,LENFLD ;AND LENGTH OF FIELD
CAILE B,(A) ;IF NUM .GT. LENGTH
CALL SV.NUMRD ;AND SAVE THE LENGTH
CALL SETTAB ;SECTION AND FIELD TABLES
CALL FORMAT ;FILL WORKING STORAGE
TXNN PRM,%PROT ;IF FIELD IS UNPROTECTED
JRST CKF.3 ; THEN DO NO FURTHER PROCESSING.
TXNE PRM,%DFDT ;IF DEFAULT DATE & PROT THEN
CALL GCURDT ;SET IT UP FOR THE USER
MOVE A,FNUMRD ;GET NUMBER OF CHARACTERS IN FIELD
CALL REFORM ;MOVE DATA FROM 'VALUE' TO WORKING
JFCL ; STORAGE.
TXNE PRM,%MULT ;IF MULTIPLE AND PROTECTED
CALL MSDUPL ; THEN DUPLICATE THROUGHOUT THE SECTION
JRST CKF.3
CKF.10: ;THE FORM DATA IS MEMORY RESIDENT
HRRZS INT.A ;POINTER TO DATA
CAMN INT.A,DATHDR ;SAME AS PREVIOUS FORM?
JRST SKPRT2 ; YES - DONE
MOVEM INT.A,DATHDR ;NO - NEW FORM
SETZM FRMFIL ;CLEAR OLD FILESPEC IF PRESENT
SETZM NUMWDS ;MAKE SURE WE NEVER RELEASE THIS AREA
SETZM DATJFN ;AND DON'T TRY TO CLOSE ANYTHING
SETZM STRPNT ;THE OFFSET IS ALWAYS ZERO NOW
CALL GETFRM ;DO THE NORMAL SETUP
JRST SKPRET ;SOMETHING WRONG
SETOM GOTFIL ;PRETEND THE FILE WAS GOOD
JRST CKF.1A ;CONTINUE AS NORMAL
SUBTTL GETFRM - UNPACK FORM HEADER DATA
GETFRM: ;SEE IF THIS IS A VALID VERSION OF TFR
MOVE E,DATHDR ;FORM A POINTER TO THE HEADER
SUBI E,HDRWRD
HRRZ A,@DATHDR ;ONLY VALID IF RHS=0
SKIPE A
JRST [MOVEI A,ERR.OV ;NO GOOD - OLD VERSION
RET]
LOAD A,.VERSN,B,E ;GET THE VERSION OF TFR
CAIGE A,4 ;MUST BE 4 OR LATER
JRST [MOVEI A,ERR.OV ;NO GOOD - OLD VERSION
RET]
MOVEM A,VRSION ;SAVE IT FOR LATER
;SEE IF THIS TERMINAL IS ALLOWED BY THE FORM SPEC
LOAD A,.TERMS,B,E
MOVEM A,TRMLGL ;SAVE MASK FOR LATER
CAIN A,1_<%VT132> ;IF ONLY VT132
TXO A,1_<%VT100> ; THEN SET VT100 AS WELL FOR NOW
MOVE B,TTYPE ;GET THE TERMINAL TYPE
MOVEI C,1
LSH C,(B) ;MAKE A MASK
TDNN A,C ;SKIP IF ITS OK
JRST [MOVEI A,ERR.TT
RET]
;GET MAJOR POINTERS ETC
LOAD A,.NMFLD,B,E ;GET THE POINTER TO #FIELDS
MOVEM A,HIFLD ;SAVE IT
LOAD A,.HDSIZ,B,E ;GET THE SIZE OF THE HEADER
MOVEM A,HDRLEN ;AND SAVE IT
LOAD A,.FDSIZ,B,E ;AND DO THE SAME FOR THE FIELD SIZE
MOVEM A,FLDLEN
LOAD A,.STRPT,B,E ;GET THE STRING OFFSET
CAIG A,600000 ;IF TFR MADE THIS FILE - FIX THE POINTER
JRST GFM.1 ; ELSE ASSUME ALL ADDRESSES ARE ABSOLUTE
ADD A,DATHDR
SUBI A,STRING ;AND MAKE INTO A REAL OFFSET (-STRING)
SUBI A,HDRWRD
MOVEM A,STRPNT ;AND SAVE IT
GFM.1:
;GET ERROR LINE PARAMETERS AND FORM ATTRIBUTES
LOAD A,.FPARM,B,E ;GET THE FORM PARAMETERS
TXZE A,%ALIGN ;ARE WE WORD ALIGNED?
SETOM ALIGN ;YES
ASH A,^D27 ;SHIFT TO RIGHT PLACE
MOVE B,TTYPE ;ALLOW ONLY CERTAIN ATTRIBUTES
PUSH P,OPTTTY ;SAVE THIS FOR NOW
MOVEM B,OPTTTY ;AND SET TERMINAL TYPE FOR SETSCN/SETCOL
AND A,TRMATR
HLRZM A,FPARAM ;AND SAVE THE RENDITION BITS
CALL SETSCN ;SET SCREEN MODE IF WE CAN
LOAD A,.CSET,B,E ;GET THE CHARACTER SET
MOVE B,TTYPE ;ONLY SET IT IF RELEVANT
CAIE B,%VT100
CAIN B,%VT132
MOVEM A,CHARST ;AND SAVE THEM
LOAD A,.EPARM,B,E ;GET THE ERROR LINE ATTRIBUTES
ASH A,^D27 ;SHIFT TO RIGHT PLACE
AND A,TRMATR
HLRZM A,EPARAM ;AND SAVE THEM
LOAD A,.MAXLN,B,E ;GET MAXIMUM LINE NUMBER ALLOWED
CAMG A,TRMLIN ;ONLY SAVE IT IF SMALLER
MOVEM A,TRMLIN
LOAD A,.MAXCL,B,E ;AND COLUMN NUMBER
CAML A,TRMCOL ;IF A IS GREATER
CALL SETCOL ;SEE IF WE CAN INCREASE IT
MOVEM A,TRMCOL
LOAD A,.ERRLN,B,E ;GET THE ERROR LINE NUMBER
SKIPN A ;SKIP IF NON-ZERO
MOVE A,TRMLIN ;IF ZERO - USE LAST LINE
MOVEM A,ERRLIN
;GET MAXIMUM NUMBER OF SECTIONS AND HIDDEN SECTION POINTER
LOAD A,.MXSEC,B,E ;GET NUMBER OF SECTIONS
MOVEM A,MAXSEC
MOVE A,E
ADD A,.HIDSC ;POINT TO THE HIDDEN SECTION MASKS
MOVE B,HDRLEN
SUBI B,.FRMLN ;A HAS NUMBER OF WORDS IN MASK
MOVNS B
HRL A,B ;MAKE AN AOBJN POINTER TO THE HIDDEN SECTIONS
MOVEM A,HDNSEC
;GET MULTIPLE SECTION INFORMATION
LOAD A,.MLFCT,B,E ;GET NUMBER OF FIELDS
JUMPE A,[SETZ IDXRND ;IF NO MULTIPLE SECTION ..
MOVE A,[IDXRND,,MLTIDX]
BLT A,MLTSIZ ;THEN CLEAR ALL THE FLAGS
POP P,OPTTTY ;CLEAR THE STACK
JRST SKPRET] ;AND CONTINUE
AOJ A,
MOVEM A,MLTNMF
LOAD A,.MLTRC,B,E ;OCCURS COUNT
MOVEM A,MLTCNT
LOAD A,.MLSEC,B,E ;MULTIPLE SECTION NUMBER
SKIPE MLTCNT ;IF CNT IS NONZERO
SKIPE A ;AND SECTION NO. IS ZERO
SKIPA
MOVEI A,MAXSEC ;THEN THIS IS SECTION 64
MOVEM A,MLTSEC
LOAD A,.MLTDC,B,E ;LINES OF SCREEN USED
MOVEM A,MLTDCT
LOAD A,.MLHIR,B,E ;HIGHEST ROW NUMBER
MOVEM A,MLTHIR
LOAD A,.MLLOR,B,E ;LOWEST ROW NUMBER
MOVEM A,MLTLOR
SETZM MLTSIZ ;MAKE SURE WERE RE-ENTRANT
CALL .OMSET ;SET THE SCROLL AREA FLAGS
POP P,OPTTTY ;RESTORE OPTIMISER FLAGS
JRST SKPRET
SETCOL: ;SEE IF WE CAN INCREASE NUMBER OF COLUMNS
MOVE B,TRMLGL ;SEE IF VT132 IS THE ONLY LEGAL TERMINAL
CAIN B,1_<%VT132>
SKIPN AVOFLG ;AND IF AVO IS FITTED
JRST SKPRET ; ELSE USE LOWER VALUE WIDTH
SKIPE V132FG ;IF ALREADY SET
RET ; THEN JUST SAVE IT
MOVEM A,TRMCOL ;SAVE IT NOW
HRROI A,[BYTE (7)33,"[","?","3","h",0,0,0,0,0]
CALL $SASCIZ
SETOM V132FG ;DONE NOW
JRST SKPRET
RSTCOL: ;RESET TO 80 COLUMN MODE
SKIPN V132FG ;IF FLAG SET - SKIP ON
JRST SCN.1 ;TRY TO RESTORE SCREEN MODE
HRROI A,[BYTE (7)33,"[","?","3","l",0,0,0,0,0]
CALL $SASCIZ ;SEND THE STRING
JRST SCN.1
SETSCN: ;SET SCREEN MODE
TXNN A,%RVRS ;IS REVERSE SET?
JRST SCN.1 ; NO - RESET TERMINAL
SKIPE REVSCR ;WAS IT ALREADY SET?
RET ; YES
HRROI A,[BYTE (7)33,"[","?","5","h",0,0,0,0,0]
SETOM REVSCR
PJRST $SASCIZ
SCN.1:
SKIPN REVSCR ;WAS SCREEN REVERSE?
RET ; NO
HRROI A,[BYTE (7)33,"[","?","5","l",0,0,0,0,0]
SETZM REVSCR
PJRST $SASCIZ
SUBTTL TFRINI -- SECOND LEVEL SUBROUTINES
GETPRM: ;ROUTINE TO RESET THE TEMPORARY ATTRIBUTES OF THE FIELD
;WITH THE INITIAL (FORM DEFINED) STATUS.
LOAD PRM,.SPARM ;GET THE STATIC PARAMETERS
STORE PRM,.DPARM ;AND COPY THEM
RET ;RETURN TO CALLER
;INITIALIZE AND SET UP FIELD/SECTION TABLES FOR PERFORMANCE
INITAB: ;INITIALIZE THE TABLES
SETZM SECFLG ;CLEAR THE INDEX
HRRZ A,SECTAB ;POINT TO SECTION TABLE
SETZM (A) ;AND CLEAR FIRST WORD
HRL A,SECTAB
AOJ A, ;MAKE BLT WORD
HRR B,SECTAB ;LAST ADDRESS (ALMOST)
BLT A,MX%SEC+1(B) ;CLEAR THE TABLE
SETZM FLDTAB ;INITIALIZE THE FIELD TABLE
MOVE A,[FLDTAB,,FLDTAB+1] ;BY STORING ZEROS IN IT.
BLT A,FLDTAB+FLDTLN+1
RET
SETTAB: ;SET UP FIELD AND SECTION TABLES
; FOR SCANNING THE FORM FILE
;ON ENTRY -- THE CURRENT FIELD IS SETUP AND
; THE TABLES (SECTAB, FLDTAB) HAVE BEEN
; INITIALIZED, OR ARE IN USE.
;TABLES HAVE ENTRIES WHICH HAVE:
; LOWEST FIELD NUMBER,,HIGHEST FIELD NUMBER
CALL SETSEC ;SET THE SECTION TABLE
PJRST SETFLD ;SET THE FIELD TABLE
SETSEC: ;SET THE SECTION TABLE.
;The section table has up to MX%SEC entries and is
;indexed by the section number. The table holds the
;lowest field number associated with the section in
;the left half, and the highest number in the right.
SETZB A,D ;INITIALIZE SECTION TABLE INDEX.
HRLI E,(MOVE B,(D)) ;AN INSTRUCTION TO GET THE MASK
HRR E,FSECTN ;INCLUDE THE ADDRESS
MOVE C,CURFLD ;GET NUMBER OF CURRENT FIELD.
SSC.1:
XCT E ;GET THE NEXT MASK
SSC.2:
AOS A ;INCREMENT SECTION TABLE INDEX
CAML A,MAXSEC ;IF DONE
RET ; THEN RETURN
TRNN B,1 ;IF THIS SECTION DOES NOT HAVE BIT SET
JRST SSC.3 ; THEN GO TO NEXT SECTION
SKIPN @SECTAB ;ELSE IF FIRST FIELD IN THIS SECTION
HRLM C,@SECTAB ; THEN STORE FIELD NUMBER IN LH.
HRRM C,@SECTAB ; AND STORE IN RH ANYWAY.
SSC.3:
LSH B,-1 ;SHIFT ONCE
SKIPE B ;DONE?
JRST SSC.2 ; NO - CONTINUE
AOS D ;UPDATE POINTER TO MASKS
MOVE A,D
IMULI A,^D36 ;STEP TO THE NEXT GROUP
JRST SSC.1 ; THEN CONTINUE
SETFLD: ;SET THE FIELD TABLE UP.
;EACH FIELD-NAME IS HASHED INTO THE TABLE AND
;THE LEFT AND RIGHT HALVES OF THE TABLE ARE SET
;WITH THE LOWEST AND HIGHEST FIELD-NAME WHICH
;HASHES TO THIS ENTRY. THIS LIMITS THE SCAN NECESSARY
;FOR 'FIELD-NAME SEARCHES'.
LOAD B,.FIELD,C ;GET ADDRESS OF THIS FIELD NAME
SKIPN B
RET ;RETURN IF NO NAME
ADD B,STRPNT ; TO THE CORRECT PAGE
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVEI A,^D30 ;A MAX OF 30 CHARACTERS IN A NAME
CALL FLDHSH ;GET AND HASH THE FIELD NAME.
MOVE C,CURFLD ;GET THE FIELD NUMBER
SKIPN FLDTAB(B) ;IF ENTRY HAS NOT BEEN SET
HRLM C,FLDTAB(B) ; THEN THIS IS LOWEST NUMBER.
HRRM C,FLDTAB(B) ;THIS IS HIGHEST NUMBER ANYWAY.
RET ;DONE
FLDHSH: ;HASH FIELD NAME AND LEAVE 'A'.
; ON EXIT HASHED TABLE ENTRY IN 'B'.
DMOVE D,[^D40 ;SETUP THE '2' ADDRESS
POINT 7,INTBUF] ; AND LENGTH
SETOM CVTUC ;CONVERT TO UPPER CASE
CALL MOV6OR7 ;MOVE FIELD NAME TO INTBUF IN ASCII
SETZB A,B ;AND FILL OUT REST OF AREA
EXTEND A,[MOVSLJ ;WITH SPACES
SPACE]
JFCL
MOVE A,INTBUF ;INITIALIZE WITH FIRST WORD OF NAME.
MOVEI B,1 ;START ON SECOND WORD
FLDHLP:
LSH A,-2 ;SHIFT OFF BOTTOM 2 BITS
MOVE C,INTBUF(B) ;GET NEXT WORD
CAMN C,[ASCII/ /] ;IF WORD CONTAINS ALL BLANKS
JRST FLDHDV ; THEN WE ARE DONE WITH COLLECTION
LSH C,-2 ;SHIFT DOWN TWO BITS
ADD A,C ;ADD INTO TOTAL
AOS B ;GET NEXT WORD INDEX
JRST FLDHLP ; AND CONTINUE AROUND.
FLDHDV: ;ACCUMULATED TOTAL IS IN 'A'
MOVMS A ;MAKE SURE IT IS POSSITIVE
IDIVI A,FLDTLN ;DIVIDE BY THE FIELD TABLE LENGTH
AOS B ;LEAVING TABLE OFFSET (1-31) IN 'B'.
RET ;RETURN TO CALL
;END OF TABLE SETTING ADDITION
SUBTTL INITSD - INIT NON-DUPED FIELDS
INITSD: ;FIND THE NEXT FIELD
CALL FIND ;INT.A MUST BE SET-UP
RET ;FIELD NOT FOUND
JRST SKPRET ;NO MORE FIELDS.
CALL GETFLD ;GET FIELD ATTRIBUTES
TXNN PRM,%DSPLY ;IF FIELD IS NOT ON THE SCREEN
JRST INITSD ;THEN BYPASS IT.
TXNE PRM,%PRDUP ;IF PREVIOUS OR MASTER DUPE
JRST INITSD ;DUPE WITH FLAG SET THEN BYPASS IT ALSO.
TXNE PRM,%PROT ;IF THIS IS A PROTECTED FIELD.
JRST INITSD ; THEN SKIP THIS FIELD.
TXNE PRM,%MULT ;IF MULTIPLE FIELD
CALL GETMFD ; THEN GET THE RIGHT POINTERS
CALL FORMAT ;OTHERWISE BLANK OUT WORKING STORAGE.
MOVE A,LENFLD ;COPY THE FIELD BACK TO VALUE
MOVE B,OFFFLD
MOVE D,A
MOVE E,VALFLD
EXTEND A,[MOVSLJ] ;NO NEED FOR FILLER
JFCL
CALL BLANK ;THEN SEND BLANKS TO THE SCREEN.
SETZ A, ;AND FINALLY INDICATE ZERO CHARACTERS
CALL SV.NUMRD ; IN THE FIELD.
CALL $SCHKPNT ;WRITE IT OUT IF ROOM NEEDED
JRST INITSD ;THEN LOOP FOR NEXT FIELD.
SUBTTL WRITE - WRITE A FIELD TO THE SCREEN
REWRITE:
SKIPE OLDRN ;IF REWRITING NUMBERS ...
RET ;(RETURN IF NOT)
WRITE:
SKIPE WHFLAG ;DONT WRITE HIDDEN SEC TWICE
RET
SKIPG C,FNUMRD ;ANY TO WRITE ?
RET ; NO!
TXNN PRM,%TALL ;TALL REQUIRES SPECIAL TREATMENT
JRST WRITED
CALL WRITED ;WRITE TOP HALF
AOS LINFLD ;POINT TO NEXT LINE
SETOM TOPBOT ;AND FLAG AS BOTTOM HALF
MOVE C,FNUMRD ;RESTORE NUMBER OF CHARACTERS
CALL WRITED ;WRITE IT
SOS LINFLD ;RESTORE THINGS
SETZM TOPBOT
RET
WRITED:
SETZM SUBCNT ;INITIALISE THE COUNTER
TXNE PRM,%NEKO ;DON'T WRITE A SECURE FIELD
RET
TXNE PRM,%VERT ;IF VERTICAL
SETOM VERT ; THEN FLAG IT
DMOVE A,LINFLD ;LINE AND COLUMN ON SCREEN
MOVEM C,YET2WT ;# REMAINING TO WRITE
CALL $POSIT ;MOVE THE CURSOR THERE.
CALL SFINIT ;POINT TO FIRST SUBFIELD
WRT.1: ;HANDLE EACH SUBFIELD
CALL SUBFLD
JRST [SETZM VERT ;LEAVE IT AS WE FOUND IT
RET]
JUMPL B,WRT.2 ;FOUND A SEPARATOR
SKIPG D,YET2WT ;IF NO MORE LEFT
JRST [SETZM VERT ;LEAVE IT AS WE FOUND IT
RET]
CAIL C,(D) ;IF THE SUBFIELD IS TOO LONG
MOVEI C,(D) ; THEN SHORTEN IT
SUBI D,(C) ;SAVE THE NUMBER REMAINING
MOVEM D,YET2WT
MOVE B,SUBPTR ;POINT TO THIS SUBFIELD
CALL $SSTRING ;AND WRITE IT
MOVEM B,SUBPTR ;RESAVE THE POINTER
JRST WRT.1 ;LOOP FOR MORE
WRT.2:
CALL $SMCHAR ;SEND THE SEPARATOR CHARACTERS
AOS SUBCNT ;COUNT THE SEPARATORS FOR FILL
JRST WRT.1
TWRITE: ;WRITE THE FIELD'S TEXT VALUE TO THE SCREEN
TXNN PRM,%DSPLY ;IF ALREADY DISPLAYED
TXNN PRM,%TEXT ; OR THERE IS NO TEXT
RET ; THEN RETURN
PUSH P,FLDATR ;SAVE THE FIELD ATTRIBUTES
LOAD A,.TPARM ;GET THE TEXT ATTRIBUTES
ASH A,^D27 ;LINE THEM UP CORRECTLY
AND A,TRMATR
HLRZM A,FLDATR ;AND SET THE NEW ONES
PUSH P,FTPOS ;SAVE LINE NUMBER
PUSH P,FTEXT ;BYTE POINTER
TXNN A,%TALL ;IF THIS IS A TALL FIELD
JRST TWR.1
CALL TWR.2 ;THEN WRITE THE TOP HALF
SETOM TOPBOT
MOVE A,-1(P)
MOVEM A,FTPOS ;RESET THE LINE NUMBER
MOVE A,(P)
MOVEM A,FTEXT ;RESTORE FTEXT POINTER
AOS FTPOS ;DOWN ONE LINE
TWR.1:
CALL TWR.2 ;AND WRITE THE BOTTOM HALF
SETZM TOPBOT
POP P,FTEXT
POP P,FTPOS
POP P,FLDATR
RET
TWR.2:
DMOVE A,FTPOS ;GET TEXT POSITION
CALL $POSIT ;AND POINT TO IT
TWR.3:
ILDB A,FTEXT
CAIN A,15 ;<CR> MEANS NEXT LINE
JRST [AOS FTPOS
MOVE A,FLDATR
TXNE A,(%TALL) ;IF TALL TEXT
AOS FTPOS ; THEN SKIP TWO LINES
JRST TWR.2]
SKIPE A ;<NUL> MEANS END OF STRING
JRST [CALL $SCHAR ; WRITE THE CHARACTER
JRST TWR.3]
RET
SUBTTL FORMAT - PUT SPACES INTO WORKING STORAGE
;THIS ROUTINE WILL FILL WORKING STORAGE WITH
;SPACES FOR ALPHA AND ALPHANUMERIC FIELDS AND
;WITH ZEROS FOR NUMERIC FIELDS
FORMAT:
MOVE E,OFFFLD
MOVE D,LENFLD ;GET LENGTH
MOVEI A,SPACE ;ASSUME BLANK FILL UNLESS
TXNN PRM,%ALPHA!%PUNCT ;IF NOT ALPHA OR ALPHA-NUMERIC
MOVEI A,ZERO ; THEN FILL WITH ZEROS BY
MOVEM A,MOVFILL+1 ; STORING THE FILLER CHARACTER
SETZB A,B ; INDICATING NO 'FROM' FIELD,
EXTEND A,MOVFILL ; AND THEN SPREADING THE CHARACTER
JFCL ; ACROSS THE FIELD.
RET
MFORMT: ;FORMAT A SET OF MULTIPLE FIELDS
SKIPN COBCAL ;IF INTERNAL THEN -
PJRST GETMFD ;- JUST DO ONE FIELD
PUSH P,OFFFLD ;SAVE OFFSET FOR CALLER
MOVE A,MLTCNT ;OCCURS COUNT
SOJ A,
MOVEM A,MLTTMP ;SET UP A COUNTER
MFM.1:
MOVE A,MLTSIZ
ADJBP A,OFFFLD ;POINT TO NEXT ENTRY
MOVEM A,OFFFLD
CALL FORMAT ;DO THE FORMAT WORK
SOSE MLTTMP ;MORE?
JRST MFM.1 ;YES
POP P,OFFFLD ;NO - NOW DO THE FIRST
RET
MSDUPL: ;DUPLICATE A MULTIPLE FIELD THROUGH SECTION
MOVE A,MLTCNT
SOJ A,
MOVEM A,MLTTMP ;SET A COUNT - NUMBER OF FIELDS
MOVE A,CURFLD ;SET THE BASIC TABLE POINTER
SUB A,MLTBAS
ADJBP A,MULTAB
MOVEM A,MULTPT
PUSH P,VALFLD
PUSH P,OFFFLD
MOVE A,LENFLD ;FIND NUMBER OF WORDS PER FIELD
SKIPE MSINIT ;SKIP IF NOT INITING UNPROT FIELDS
SETZ A, ; ELSE USE ZERO LENGTH
IDPB A,MULTPT ;SAVE THE LENGTH OF THIS FIELD
ADDI A,5
IDIVI A,5
PUSH P,A ;AND SAVE IT
MSD.1:
MOVE A,LENFLD
MOVEI B,4
ADDB B,MULTPT ;POINT INTO LENGTH TABLE
SKIPE MSINIT ;IF UNPROTECTED
SETZ A, ; THEN CLEAR IT
DPB A,B
MOVE A,LENFLD ;LENGTH TO COPY
MOVE B,-1(P) ;COPY FROM HERE
MOVE D,A
MOVE E,MLTSIZ
ADJBP E,OFFFLD ;TO HERE
MOVEM E,OFFFLD
EXTEND A,[MOVSLJ]
JFCL
MOVE A,(P)
ADDM A,VALFLD ;UPDATE THE OTHER POINTER
CALL WS2VAL ;AND COPY IT TO THERE
SOSE MLTTMP
JRST MSD.1 ;LOOP FOR MORE
POP P,A
POP P,OFFFLD
POP P,VALFLD
RET
SUBTTL REGISTER LOAD/SAVE ROUTINES
SV.NUMRD:
MOVEM A,FNUMRD ;SAVE IN TEMPORARY LOCATION
TXNE PRM,%MULT ;IF MULTIPLE...
DPB A,MULTPT ;THEN SAVE IN REAL LENGTH TABLE
STORE A,.NUMRD
RET
LD.NUMRD: ;LOAD REGISTER 'A' WITH COUNT OF CHARS
TXNE PRM,%MULT ;IF MULTIPLE ...
JRST [LDB A,MULTPT ;THEN GET THE LENGTH FROM MULTAB
MOVEM A,FNUMRD ;SAVE IN TEMPORARY
RET]
LOAD A,.NUMRD
MOVEM A,FNUMRD ;SAVE IN TEMPORARY
RET
SUBTTL FIND - FIND THE NEXT DESIRED FIELD
COMMENT +
CALL FIND (FLD-ID)
NOT FOUND ERROR
NO MORE THIS TYPE
RETURN (CURFLD SET)
+
FIND:
SKIPN GOTFIL ;IF NO FORM INIT HAS BEEN DONE
JRST FND.8 ;TELL CALL 'NO FIELD'
MOVE A,CURFLD ;SAVE FIRST FIELD
MOVEM A,FRSTFD
;;DISPATCH DEPENDING ON TYPE OF FIELD-NUMBER.
;; 0 -- FORM
;; .LT. 0 -- SECTION.
;; .GT. 0 -- FIELD NUMBER.
;; ???? -- BYTE POINTER
JUMPE INT.A,FND.6 ;IF ZERO THEN IS A FORM.
HLRE A,INT.A ;LEFT HALF WILL INDICATE TYPE.
JUMPE A,FND.3 ;IF ZERO, THEN IT IS A FIELD NUMBER.
AOJE A,FND.1 ; THIS IS A SECTION NUMBER.
JRST FND.4 ;OTHERWISE IT IS A FIELD NAME.
;;;;;;;;;;;;;;;;;; USER HAD SPECIFIED A SECTION NUMBER ;;;;;;;;;;;;;;;;
FND.1:
SKIPE NOSECT ;IF ONLY SINGLE FIELD ALLOWED
RET ; THEN SAY IT WASN'T FOUND
SKIPE SECFLG ;IF NOT FIRST FIELD IN SECTION
JRST FND.2 ;THEN INITIALIZATION DONE.
MOVN A,INT.A ;SECTION NUMBER BEING REQUESTED
CAMLE A,MAXSEC ;LEGAL ?
JRST FND.7 ;NO
SKIPN A,@SECTAB ;GET BEGINNING,,ENDING FIELD NUMBERS.
JRST FND.7 ;ZERO--NO FIELDS THIS SECTION.
HRRZM A,SECFLG ;SAVE ENDING FIELD NUMBER.
HLRZS A ;GET BEGINNING FIELD #
SOS A ;MAKE IT THE CURFLD-1
MOVEM A,CURFLD ;AND UPDATE CURRENT FIELD #
FND.2:
CALL GETNXT ;GET NEXT DATA FIELD
JRST FND.7 ;NO MORE FIELDS.
MOVE A,CURFLD ;IF THE CURRENT FIELD NUMBER
CAMLE A,SECFLG ;IS NOT LESS THAN HIGHEST FIELD #
JRST FND.7 ;IN SECTION, THEN WE ARE DONE.
;;DETERMINE IF WE ARE IN THE CORRECT SECTION.
MOVN B,INT.A ;FORM SEC # - 1
SOJ B,
IDIVI B,^D36 ;FIND WORD OFFSET AND BIT IN C
ADD B,FSECTN ;POINT TO THE SECTION MASKS
MOVEI A,1 ;STBRT WITH SECTION 1
LSH A,(C) ;SHIFT (C) PLACES
TDNE A,(B) ;SEE IF THE BIT IS ON
JRST [MOVE A,CURFLD ;THEN THIS IS A PROPER SECTION.
JRST FND.10] ;GOOD SECT = GO DO SET UP OF WD?
JRST FND.2 ;FIELD NOT IN DESIRED SECTION.
;;;;;;;;;;;; USER SPECIFIED A SPECIFIC FIELD NUMBER ;;;;;;;;;;;;;;;;
FND.3:
SKIPE CURFLD ;IF FIELD ALREADY FOUND
JRST FND.9 ; THEN FINISH UP.
MOVE A,INT.A ;IF CURRENT FIELD IS
CAMLE A,HIFLD ; .GT. HIGHEST FIELD
JRST FND.8 ; THEN FINISH UP.
;;GET POINTER TO CURRENT FIELD
SOJ A, ;CURFLD-1
MOVEM A,CURFLD
CALL GETNXT ;REALLY GET CURRENT FIELD
JRST FND.8 ;IF HERE, WE GOT TROUBLE
JRST FND.10
;;;;;;;;;;;;;;;;;;;;;;;; USER SPECIFIED FIELD NAME ;;;;;;;;
FND.4: ;;SAVE FIELD IN 'INTBUF' WITH TRAILING NULL
SKIPE CURFLD ;IF CURRENT FIELD IS NOT 0,
JRST FND.7 ;THEN WE HAVE BEEN HERE ALREADY.
MOVE B,INT.A
MOVE A,INT.B
CALL FLDHSH ;HASH THE NAME
HLRZ A,FLDTAB(B) ;GET THE STARTING FIELD
JUMPE A,FND.7 ;IF NOTHING IN ENTRY, THEN ILLEGAL
SOS A ;AND SET IT ONE BACK SO THAT
MOVEM A,CURFLD ;WE CAN START IN THIS POSITION.
HRRZ A,FLDTAB(B) ;GET THE LAST FIELD WITH THIS HASH
MOVEM A,FLDTAB ;AND STORE IT INTO FLDTAB(0).
FND.5:
CALL GETNXT ;SETUP THE NEXT FIELD.
JRST FND.7 ;NO MORE FIELDS.
MOVE A,CURFLD ;IF THE CURRENT FIELD NUMBER
CAMLE A,FLDTAB ;IS ALREADY GREATER THAN THE LAST
JRST FND.7 ;POSSIBLE, THEN STOP LOOKING.
LOAD B,.FIELD,C ;CHECK THIS FIELD
ADD B,STRPNT ;PAGE.
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVEI A,^D30 ;AND THE LENGTH OF THE NAME TO 'A'.
MOVEI D,(A) ;USE SAME LENGTH HERE
MOVE E,[POINT 7,INTBUF+8]
CALL MOV.7 ;MOVE THE STUFF TO INTBUF+8
SETZB A,B ;AND NOW FILL IT UP WITH
EXTEND A,[MOVSLJ ;BLANKS
SPACE]
JFCL
DMOVE A,[^D30 ;PREPARE TO COMPARE
POINT 7,INTBUF] ;THE STUFF IN INTBUF
DMOVE D,[^D30 ;WITH THE STUFF IN
POINT 7,INTBUF+8] ;IN INTBUF+8
EXTEND A,[CMPSE
SPACE ;SPACE FILL BOTH
SPACE] ; FIELDS
JRST FND.5 ;FIELDS ARE NOT THE SAME
JRST FND.10 ;FIELDS ARE THE SAME.
;;;;;;;;;;;;;;;;;;;; USER SPECIFIED A FORM ;;;;;;;;;;;;;;;;;;;;;
FND.6:
SKIPE NOSECT ;IF ONLY SINGLE FIELD ALLOWED
RET ; THEN SAY IT WASN'T FOUND
CALL GETNXT ;GET THE NEXT FIELD.
JRST FND.7 ;NO MORE.
JRST FND.10 ;GOT ONE.
;;;;;;;;;;;;;;;;;; COMMON EXIT ROUTINES USED BY ALL ;;;;;;;;;;;;;;;;;;
FND.7: ;;NO FIELD (DETERMINE IF 'NONE' OR 'NO MORE'.
SETZM SECFLG ;INDICATE FINISHED WITH SECTION.
SKIPE FRSTFD ;IF THIS IS NOT THE FIRST FIELD
JRST FND.9 ; THEN NO MORE FIELDS
; ELSE RETURN 'NO FIELD FOUND'.
FND.8: ;;NO FIELD WAS FOUND TO MATCH SPECIFICATION.
SETZM CURFLD ;DONE THIS PASS
RET ;NON-SKIP
FND.9: ;;AT LEAST ONE FIELD WAS FOUND, BUT NONE LEFT.
SETZM CURFLD ;DONE THIS PASS
JRST SKPRET ;RETURN TO CALL + 2.
FND.10: ;;HERE WHEN FIELD HAS BEEN FOUND TO MATCH.
LOAD PRM,.DPARM ;LOAD PARAMETERS
JRST SKPRT2 ;WE HAVE NOW FOUND THE FIELD
SUBTTL GETFLD - GET FIELD ATTRIBUTES ETC
GETFLD:
MOVE B,TRMATR
AND B,PRM
HLRZM B,FLDATR ;FIELD VIDEO ATTRIBUTES
;SET UP POSITION AND FILLER
LOAD A,.LINE ;SETUP PARAMETERS FOR FIELD.
LOAD B,.COLM
DMOVEM A,LINFLD ;SET THE LINE AND COLUMN NUMBER.
LOAD A,.FILLR ;SET UP THE FILLER CHARACTER
MOVEM A,FILCHR
LOAD A,.LENG ;SET UP THE FIELD LENGTH.
;SET UP VALUE AND LENGTH
LOAD B,.VALUE ;SET UP POINTER TO THE VALUE.
ADD B,STRPNT ;PAGE.
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
DMOVEM A,LENFLD
MOVEM A,FULLEN ;SAVE FULL LENGTH OF FIELD
CALL LD.NUMRD ;GET ACTUAL LENGTH OF DATA
;SET UP OFFSET POINTER
LOAD A,.OFFST
IBP A,RECPTR ;POINT TO REC IN W.S.
MOVEM A,OFFFLD
;SET UP TEXT POINTER AND POSITION
LOAD A,.TLINE ;GET TEXT POSITION
LOAD B,.TCOLM
DMOVEM A,FTPOS ;AND SAVE IT
LOAD A,.TXTPT ;GENERATE A POINTER TO THE TEXT
ADD A,STRPNT
HRLI A,(POINT 7,0) ;MAKE IT A BYTE POINTER
LOAD B,.TLENG ;AND THE LENGTH
DMOVEM A,FTEXT ;AND SAVE THEM
;GET DATE SUBTYPE
LOAD A,.TYPE ;DATE SUBTYPE
SETZM LONGDT ;ASSUME SHORT FORMAT
TXZE A,%LONGD ;BUT IS IT?
SETOM LONGDT ; NO - USE LONG FORMAT
MOVEM A,DATTYP
;SET UP SUBFIELD POINTER
LOAD B,.SFDES ;GET THE SUBFIELD DESCRIPTOR POINTER
SKIPE B ;IF ZERO
TXNN PRM,%SFDEF ; OR THE FIELD HAS NONE
JRST GFD.1 ; THEN GENERATE A DUMMY
ADD B,STRPNT ;MAKE THE POINTER REAL
HRLI B,(POINT 9,0) ;AND MAKE A BYTE POINTER
MOVEM B,SFDPTR ;SAVE IT
RET
GFD.1:
MOVE A,[POINT 9,SFDES] ;POINT TO A DUMMY DESCRIPTOR
MOVE B,LENFLD ;PUT THE LENGTH BYTE IN
ORI B,%SFLEN
IDPB B,A
MOVE B,PRM ;THEN PUT IN THE FLAGS
ANDI B,%SFLGL
IDPB B,A
MOVEI B,%SFEND ;AND TERMINATE IT
IDPB B,A
MOVE B,[POINT 9,SFDES] ;FINALLY SAVE THE POINTER
MOVEM B,SFDPTR
RET
SUBTTL GETNXT - GET NEXT FIELD
GETNXT:
AOS A,CURFLD ;BUMP FIELD COUNTER
CAMLE A,HIFLD ;IF FIELD # TOO LARGE
RET ; THEN PROCESS IS DONE.
GNX.1: ;CALC POINTER TO DATA = DATA + (FLDLEN*(CURFLD-1))
MOVE B,CURFLD ;FORM FIELD-1
SOJ B,
IMUL B,FLDLEN ;TIME FLD LENGTH
ADD B,DATHDR ;GET THE STARTING PAGE
ADD B,HDRLEN ;AND THEN OFFSET IT.
MOVEM B,FLDPTR ;SAVE FOR STRPRM
ADD B,.DPARM
LDB PRM,B ;GET THE PARAMETERS FOR THE FIELD
MOVE A,FLDPTR ;FORM A POINTER TO THE SECTION MASKS
ADD A,.SECTN
HRRZM A,FSECTN ;AND SAVE IT
JRST SKPRET
STRPRM:
;;STORE THE FLAG REGISTER (PRM) BACK INTO THE
;; FIELD AREA FOR SAVING BETWEEN CALLS
SKIPE OLDPR ;IF FIELDS ARE TO REMAIN
CALL STRP50 ;MAKE ALL TEMPORARY CHANGES PERMANENT
STORE PRM,.DPARM ;SAVE THE PARAMETERS
MOVE E,TRMATR
AND E,PRM ;AND KEEP ONLY THOSE
HLRZM E,FLDATR
RET
STRP50:
STORE PRM,.SPARM
RET
SUBTTL WS2VAL - MOVE A FIELD'S VALUE FROM W.S. TO .VALUE
WS2VAL:
MOVE A,LENFLD ;LENGTH OF MOVE
MOVE D,A
MOVE B,OFFFLD ;FORM W.S. POINTER
MOVE E,VALFLD ;PTR TO CORE VALUE STORAGE
EXTEND A,[MOVSLJ] ;WILL NEVER NEED FILL CHARACTER !
JFCL
TXNN PRM,%ALPHA!%PUNCT
TXNN PRM,%NUMER ;IF THIS IS NOT A NUMERIC
RET ; THEN RETURN
MOVE A,LENFLD ;INDICATE THAT THE FIELD
SKIPN MSINIT ;IF NOT PART OF M.S. INIT
CALL SV.NUMRD ; IS THE FULL LENGTH OF THE FIELD.
MOVEI Z,SPACE ;INDICATE BLANKING DESIRED
TXNE PRM,%ZERO!%DATE ;IF USING LEADING ZEROS
MOVEI Z,ZERO ;THEN INDICATE THAT.
PJRST REPZER ;REPLACE ZEROS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
REPZER: ;ROUTINE TO REPLACE LEADING ZEROS WITH BLANKS
;AND PUT IN STANDARD NUMERIC FORM
SETZM ISNEG ;INDICATE NUMBER NOT NEGATIVE.
CALL SFINIT ;PRESET THE SUBFIELD SYSTEM
MOVE E,VALFLD
SETZ D, ;CLEAR BLANKED CHARACTER COUNTER
RPZ.1: ;LOOP OVER EACH SUBFIELD
CALL SUBFLD ;GET THE NEXT SUBFIELD
JRST [MOVEI Z,ZERO ;NO MORE LEFT - MAKE SURE LAST CHARACTER
DPB Z,E ; IS A ZERO
RET]
JUMPL B,RPZ.1 ;DON'T BOTHER WITH SEPARATORS
CAIE Z,SPACE ;ARE WE BLANKING ?
JRST RPZ.2 ;NO..
TXNE A,%ZERO ;IF ZEROS ARE ALLOWED IN SUBFIELD
MOVEI Z,ZERO ;THEN GET ONE
RPZ.2:
MOVEM E,SUBTMP ;AND SAVE THE CURRENT POINTER FOR LATER
CALL REPZLP ;DO THE REPLACE ON THIS SUBFIELD
SKIPA
RET ;DONE
TXNE PRM,%MONEY ;IF THIS IS THE FIRST SUBFIELD IN
SKIPN SUBCNT ; A MONEY FIELD, THE PUT IN A ZERO
JRST RPZ.1
MOVEI A,ZERO
DPB A,E
JRST RPZ.1
REPZLP: ;REPLACE ZEROS LOOP
;ENTER WITH E = POINTER TO DATA IN VALUE
; C = MAXIMUM LENGTH
ILDB B,E ;GET NEXT CHARACTER
CAIN B,ZERO ;IF LEADING 0
JRST RPZ.3 ; THEN CONTINUE BLANKING.
CAIN B,SPACE ;IF LEADING BLANK
JRST RPZ.3 ; THEN CONTINUE BLANKING.
CAIN B,"+" ;IF LEADING PLUS SIGN
JRST RPZ.3 ; THEN CONTINUE BLANKING.
CAIE B,"-" ;IF NOT LEADING MINUS
JRST RPZ.4 ;THEN SEARCH IS DONE.
SETOM ISNEG ; OTHERWISE INDICATE NEGATIVE.
RPZ.3:
AOS D ;COUNT BLANKED DIGITS
DPB Z,E ;INSERT THE BLANKING CHARACTER.
SOJG C,REPZLP ;IF MORE CHARACTERS..LOOP.
SKIPA ;TIDY UP AND THEN
;GO FOR ANOTHER SUBFIELD
RPZ.4: ;HERE AFTER SEARCH FOR LEADING ZEROS IS DONE WITH:
; D == NUMBER OF LEADING CHARACTERS BLANKED.
; E == POINTING AT LAST CHARACTER BLANK.
; ISNEG = 0 IF POSITIVE, -1 IF NEGATIVE.
AOS (P) ;SKIP RETURN
SKIPE D ;IF NO CHARACTERS BLANKED
SKIPL ISNEG ; OR A POSITIVE NUMBER
RET ; THEN JUST EXIT
TXNN PRM,%SIGND ;IF NOT SIGNED
RET ; THEN DON'T ATTEMPT TO PROCESS IT
MOVEI A,"-" ; ELSE INSERT THE MINUS SIGN.
CAIE Z,SPACE ;IF NOT BLANKING
JRST [MOVE E,SUBTMP ;RESTORE THE SAVED POINTER
CAMN E,VALFLD ;IF THIS IS NOT THE FIRST BYTE
IBP E ; THEN ADVANCE THE POINTER
DPB A,E ;INSERT THE SIGN BYTE
RET]
SETO B, ;BACKUP THE POINTER BY 1
ADJBP B,E ; BYTE
DPB A,B ; AND DEPOSIT THE MINUS SIGN.
RET
SUBTTL SUBFLD - GET NEXT SUBFIELD LENGTH AND BYTE POINTER
;SFINIT - THIS IS CALLED TO INITIALIZE THE SUBFIELD SYSTEM
;
;SUBFLD - IS CALLED TO GET THE NEXT BYTE FROM THE SUBFIELD DESCRIPTOR.
;
;RETURN +1 IF THERE ARE NO MORE SUBFIELDS
;RETURN +2 WITH THE NEXT SUBFIELD INFORMATION:
;
; AC1 - SUBFIELD CLASS OR SEPARATOR
; AC2 - FLAG = 0 IF NORMAL CHARACTER, -1 IF SEPARATOR
; AC3 - LENGTH OF SUBFIELD
;
SFINIT: ;INITIALIZE THE SUBFIELD
MOVE A,VALFLD ;GET POINTER TO FIELD BUFFER
MOVEM A,SUBPTR ; AND STORE.
MOVE A,SFDPTR ;GET POINTER TO SUBFIELD DESCRIPTOR
MOVEM A,SFPNTR ; AND INITIALIZE
RET
SUBFLD:
SETZB A,B ;INITIALIZE
ILDB C,SFPNTR ;GET THE FIELD FROM SUBFIELD DESCRIPTOR
SKIPN C ;IF NO MORE FIELDS
RET ; THEN NO MORE FIELDS
TXZN C,%SFLEN ;IF NOT A LENGTH FIELD
JRST SBF.2
ILDB A,SFPNTR ; ELSE GET TYPE FROM NEXT FIELD
SBF.1:
SKIPN A ;IF THE FIELD HAS A TYPE
TXNE PRM,%PROT ; OR IF THE FIELD IS PROTECTED
SKIPA ; THEN IT IS GOOD
RET ; ELSE NO MORE SUBFIELDS
TXZN A,%SFSEP ;IF IT IS A SEPARATOR
JRST SKPRET
SETO B, ;THEN MARK IT.
MOVEM A,LSTSEP ;SAVE THE SEPARATOR FOR CHECKS
JRST SKPRET
SBF.2:
TXZE C,%SFSEP ;IF IT WAS A SEPARATOR
JRST SBF.3 ; THEN TREAT IT AS SUCH
MOVEI A,(C) ;COPY THE TYPE CODE
MOVEI C,1
TXNE A,%SFTYP ;IF TYPE=0 THEN LENGTH=1, ELSE =2
AOJ C, ; SET LENGTH=2
CAIE A,%T.AM ;IF %T.AM THEN LENGTH=3
CAIN A,%T.JD ; ALSO IF JULIAN DAYS
AOJ C,
CAIN A,%T.Y ;IF THIS IS THE YEAR SUBFIELD
SKIPN LONGDT ; AND IT IS LONG FORMAT
JRST SBF.1
MOVEI C,4 ;THEN THE LENGTH IS 4
JRST SBF.1
SBF.3:
MOVEI A,(C) ;COPY THE SEPARATOR
MOVEM A,LSTSEP ;AND SAVE IT
MOVEI C,1 ;ONLY ONE OF THEM
SETO B, ;SET THE FLAG
JRST SKPRET
SUBTTL STRING MOVERS & TRANSLATERS
MOV6OR7: ;MOVE EITHER SIXBIT OR SEVEN BIT
;ON ENTRY:
; A-- LENGTH OF MOVE 'FROM' FIELD
; B-- BYTE POINTER FOR 'TO FIELD.
; D-- LENGTH OF MOVE 'TO' FIELD
; E-- BYTE POINTER FOR 'TO FIELD.
TLNN B,100 ;IF NOT ASCII TO ASCII
JRST [CALL MOV.6 ;ASSUME SIXBIT TO ASCII
RET] ;AND RETURN
PJRST MOV.7 ;ELSE DO ASCII MOVE
MOV.6:
SKIPG A ;DEFAULT TO 130(8) CHARS
MOVEI A,130
TLO A,400000 ;INDICATE STOP ON SPACE & NULLS
EXTEND A,[MOVST SIX27
SPACE] ;SIXBIT TO 7BIT
SETZ A, ;ABORT = ALL SOURCE BYTES DONE
RET
MOV.7:
SKIPG A ;DEFAULT TO 130(8) CHARS
MOVEI A,130
TLO A,400000 ;INDICATE STOP ON SPACE & NULLS
SKIPE CVTUC ;IF CONVERTING TO UPPER CASE
JRST MOV.7U ; THEN DO IT
EXTEND A,[MOVST SVN27
SPACE] ;ASCII TO ASCII
SETZ A, ;ABORT = ALL SOURCE BYTES DONE
RET
MOV.7U:
EXTEND A,[MOVST SVN2U
SPACE]
SETZ A,
RET
INT627: ;SIXBIT TO ASCII IN INTBUF
PUSH P,A ;PRESERVE A
DMOVE D,[130 ;INTBUF LENGTH
POINT 7,INTBUF]
CALL MOV.6 ;MOVE 6 TO ASCII
SETZB A,B ;AND NOW FILL OUT THE
EXTEND A,[MOVSLJ ; OF INTBUF WITH
SPACE] ; SPACES
JFCL
MOVE B,[POINT 7,INTBUF]
POP P,A
RET
INT72U: ;CONVERT ASCII TO UPPER CASE
SKIPG A
MOVEI A,130 ;DEFAULT TO 130(8) CHARACTERS
PUSH P,A
DMOVE D,[130
POINT 7,INTBUF]
TLO A,400000
EXTEND A,[MOVST SVN2U
SPACE]
JRST [TLZ A,400000
MOVNS A ;FIND REAL LENGTH
ADD A,(P)
HRRZ INT.B,A ;AND COPY IT
JRST .+1]
MOVE B,[POINT 7,INTBUF]
POP P,A
RET
TRNCBL: ;ROUTINE TO GIVE NUMBER OF SIGNIFICANT CHARACTERS
;ON A LINE BY 'TRUNCATING' TRAILING BLANKS.
;ENTER WITH A--POINTER TO FIELD, B--LENGTH OF FIELD
;EXIT WITH A--POINT TO LAST SIGNIFICANT CHAR, B=COUNT
MOVEI C,(B) ;GET LENGTH OF STRING IN C
ADJBP C,A ;AND POINT TO END OF STRING
MOVE A,C ; AND PUT POINTER IN A.
TRNC10:
LDB D,C ;GET CHARACTER
CAIE D,SPACE ;IF IT IS A NOT A BLANK THEN
RET ; RETURN WITH NUMBER IN 'B'.
HRROI C,-1 ; ELSE BACKUP THE POINTER
ADJBP C,A ; ONE.
MOVE A,C ;MOVE THE POINTER BACK.
SOJG B,TRNC10 ;AND BACKUP.
RET ;IF NO SIGNIFICANT CHARS, STOP.
SUBTTL TFRWRT - WRITE TO SCREEN
; TFRWRT writes data from the record data area to the screen.
; Individual fields, sections or the whole form amy be written.
; When called from a VET routine, only individual fields can
; be written.
;
; CALL TFRWRT (field-or-section-identifier,
; error-code)
ENTER WRT,2
SKIPE VETCAL ;IF THIS IS A VET CALL
SETOM NOSECT ; THEN ONLY ALLOW SINGLE FIELD
SETOM WHFLAG ;DONT WRITE HIDDEN SEC TWICE
SETZM @1(ARG) ;INDICATE NO ERROR.
GETITM 0,ANY ;POINT TO FIELD IDENTIFIER
CALL $SBEGIN ;INITIALIZE OUTPUT BUFFER
CALL CHKHSC ;LOOK FOR HIDDEN SECTIONS
JRST TWT.3 ;SOMETHING WRONG
JRST [CALL MWRITE ;MULTIPLE SECTION
JRST TWT.4]
JRST TWT.2 ;MULTIPLE ERROR
TWT.1:
CALL FIND ;GET THE NEXT FIELD
JRST TWT.3 ;NO FIELDS FOUND WITH SPECIFICATION.
JRST TWT.4 ;NO MORE FIELDS FOUND.
CALL GETFLD ;GET FIELD ATTRIBUTES
TXNE PRM,%MULT ;IF MULTIPLE FIELD FOUND HERE
JRST TWT.4 ;THEN DON'T DO IT!!!
CALL FWRITE ;MOVED
JRST TWT.1 ;DO IT AGAIN
TWT.2:
MOVEI A,ERR.ML ;MULT SECT MUST BE SECT WRITE
MOVEM A,@1(ARG)
JRST TWT.4
TWT.3: MOVEI A,ERR.NF ;INDICATE FIELD NOT FOUND ERROR.
MOVEM A,@1(ARG)
TWT.4: ;RETURN TO USER,... NO MORE FIELDS
CALL $HOME1
SKIPN SCNUPD ;IF UPDATING EVERY TIME
CALL $SEND ;SEND OUTPUT BUFFER.
SETZM NOSECT ;SECTION WRITES ARE OK NEXT TIME
SETZM WHFLAG
MOVE Z,@1(ARG) ;RETURN ERROR IN AC0
RET
FWRITE:
SETZM WHFLAG ;CAN NOW WRITE HIDDEN SEC
CALL WRTDSP ;IF FIELD NOT DISPLAYED AND NOT
CALL WS2VAL ;MOVE WORKING STORAGE TO VALUE.
;SET #RD TO LENGTH OF FIELD MINUS TRAIL SPACES
MOVE A,VALFLD ;PTR TO CORE VALUE STORAGE
MOVE B,LENFLD ;LENGTH OF FIELD
CALL TRNCBL ;COUNT SIGNIFICANT DIGITS
MOVEI A,(B) ;RETURNING WITH COUNT IN 'B'.
CALL SV.NUMRD
CALL WRITE ;WRITE THE CURRENT FIELD.
TXNN PRM,%MULT ;FILL IF MULTIPLE
TXON PRM,%DSPLY ;IF FIELD WAS NOT DISPLAY, THEN
CALL FILL ;APPLY FILLERS TO END OF LINE.
SKIPN A,ENUMRD ;IF NOT OVERWRITING
JRST FWR.1 ; THEN SKIP ON..
SUB A,FNUMRD ;ELSE GET THE DIFFERENCE TO FILL
MOVEM ENUMRD ;AND SAVE TEMPORARILY
SKIPLE A ;IF POSITIVE
CALL FILL ; THEN FILL OUT THE EXTENDED PORTION
SETZM ENUMRD ;DONE IT NOW
FWR.1:
TXNE PRM,%MSDUP ;IF THE FIELD IS MASTER DUPE
TXO PRM,%PRDUP ;THEN SET MASTER DUPE FLAG.
CALL STRPRM ;SAVE THE 'PRM' INFORMATION.
PJRST $SCHKPNT ;FLUSH OUTPUT BUFFER IF ROOM NEEDED.
WRTDSP: ;ROUTINE TO TEST DISPLAY BIT, AND DETERMINE IF
;UNDISPLAYED FIELDS ARE TO BE INITIALIZED ANYWAY.
SETZM ENUMRD ;NO EXTENSION FILL REQUIRED YET
TXNN PRM,%HIDE ;DONT DO THIS IF HIDDEN
TXNE PRM,%DSPLY ;IF THIS FIELD IS DISPLAYED
JRST [MOVE Z,FNUMRD ;COPY THE EXTENSION FOR LATER
MOVEM Z,ENUMRD
RET]
CALL GETPRM ;INITIALIZING NONDISPLAYED FIELD SO
CALL STRPRM ;PRM VALUES MUST BE SET UP.
MOVEI A,ERR.ND ;INFORM USER THAT AT LEAST ONE
MOVEM A,@1(ARG) ;FIELD IS NOT DISPLAYED.
RET
SUBTTL MWRITE WRITE MULTIPLE FIELDS
MWRITE: ;WRITE A MULTIPLE SECTION
SETOM WRTFLG ;FLAG FOR WRTELM
CALL FNDLST ;FIND THE LAST ELEMENT
JFCL ; DON'T CARE HERE
ADD A,MLTCNT ;GET THE ELEMENT NUMBER
SKIPN NEWMMS ;IF ZERO THEN DO MESSAGE
JRST MWR.1
MOVEM A,LSTELM ;LSTELM = FIRST FREE
ADD A,MLTLOR
SUB A,MLTHIR
SKIPG A ;FSTELM = MAX(1, LAST - WINDOW SIZE)
MOVEI A,1
MOVEM A,FSTELM
CALL MRWRIT ;"REWRITE" THE SECTION
MOVE A,MLTLOR ;SET CURRENT LINE
ADD A,LSTELM
SUB A,FSTELM
MOVEM A,MLTDSP
MOVN A,MLTCNT ;SET NUMBER OF ELEMENTS LEFT
ADD A,LSTELM
SOS A
MOVEM A,MLTELM
SETZM WRTFLG ;CLEAR THE FLAG FOR EVERYONE ELSE
RET
MWR.1:
MOVE B,MLTDCT ;RESTART
MOVEM B,LSTELM
MOVEI C,1 ;FSTELM = 1
MOVEM C,FSTELM
PUSH P,A ;SAVE LAST ELEMENT NUMBER
PUSH P,B ;SAVE WINDOW SIZE
CAIGE A,(B) ;HOW TO DO IT?
JRST MWR.5 ;PARTIAL FILL
MWR.2:
CALL MRWRIT ;"REWRITE" THE SECTION
MOVE A,-1(P) ;SEE IF THERE'S ANY MORE
SUB A,(P)
JUMPE A,MWR.4 ;NO
MOVEM A,-1(P) ;RESAVE THE NUMBER TO GO
HRROI C,[ASCIZ 'Press TAB to continue; RETURN to finish : ']
CALL PUTMSG ;TELL USER
CALL $SEND ;FORCE THIS OUT
CALL $RDCHAR ;GET A CHAR
JUMPE A,.-1 ;IGNORE NULLS
CAIN A,CR ;IF <CR>
JRST MWR.4 ;THEN DONE
CAIE A,TAB ;IF NOT <TAB>
JRST MWR.4 ;THEN WAIT FOR IT
MOVE A,(P) ;IS A FULL WINDOW LEFT?
CAML A,-1(P)
JRST MWR.3 ;NO - SCROLL THE REST OUT
ADDM A,FSTELM ;UPDATE THE POINTERS
ADDM A,LSTELM
JRST MWR.2
MWR.3:
MOVE A,MLTHIR ;POINT TO THE LAST LINE (JUST IN CASE)
MOVEI B,1
CALL $POSIT
CALL $SCRLU ;SCROLL UP A LINE
AOS FSTELM
CALL WRTELX ;WRITE THE NEW ELEMENT
SOSLE -1(P) ;DONE?
JRST MWR.3 ; NO
MWR.4:
ADJSP P,-2 ;TIDY UP
SETZM WRTFLG ;CLEAR THE FLAG
RET ;DONE NOW
MWR.5:
CALL MRWRIT ;WRITE PART OF THE AREA
SKIPN .TMOPT ;FINISH IF OPTIMISER IS OFF
JRST MWR.4
MOVE A,-1(P) ;SET UP THE FIRST LINE TO CLEAR
SUBM A,(P) ;SET A COUNTER
ADD A,FSTELM
MOVEM A,-1(P)
SKIPA
MWR.6:
AOS A,-1(P) ;NEXT ELEMENT
MOVEI B,1
CALL $00POS
CALL $00ERS ;CLEAR IT OUT
SOSLE (P) ;MORE?
JRST MWR.6 ; YES
ADJSP P,-2 ;DONE
SETZM WRTFLG ;CLEAR THE FLAG
RET
;REWRITE MULTIPLE FIELDS (CALLED FROM TFRRWT OR ESC.R)
MRWRIT:
PUSH P,INT.A ;SAVE OLD INDICATOR
MOVN INT.A,MLTSEC ;AND SET FOR MULTIPLE ONLY
PUSH P,SECFLG
MOVE A,[MLTTMP,,MLTSAV] ;SET UP TO SAVE
BLT A,MLTSAV+7 ;8 WORDS
SETOM MTXTFG ;WRITE TEXT ON THIS PASS
MOVE A,FSTELM ;START AT THE FIRST ELEMENT
SOJ A,
PUSH P,A
MRW.1:
AOS A,0(P) ;GET ELEMENT NUMBER TO SEND
CAMLE A,LSTELM ;SEND IT?
JRST MRW.2 ; NO
CALL WRTELM ;YES
SETZM MTXTFG ;DON'T WRITE TEXT ON NEXT PASS
JRST MRW.1
MRW.2:
ADJSP P,-1
POP P,SECFLG ;RESTORE SOME POINTERS
POP P,INT.A
MOVE A,[MLTSAV,,MLTTMP] ;AND RESTORE
BLT A,MLTTMP+7 ;8 WORDS
MOVE A,MLTBAS ;SET UP CURFLD TO POINT
ADD A,MLTNMF ;TO THE FIELD AFTER
SOS A ;CORRECT IT
MOVEM A,CURFLD ;THE MULTIPLE SECTION
RET
WRTELX: ;ALTERNATE ENTRY POINT
AOS A,LSTELM
WRTELM: ;WRITE A MULTIPLE ELEMENT TO THE SCREEN
PUSH P,MLTTMP
PUSH P,MLTELM ;SAVE THE ELEMENT POINTER
PUSH P,MLTDSP
SETZM SUBCNT
MOVEI B,-1(A) ;SET UP THE ELEMENT NUMBER
SUB B,MLTCNT
MOVEM B,MLTELM
SETZM SECFLG ;RESTART
SETZM CURFLD ;"
SUB A,FSTELM
ADD A,MLTLOR ;SET UP THE DISPLAY ROW
CAMLE A,MLTHIR ;IF THIS IS OFF THE END
MOVE A,MLTHIR ; THEN USE THE HIGHEST
MOVEM A,MLTDSP
MOVN A,MLTNMF ;SET UP A COUNT
MOVEM A,MLTTMP
WRE.1:
CALL FIND ;FIND THE NEXT ONE
JFCL
JRST WRE.4 ;DONE
AOS MLTTMP ;STEP THE COUNTER FOR NEXT TIME
CALL GETFLD ;GET FIELD ATTRIBUTES
CALL GETMFD ;GET THE FIELD INFO
SKIPE WRTFLG ;IF CALLED FROM MWRITE
JRST [CALL FWRITE ;THEN WRITE IT THIS WAY
JRST WRE.1] ;AND CONTINUE
CALL LD.NUMRD ;GET ACTUAL NUMBER READ
SKIPN C,A ;IF EMPTY
JRST WRE.3
PUSH P,C ;SAVE THE COUNTER
CALL WRITED ;WRITE IT TO THE SCREEN
POP P,C
WRE.3:
CALL FILL2 ;FILL THE FIELD SO FAR
SKIPN MTXTFG ;CAN WE WRITE TEXT?
JRST WRE.1 ; NO
TXZ PRM,%DSPLY ;YES - PRETEND ITS NOT DISPLAYED
CALL TWRITE
TXO PRM,%DSPLY
JRST WRE.1
WRE.4:
POP P,MLTDSP ;RESTORE THE WORLD
POP P,MLTELM
POP P,MLTTMP
SETZM MWTALL ;RESET THE WRITEALL FLAG
RET ;FINISH OFF
SUBTTL FILL & BLANK - FILL OR BLANK A FIELD WITH FILL
FILL:
TXNE PRM,%SFDEF ;IF TFR DEFINED SUBFIELD
JRST FIL.1 ; THEN HANDLE.
SKIPE ENUMRD ;IF OVERFILLING A FIELD
JRST FIL.1 ; DO IT EVEN IF BLANKS
MOVE Z,FILCHR ;GET THE FILLER AND
CAIN Z,SPACE ;IF FILLER IS A BLANK
SKIPE FLDATR ; AND IF NO SPECIAL ATTRIBUTES
SKIPA
RET ; THEN DON'T BOTHER FILLING.
FIL.1:
MOVE C,FNUMRD ;GET NUMBER OF CHARS IN FIELD.
FILL2:
TXNE PRM,%NEKO ;IF NO ECHO TO FIELD
SETZ C, ; THEN NO LENGTH.
CAMN C,LENFLD ;IF FIELD IS FULL
RET ; THEN WE ARE DONE.
TXNE PRM,%VERT ;IF VERTICAL
SETOM VERT ; SET THE FLAG
SETZ D, ;INITIALIZE CURRENT POSITION.
CALL SFINIT ;INITIALIZE THE SUB-FIELD
JUMPE C,[CALL FIL.6 ;IF FILLING WHOLE FIELD, POSITION
JRST FIL.3] ; TO IT AND WRITE FILLERS.A.
MOVE E,C ;SAVE THE CURRENT LENGTH OF THE FIELD.
ADD E,SUBCNT
FIL.2: ;ADVANCE TO FIRST FILL POSITION (AC-D),
CALL SUBFLD ;GET THE NEXT SUB FIELD
JRST FIL.7 ; UNLESS THERE ARE NO MORE.
ADD D,C ;NEXT FIELD POSITION AFTER THIS SUBFIELD
SUB E,C ;COUNT DOWN NUMBER OF CHARACTERS IN THIS
JUMPL B,FIL.2 ;JUMP IF SEPARATOR (DO NOT FILL)
JUMPG E,FIL.2 ; SUBFIELD AND LOOP IF STILL MORE.
; NOW IN SUBFIELD TO START FILLING
TXNN PRM,%SFDEF ;IF SUBFIELDS IN USE HERE
TXNN PRM,%ALPHA+%PUNCT ;OR NUMERIC
JRST [SUB D,C ;CORRECT FOR GOING TOO FAR
ADD E,C
JRST .+1]
JUMPE E,[CALL FIL.6 ;IF STARTING ON SUBFIELD BOUNDRY
MOVE A,FILCHR
JRST FIL.5] ; THEN POSITION AND OUTPUT FILLER.
ADD D,E ;DECREMENT TO STARTING POSITION.
MOVN C,E ;NUMBER OF CHARACTERS TO FILL THIS SUBFIELD.
CALL FIL.6 ;POSITION TO SUBFIELD
JRST FIL.4 ; AND CARRY ON AS IF IN SUBFIELD
FIL.3: ;FOR EACH REMAINING SUBFIELD, DO:
CALL SUBFLD ;GET THE NEXT SUBFIELD
JRST FIL.7 ; UNLESS THERE ARE NONE.
SKIPGE B ;IF THIS IS A SEPARATOR
JRST [CALL $SMCHAR ; THEN SEND IT OUT (AC-A)
JRST FIL.3] ; AND GET NEXT SUBFIELD.
FIL.4:
MOVE A,FILCHR ; ELSE...SET UP FILL CHARACTER.
SKIPG B,ENUMRD ;IF NOT OVERWRITTING
JRST FIL.5 ; THEN CONTINUE NORMALLY
CAML C,B ; ELSE IF FINISHED IN THIS
JRST [MOVE C,B ; SUBFIELD
CALL $SMCHAR ; OUTPUT FILLER
JRST FIL.7] ; AND WE'RE DONE.
SUB B,C ;DECREMENT BY SUBFIELD SIZE
MOVEM B,ENUMRD
FIL.5:
CALL $SMCHAR
JRST FIL.3
FIL.6: ;POSITION TO SUBFIELD
DMOVE A,LINFLD ; OFFSETTING COLUMN
ADD B,D ; BY AC-D
PJRST $POSIT
FIL.7:
SETZM VERT ;CLEAR THE VERTICAL FLAG
RET
TBLANK: ;CLEAR TEXT FROM THE SCREEN
PUSH P,FTPOS ;SAVE LINE NUMBER
PUSH P,FTEXT ;BYTE POINTER
TBK.1:
DMOVE A,FTPOS ;GET TEXT POSITION
CALL $POSIT ;AND POINT TO IT
TBK.2:
ILDB A,(P)
CAIN A,15 ;<CR> MEANS NEXT LINE
JRST [AOS FTPOS
JRST TBK.1]
SKIPE A ;<NUL> MEANS END OF STRING
JRST [MOVEI A,SPACE ;BLANK THE CHARACTER
CALL $SCHAR ; WRITE THE CHARACTER
JRST TBK.2]
ADJSP P,-1 ;TIDY UP
POP P,FTPOS ;AND RESTORE POSITION
RET
ABLANK: ;CLEAR OUT WHOLE FIELD (TEXT, DATA, SEPARATORS)
;BLANKING OF VIDEO ATTRIBUTES TOO
TXNN PRM,%TALL ;IF THIS IS A TALL FIELD
JRST ABL.0
AOS LINFLD ;THEN ALSO CLEAR THE BOTTOM HALF
CALL ABL.0
SOS LINFLD ;AND NOW DO THE TOP HALF
ABL.0:
MOVE A,LINFLD ;IF THE FIELD WAS TALL OR WIDE
MOVE B,.OFLAG(A)
TXNE B,%OTAL1!%OTAL2!%OWIDE
TXO B,%OLCLR ;THEN SET THE FLAG TO CLEAR IT
MOVEM B,.OFLAG(A)
PUSH P,FILCHR ;SAVE THE FILLER
SKIPE FLDATR ;IF USING VIDEO ATTRIBUTES
SETOM FILCHR ; THEN INSURE FILLER NON-BLANK
SETZM FLDATR ;NO VIDEO ATTRIBUTES
;CLEAR OUT THE TEXT
SKIPE FTLEN ;IF THERE IS TEXT IN THIS FIELD
CALL TBLANK ; THEN CLEAR IT.
;CLEAR OUT DATA AND SEPARATORS
CALL SFINIT ;INITIALIZE SUBFIELD
SETZ D, ;TOTAL SIZE (INCLUDING SEPARATORS)
SETZM LSTSEP ;POSITION OF LAST SEPARATOR
MOVE A,FNUMRD ;INITIALIZE WITH NUMBER OF
MOVEM A,SUBTMP ; CHARACTERS TO BLANK
ABL.1: ;FOR EACH SUBFIELD DO:
CALL SUBFLD ;GET THE SUBFIELD LENGTH
JRST ABL.2 ;NO MORE ...LENGTH IN AC-D
ADD D,C ;UPDATE TOTAL
SKIPGE B ;IF A SEPARATOR,
JRST [MOVEM D,LSTSEP ; THEN SAVE ITS POSITION
ADDM C,SUBTMP ; AND INCREMENT COUNT
JRST .+1] ; AND RETURN.
JRST ABL.1 ;LOOP
ABL.2:
MOVE C,D ;TOTAL LENGTH
MOVE D,SUBTMP ;SET D TO TTHE MAXIMUM OF THE
CAMGE D,LSTSEP ; LAST WRITTEN CHARACTER AND
MOVE D,LSTSEP ; THE LAST SEPARATOR POSITION
MOVEI B,SPACE ; AND THEN IF THE FILLER IS
CAMN B,FILCHR ; IS A SPACE, CLEAR ONLY UP
MOVE C,D ; TO THAT POINT.
DMOVE A,LINFLD ; USING THE LINE AND COLUMN
CALL $POSIT ; POSITION TO FIELD.
MOVEI A,SPACE ;BLANKING CHARACTER
CALL $SMCHAR ; AND BLANK FILL
POP P,FILCHR ;RESTORE FILLER
RET
BLANK: ;BLANK FILLED CHARACTERS OF A FIELD.
MOVE C,FNUMRD ;GET NUMBER OF CHARS IN FIELD.
TXNN PRM,%PROT ;IF FIELD IS UNPROTECTED
TXNE PRM,%DSPLY ; AND CURRENTLY NOT ON SCREEN
SKIPA ; THEN
MOVE C,LENFLD ; FILL THE WHOLE FIELD.
SKIPN C
RET
DMOVE A,LINFLD
CALL $POSIT ;POSITION TO THE FIELD
CALL SFINIT ;INITIALIZE SUBFIELD
MOVE D,C ;NUMBER TO BLANK.
BLK.1: ;FOR EACH SUBFIELD, DO:
CALL SUBFLD ;GET A SUBFIELD
RET ; NO MORE, DONE.
CAMG D,C ;IF THIS IS THE LAST SUBFIELD
MOVE C,D ; THEN THIS IS THE NUMBER TO BLANK.
SKIPL B ;IF THIS IS NOT A SEPARATOR
MOVE A,FILCHR ;GET THE FILL CHAR
PUSH P,C ;SAVE NUMBER OF CHARACTERS
CALL $SMCHAR ;SEND IT OUT AC-C TIMES.
POP P,C ;RESTORE NUMBER OF CHARACTERS
SKIPL B ;IF NOT A SEPARATOR
SUB D,C ;COMPUTE NUMBER REMAINING TO SEND.
JUMPG D,BLK.1 ;LOOP UNTIL ALL DONE
RET ;IF DONE, RETURN
SUBTTL TFRRD - READ A FIELD-ID FROM SCREEN
; TFRRD reads data from the screen and places it in the data record
; specified by TFRINI. Individual fields, sections, or the whole
; form can be read by this routine.
;
; CALL TFRRD (field-or-section-identifier,
; end-indicator,
; error-code)
ENTER RD,3
SETZM @2(ARG) ;INITIALIZE ERROR RETURN.
SETZM @1(ARG) ;PRESET END-INDICATOR
CALL $SBEGIN ;INITIALIZE THE OUTPUT LINE
SETZM TRMCHR
SETZM MAXFLD ;INDICATE NOT BACKING UP.
SETZM MAXELM ; SAME FOR MULTIPLE SECTION
SETZM COBCAL ;ALLOW INIT TO DO ALL
GETITM 0,ANY ;GET FIELD IDENT
CALL CHKHSC ;CHECK FOR HIDDEN SECTION
JRST TRD.4 ;ERROR
JRST MREAD ;MULTIPLE SECTION
JRST TRD.3 ;MULTIPLE ERROR
CALL INITSD
JRST TRD.4 ;INIT FAILED = NOT FOUND
SETZM DEFALT ;INDICATE NOT DEFAULTING FIELDS
TRD.1:
CALL FIND ;GET NEXT FIELD SPECIFIED
JRST TRD.4 ; NO FIELD WAS FOUND.
JRST TRD.2 ; NO MORE FIELDS ANSWER SPECIFICATION.
CALL GETFLD ;GET FIELD ATTRIBUTES
CALL RDFLD ;MOVED IT!!!
JRST TRD.1 ;NOT USED HERE
JRST TRD.1 ;NORMAL
TRD.2: ;VET FORCED EXIT OR NO MORE FIELDS
MOVE A,TRMCHR ;SET TERMINATOR
MOVEM A,@1(ARG)
JRST TRD.5
TRD.3:
MOVEI INT.C,ERR.ML ;MULT SECT MUST BE SECT READ
SKIPA
TRD.4:
MOVEI INT.C,ERR.NF ;FLAG FIELD NOT FOUND ERROR.
MOVEM INT.C,@2(ARG)
SETZM @1(ARG) ;ERROR GIVES OK TERM CHAR
TRD.5:
CALL $HOME1
SETZM ISTAB ;MAKE SURE OF THIS
CALL $SEND ;FLUSH ANY OUTPUT
MOVE Z,@2(ARG) ;RETURN ERROR IN AC0
RET
SUBTTL MREAD READ MULTIPLE SECTION
MREAD: ;MULTIPLE SECTION READ ROUTINE
SETZM IDXSET ;INDEX NOT DONE YET
CALL MRRD ;SET UP FOR THE READ
JRST MRD.4 ; NO MORE ELEMENTS LEFT
SETZM DEFALT
MRD.1:
CALL $SEND ;FORCE UPDATE IN CASE LAST FIELD WAS
;JUSTIFIED AND WE ARE ABOUT TO SCROLL
CALL GETOFF ;GET NEXT FIELD
JRST MRD.3 ;DONE ALL
TXNE PRM,%INDEX ;IF THIS IS THE INDEX FIELD
JRST MRD.1 ; DON'T READ IT
CALL RDFLD ;DO THE READ
JRST [CALL GETIDX ;FIND CURRENT INDEX
MOVEI A,ZERO ;PUT ZEROS IN IT
IDPB A,B ;FOR THE WRITE SO THAT
IDPB A,B ;PF2 COMES BACK TO CURRENT ELEM
JRST MREAD] ;AND RESTART
SKIPA ;NORMAL
JRST MRD.3 ;VET FORCED EXIT
TXNE PRM,%PROT ;IF PROT (INDEX)
JRST MRD.2 ;THEN DONT DO IT
SKIPN TOTNRD ;IF NONE READ (OR PROT FLD)
JRST MRD.2 ;THEN IGNORE INDEX
SKIPE IDXSET ;IF INDEX SET UP -
JRST MRD.2 ;THEN DONT REPEAT IT
CALL GETIDX ;GET INDEX POINTER
AOJ A, ;ELEMENT NUMBER
PUSH P,B ;SAVE BYTE POINTER
MOVE E,B ;BYTE POINTER
MOVE B,A ;NUMBER
SETZ A, ;HIGH ORDER PART
MOVE D,[1B0+2] ;RIGHT JUST, LENGTH 2
EXTEND A,[CVTBDO ZERO ;CONVERT IT
ZERO] ;ZERO FILL
JFCL
PUSH P,FLDATR ;SAVE THIS
MOVE A,IDXRND
HLRZM A,FLDATR ;SET INDEX ATTRIBUTES
DMOVE A,MLTDSP ;GET SCREEN POSITION
CALL $POSIT ;POITION CURSOR
POP P,FLDATR ;RESTORE FLAGS
MOVE B,(P) ;POINT TO OFFSET
MOVEI C,2 ;LENGTH OF FIELD
CALL $SSTRING ;WRITE IT TO SCREEN
MOVEI A,2 ;THIS IS THE LENGTH OF THE
MOVEI D,2 ;INDEX FIELD
POP P,B ;OFFSET POINTER AGAIN
MOVE E,MLTELM ;CALCULATE THE VALUE POINTER
ADD E,MLTCNT
ADD E,MLTIDX
EXTEND A,[MOVSLJ] ;WON'T NEED THE FILLER
JFCL ;OR THIS
SETOM IDXSET ;FLAG THIS LOT
MRD.2:
MOVE E,TRMCHR ;CHECK FOR EXIT TERMINATOR
SKIPL MLTFLG ;IF NOT FIRST IN LINE
JRST [CAILE E,TRM.TB ;IF EXIT CODE
SETZM NOSCRL ; THEN DON'T ALLOW SCROLLING
JRST MRD.1] ;THEN GO FOR NEXT, ELSE -
CAIG E,TRM.TB ;CODES > TAB MEAN EXIT
JRST MRD.1 ;ROUND FOR MORE
MRD.3:
SETZM CURFLD ;SO THAT NEXT SECTION
SETZM SECFLG ;CAN BE READ WITHOUT PROBLEMS
MOVE INT.A,MLTSVA+2 ;RESTORE CONTEXT
JRST TRD.2 ;BACK FOR NORMAL RETURN
MRD.4:
MOVEI A,ERR.EM ;READ AFTER WRITE WHEN -
MOVEM A,@2(ARG) ;ARRAY WAS FULL OF DATA-
SETZM @1(ARG) ;SO RETURN ERROR TO USER
JRST TRD.5 ;HOME THE CURSOR
MRRD: ;SET UP A READ (MAYBE RE-READ)
CALL FNDLST ;FIND FIRST FREE ELEMENT
JRST [SKIPN RSCANM ;TOO FAR - IS THAT FATAL?
RET ; YES
JRST .+1] ;NO
AOS (P) ;CAN'T BE FATAL NOW
SKIPE RSCANM ;IF STARTING AT THE TOP
MOVEM A,MAXELM ;THEN PRETEND WE ARE IN BACKUP MODE
ADD A,MLTCNT ;GET ELEMENT NUMBER
AOS A
SKIPN RSCANM ;WHAT MODE?
JRST MRR.1 ;CONTINUE FROM END
MOVE B,MLTDCT ;RESTART
CAMLE A,B ;LSTELM = MIN(LAST FREE, WINDOW SIZE)
MOVEI A,(B)
MOVEM A,LSTELM
MOVEI A,1 ;FSTELM = 1
MOVEM A,FSTELM
MOVEM A,MAXFLD ;SET BACKUP MODE ON
CALL MRWRIT ;"REWRITE" THE SECTION
PJRST STF.1 ;PRESET SOME POINTERS ETC
MRR.1:
MOVEM A,LSTELM ;LSTELM = FIRST FREE
SUB A,MLTDCT
AOS A
SKIPG A ;FSTELM = MAX(1, LAST - WINDOW SIZE)
MOVEI A,1
MOVEM A,FSTELM
CALL MRWRIT ;"REWRITE" THE SECTION
MOVE A,MLTLOR ;SET CURRENT LINE
ADD A,LSTELM
SUB A,FSTELM
MOVEM A,MLTDSP
MOVN A,MLTCNT ;SET NUMBER OF ELEMENTS LEFT
ADD A,LSTELM
SOS A
MOVEM A,MLTELM
SETOM NOSCRL ;ENABLE THE SCROLLER
PJRST STF.2 ;SET UP OTHER POINTERS
SUBTTL RDFLD - READ THE NEXT FIELD
;
;CALLED BY TFRRD AND MREAD TO READ A FIELD AND DO ALL THE REQUIRED
;CHECKING AND VALIDATION.
;
;RETURN TO: .+1 IF PF2 WAS PRESSED DURING A MULTIPLE SECTION READ
; .+2 FOR MOST OTHER CASES
; .+3 WHEN A VET ROUTINE FORCED AN EXIT FROM THE READ
;
RDFLD:
SETZM SFCERR ;NO ERRORS YET
TXNN PRM,%DSPLY ;ON THE SCREEN ?
JRST [MOVEI A,ERR.ND ;INDICATE NOT DISPLAYED
MOVEM A,@2(ARG) ;ON RETURN
JRST SKPRET] ;AND GO FOR NEXT FIELD
TXNE PRM,%PROT ;IF FIELD IS PROTECTED
JRST [TXNE PRM,%MULT ;IF MULTIPLE THEN -
CALL WRITE ;- WRITE IT TO THE SCREEN
JRST SKPRET]
MOVN INT.C,PRM ;IF BOTH %MSDUP AND %PRDUP ARE ON
TXNN INT.C,%MSDUP+%PRDUP ; THEN FIELD IS MASTER DUPED
JRST [TXNE PRM,%MULT ;IF MULTIPLE THEN -
CALL WRITE ;- WRITE IT TO THE SCREEN
JRST SKPRET]
SETZM TXTTAB+.RDDBC ;CLEAR DEST BYTE COUNT
SETZM PREDUP ;INDICATE NOT PREVIOUS DUPE
MOVE A,MAXFLD ;IF WE WERE BACKING UP BUT HAVE
CAMLE A,CURFLD ; NOW COME BACK TO THE STARTING POINT
JRST RDF.0
MOVE A,MAXELM ;MUST ALSO SEE IF ON RIGHT ELEMENT
TXNE PRM,%MULT ; IF THIS IS A MULTIPLE SECTION
CAMN A,MLTELM
SKIPA ;SKIP IF BACK TO START
JRST RDF.0
SETZM MAXFLD ; OF THE BACKUP, RESET.
SETZM MAXELM
RDF.0:
SKIPE MAXFLD ;IF WE ARE BACKING UP THEN
SETOM PREDUP ;INDICATE FIELD IS PREVIOUS DUPE.
TXNE PRM,%MSDUP ;IF MASTER DUPE BUT NOT VALUE
JRST RDF.2 ; THEN TREAT LIKE NORMAL.
TXNN PRM,%PRDUP ;IF NOT PREVIOUS DUPE THEN
JRST [SKIPE MAXFLD ;IF NOT BACKING UP
JRST .+1
JRST RDF.2] ;THEN IT IS NOT PREVIOUS DUPE
SETOM PREDUP ;TREAT IT AS PREVIOUS DUPE
TXNE PRM,%DFDT ;IF DEFAULT DATE
JRST RDF.2
SKIPN DEFALT ;IF READING ALL FIELDS THEN
JRST RDF.3 ; THEN GO TO READ
MOVE A,FNUMRD ;GET LENGTH OF DATA
JRST RDF.4 ;AND MERELY CHECK REQUIRED STATUS.
RDF.1:
TXNE PRM,%MULT ;IF MULTIPLE FIELD
CALL GETMFD ;THEN CALCULATE THE OFFSETS
RDF.2:
SKIPN DEFALT ;IF READING ALL FIELDS
JRST RDF.3 ; THEN GO TO READ ROUTINE
SETZB A,INT.C ; ELSE SET SIZE TO ZERO AND
JRST RDF.4 ; GO CHECK FOR REQUIRED STATUS.
;;;;;;;; READ THE SPECIFIED FIELD ;;;;;;
RDF.3:
TXNN PRM,%NEKO ;IF ECHO IS ALLOWED
JRST [TXNE PRM,%ALPHA ;THEN SEE IF LOWER CASE IS ALLOWED
CALL CHKLWR
JRST .+2] ;AND SKIP ECHO-OFF
CALL ECOOFF ;SWITCH OFF ECHOING
CALL FLDRD ; AND THEN READ THE FIELD.
TXNE PRM,%NEKO
CALL ECOON ;BACK ON AGAIN
JUMPN B,RDF.ES ;ESCAPE WAS RETURNED FROM INTRD.
SKIPN OLDMD ;IF MASTER DUPE IS NOT TO BE TURNED
JRST RDF.4 ;ON UNLESS CHARACTERS TYPED..GO ON.
TXNE PRM,%MSDUP ;ELSE ;IF MASTER DUPE AND
TXNE PRM,%PRDUP ;NOT ON THE SCREEN
JRST RDF.4 ;THEN
TXO PRM,%PRDUP ;INDICATE THAT IT HAS VALUE.
CALL STRPRM ; AND CONTINUE
RDF.4:
CALL CKREQD ;CHECK REQUIRED ATTRIBUTE
JRST [CALL CKRQDM ;MAY NOT BE BAD
JRST SKPRET ;SEE!
JRST RDF.3] ;GO FOR IT AGAIN
SKIPGE DEFALT ;IF ONLY CHECKING REQUIRED STATUS
JRST SKPRET ;THEN GO ON TO NEXT FIELD.
JUMPE A,[SKIPE SFCERR ;IF AN ERROR OCCURED
JRST RDF.5 ; THEN CONTINUE CHECKING
JRST SKPRET] ;IF NOTHING TYPED, NO MORE PROCESSING.
SKIPN NEWDAT ;IF NOT NEW DATA (PREVIOUS DUPE)
JRST SKPRET ; THEN ALL IS OK.
SOS SUBCNT ;KEEP THE COUNTER CORRECT
CALL RFORMX ;COPY TO WORKING STORAGE
SKIPLE DEFALT ;IF WE JUST STARTED DEFAULTING
SETOM DEFALT ;THEN INDICATE NO MORE WRITING.
TXNE PRM,%MSDUP ;IF MASTER DUPE AND
TXNE PRM,%PRDUP ; NOT ON THE SCREEN
JRST RDF.5 ; THEN
TXO PRM,%PRDUP ; INDICATE THAT IT HAS VALUE.
CALL STRPRM ; AND CONTINUE
;;;;;;;;;;;;;;;;;;;; CHECK THE FIELD FOR LEGALITY ;;;;;;;;;;;;;;;
RDF.5:
TXNN PRM,%DATE ;DATE CHECK REQUIRED
JRST RDF.6 ;NOT A DATE.. CONTINUE
CALL CKDATE ;DATE CHECKING
JRST [HRROI C,MSG.ID ;ILLEGAL DATE
CALL INTERR
JRST RDF.10]
RDF.6: ;JUMP HERE IF NOT DATE
TXNN PRM,%RANGU+%RANGL ;IF NO RANGE CHECKS
JRST RDF.7 ;THEN ALL IS OK
PUSH P,VALFLD ;MOVE THE VALUE INTO A FIELD
MOVE A,[POINT 7,INTBUF] ;WITH LEADING ZEROS IF NUMERIC
MOVEM A,VALFLD
PUSH P,PRM ;SAVE BLANKING INDICATOR
TXO PRM,%ZERO ;AND FORCE IT ON
CALL WS2VAL ;MOVE IT.
POP P,PRM ;RESTORE THE VALUE
POP P,VALFLD ;AND THE POINTER
CALL CKRGLW
JRST [LOAD B,.LRANG,A ;NOT WITHIN RANGE.
ADD B,STRPNT ;PAGE.
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVEM B,ERRRNG
HRROI C,MSG.LR
CALL INTERR
JRST RDF.10]
CALL CKRGUP
JRST [LOAD B,.URANG,A ;NOT WITHIN RANGE
ADD B,STRPNT ;PAGE.
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVEM B,ERRRNG
HRROI C,MSG.UR
CALL INTERR
JRST RDF.10]
RDF.7: ;DO DATA VET WORK
TXNN PRM,%NAUTO ;FIRST SEE IF THE FIELD IS NO-AUTO-TAB
JRST RDF.7D ; NO
MOVE A,TRMCHR ;IF NOT - SEE IF LENGTH TERMINATED
CAIE A,TRM.LN ;THE FIELD
JRST RDF.7D ; CONTINUE IF OTHER
CALL ECOOFF ;DON'T ECHO IF BAD CHARACTER
HRROI C,MSG.NT ;IF IT WAS - THEN TELL THE USER
SKIPN NEWAUT ;IF MESSAGES ALLOWED
RDF.7A:
CALL PUTERR ;TO TAB OUT OF THE FIELD
DMOVE A,LINFLD ;POSITION TO ONE AFTER THE FIELD
ADD B,LENFLD
ADD B,SUBCNT
CALL $POSIT
CALL $SEND
SETZ C, ;NO FIELD LENGTH
CALL SETLEN
CALL $RDCHAR ;READ THE RESPONSE (ONE CHARACTER)
MOVEI B,FCCCHR ;SEE IF IT IS LEGAL
TDNE B,CHRTAB(A) ;ONLY ALLOW <CR> <LF> <TAB> <BS>
CAIN A,ESC ;NOT <ESC>
JRST [HRROI C,MSG.NX
JRST RDF.7A]
PUSH P,A
SKIPE ERRDSP
CALL CLRERR ;CLEAR THE ERROR MESSAGE IF PRESENT
DMOVE A,LINFLD ;AND REPOSITION READY FOR WHATEVER
ADD B,LENFLD
ADD B,SUBCNT
CALL $POSIT
CALL $SEND
SETZM ERRDSP ;ERROR LINE IS FREE NOW
CALL ECOON ;ALLOW ECHOS
POP P,A
CAIN A,BACKSP ;<BS> IS SPECIAL
JRST RDF.7B
MOVE A,[TRM.TB ;<TAB>
TRM.LF ;<LF>
0 ;<VT>
TRM.FF ;<FF>
TRM.CR]-TAB(A) ;<CR>
MOVEM A,TRMCHR
JRST RDF.7D
RDF.7B:
SETOM BYPASS ;SET BYPASS MODE ON
JRST RDF.3 ;AND "READ" A DELETE
RDF.7D:
LOAD A,.VETNO ;GET VET NUMBER
JUMPE A,SKPRET ;ISN'T ONE
ADJBP A,[POINT 18,DVTAB] ;POINT TO TABLE
ILDB A,A ;AND GET ENTRY
JUMPE A,SKPRET ;NO VET ROUTINE THERE
MOVE E,VALFLD ;POINT TO DATA
HRRM E,LINKBF+1 ;ALSO SET UP FORTRAN BLOCK
MOVEM E,LINKBS ;PUT IT IN LINK AREA
MOVE E,LENFLD ;GET LENGTH
HRLI E,(3B4) ;COBOL REQUIREMENT
MOVEM E,LINKBS+1 ;PUT THIS IN AS WELL
MOVEM A,LINKBS+3 ;SAVE 'A' FOR NOW
LOAD B,.FIELD ;POINT TO THE FIELD NAME
ADD B,STRPNT
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVEM B,LINKBS+2 ;SAVE IT FOR THE VETTER
HRRM B,LINKBF+4 ;SAVE IN FORTRAN BLOCK AS WELL
SETZ A, ;CLEAR A COUNTER
RDF.12:
ILDB E,B ;GET A CHARACTER FROM THE NAME
SKIPE E ;DONE IF NULL
AOJA A,RDF.12 ;COUNT IT IF NOT NULL
HRLI A,(3B4) ;SET THE REQUIRED BITS FOR COBOL
EXCH A,LINKBS+3 ;SAVE IT AND GET 'A' BACK
SETZM DSTAT ;DEFAULT IS OK
SETZM ERRBUF ;IN CASE IT RETURNS NONE
MOVEM ARG,ACSAV+16 ;SAVE ARG POINTER
MOVEI ARG,ACSAV
BLT ARG,ACSAV+15 ;SAVE ALL
MOVEI ARG,LINKBK+1 ;GET LINK TO FUTURE
SKIPN COBAPP ;IF THIS IS 'A' FORTRAN APPLICATION
MOVEI ARG,LINKBF+1 ; THEN SET THE POINTER
MOVE E,[FLDPTR,,SAVCTX] ;SAVE CONTEXT FOR
BLT E,SAVCTX+13 ;WHEN WE RETURN
PUSH P,SECFLG ;WE NEED THIS LATER
SETOM VETCAL ;NOW ENTERING VET ROUTINE
CALL (A) ;GO TO IT
SETZM VETCAL ;DONE
POP P,SECFLG ;RESTORE POINTER
MOVE A,[SAVCTX,,FLDPTR] ;RESTORE DATA
BLT A,FLDPTR+13
MOVSI ARG,ACSAV ;RESTORE ALL
BLT ARG,ARG
SKIPN A,DSTAT ;GET STATUS
JRST SKPRET ;OK
JUMPG A,RDF.8 ;REWRITE
PUSH P,A
SETZM ERRRNG
HRROI C,ERRBUF ;POINTER TO MESSAGE
SKIPE ERRBUF ;DONT DO IT IF ZERO
CALL PUTMSG ;WRITE ERROR MSG
POP P,A
MOVMS A
CAIL A,4 ;CODES 4 AND OVER MEAN FORCED EXIT
JRST RDF.9
JRST @[SKPRET ;A=-1 - REWRITE
RDF.8 ;A=-2 - RETURN
.+1]-1(A) ;A=-3 - REREAD
CALL INICUF ;REINIT THIS FIELD
SETZM DEFALT ;IN CASE IT WAS ON - NOT NOW
JRST RDF.2 ;A=-3 - REREAD
RDF.8:
MOVE A,VALFLD ;POINT TO VALUE
MOVE B,LENFLD ;FORCE FULL LENGTH
CALL TRNCBL ;TRIM TRAILING SPACES
MOVE A,B ;COPY LENGTH
PUSH P,DEFALT
SETOM DEFALT ;DONT NEED PART OF REFORM
CALL REFORM ;PUT DATA INTO STORAGE
JFCL
POP P,DEFALT
CALL WRITE
CALL FILL ;FILL IT OUT
CALL $SCHKPNT ;EMPTY BUFFER IF REQUIRED
JRST SKPRET ;ALL OK
RDF.9:
CALL INICUF ;REINIT THIS FIELD
MOVEI A,TRM.VE ;VET FORCED EXIT
MOVEM A,TRMCHR
JRST SKPRT2
RDF.10: ;;ERROR (NOT WITHIN RANGE, ILLEGAL DATE) DISCOVERED.
PUSH P,INT.A
PUSH P,CURFLD
MOVE INT.A,CURFLD
SETOM HXFLAG ;HIDDEN FIELDS CAN BE INITED OK
SETZM CURFLD
CALL INITAL ;RE-INIT THE CURRENT FIELD
SETZM HXFLAG
POP P,CURFLD
POP P,INT.A
JRST RDF.3 ;REREAD THE FIELD.
;*************** HANDLE THE ESCAPE SEQUENCES ****************
RDF.ES:
SKIPE SFCERR ;IF WE HAD A SUBFIELD ERROR
MOVE A,LENFLD ; THEN BLANK THE WHOLE FIELD
PUSH P,A ;SAVE THE CHARACTER COUNT OF FIELD.
SETZM COBCAL ;INITSD MUST ONLY DO ONE
SKIPE SFCERR ;IF AN ERROR OCCURED, CLEAR THE FLAG
SETZM PREDUP
SKIPL PREDUP ;IF FIELD IS NOT PREV DUPE
CALL SV.NUMRD ;SAVE COUNT OF # RD SO FAR
CALL INICUF ;INITIALIZE CURRENT FIELD.
POP P,A ;RESTORE CHARACTER COUNT TO 'A'.
JRST @[ESC.P ;BLUE = PF1 - BACKUP FIELD
ESC.Q ;RED = PF2 - BACKUP SECTION
ESC.R ;BLACK = PF3 - REWRITE SCREEN
RDF.2 ; PF4 - HELP (REREAD)
RDF.2]-1(B) ; ^W - REREAD FIELD
ESC.P:
SETZM MLTFLT ;NEED A FLAG FOR LATER
TXNE PRM,%PRDUP ;IF THIS IS A PREVIOUS DUPE FIELD
JRST ESC.P0
SKIPN MAXFLD ;IF NOT BACKING UP
JRST [JUMPG A,RDF.2 ;THEN IF ERASE CURRENT FIELD, DO IT
JRST ESC.P1] ;ELSE BACKUP ONE FIELD.
ESC.P0:
SKIPLE PREDUP ;IF FLAG SET
SETOM PREDUP ; THEN RESTORE PREDUP
SKIPN SFCERR ;IF THERE WAS A SUBFIELD ERROR
SKIPL PREDUP ;OR IF SOME CHARACTERS WERE TYPED
JRST [SETOM PREDUP ;THEN RAISE THE PREV-DUPE FLAG
JRST RDF.2] ; AND REREAD FIELD.
ESC.P1:
MOVE A,CURFLD ;BACKUP TO PREVIOUS FIELD.
SKIPE MAXFLD ;IF CURRENTLY BACKING UP,
JRST ESC.P2 ; THEN CONTINUE
MOVEM A,MAXFLD ;ELSE START BACKUP HERE
SETZM MAXELM
TXNN PRM,%MULT ;IF THIS IS A MULTIPLE SECTION
JRST ESC.P2
MOVE E,MLTELM ;THEN SAVE THE CURRENT ELEMENT NUMBER
MOVEM E,MAXELM
ESC.P2:
PUSH P,A ;SAVE THE CURRENT FIELD NUMBER.
SETZM CURFLD ;PREPARE TO FIND PREVIOUS FIELD
SETZM SECFLG ;BY STARTING AT BEGINNING OF
SETZM LASTFLD ;THE READ AND SAVING THE PREVIOUS
ESC.PA:
CALL FIND ;FIND THE NEXT FIELD
JFCL ;WE SHOULD NOT GET THESE
JFCL ;THESE RETURNS.
TXNN PRM,%DSPLY ;IF FIELD NOT DISPLAYED, THEN
JRST ESC.PA ;IT IS NOT OF INTEREST.
TXNE PRM,%PROT ;IF FIELD IS PROTECTED, THEN IT
JRST ESC.PA ;IS NOT OF INTEREST EITHER.
MOVN INT.C,PRM ;IF FIELD IS SET-MASTER DUPE
TXNN INT.C,%MSDUP+%PRDUP ;THEN IT IS NOT OF INTEREST.
JRST ESC.PA
MOVE A,CURFLD ;IF THIS FIELD'S NUMBER IS
CAMN A,(P) ;IS THE SAME AS THE CURRENT ONE
JRST ESC.PB ;THEN LASTFLD WILL HAVE PREVIOUS ONE
MOVEM A,LASTFLD ;ELSE SAVE THIS FIELD AS PREVIOUS FIELD.
JRST ESC.PA ;AND CONTINUE SEARCHING FOR CURRENT.
ESC.PB:
ADJSP P,-1 ;RESTORE THE STACK
SKIPE A,LASTFLD ;IF LAST FIELD IS STILL ZERO THEN
JRST ESC.PC
TXNN PRM,%MULT ;IF NOT MULTIPLE -
JRST [HRROI C,MSG.BU ;WARN THE USER
CALL INTERR
CALL GETFLD ;GET FIELD INFO
JRST RDF.2]
CALL ESCROL ;ELSE TRY TO SCROLL DOWN
JRST SKPRET
MOVE A,MLTBAS ;SET UP CURFLD FOR WHERE
ADD A,MLTNMF ;WE SHOULD BE POINTING NEXT
SUBI A,2
MOVEM A,CURFLD
SETOM MLTTMP ;NOW AT LAST OF ROW
CALL GETNXT ;CHECK-UP ON LAST FIELD
JFCL
TXNE PRM,%PROT ;IF PROT AT END OF LINE
JRST [SOS MLTTMP ;THEN BACKUP ONE
SOS CURFLD ;- - " - -
JRST .+2] ;AND SKIP
AOS LASTFLD ;ELSE ALLOW FOR IT
SETOM MLTFLT ;SET THE FLAG
MOVE A,CURFLD ;START AGAIN WITH THE CURRENT FIELD
JRST ESC.P2
ESC.PC:
SKIPN MLTFLT ;IF SET THEN DONT BACK UP
SOS A ;ELSE USE THIS AS NEXT FIELD
MOVEM A,CURFLD ;TO READ
TXNN PRM,%MULT ;IF MULTIPLE FIELD
JRST SKPRET ;IT ISN'T
SUB A,MLTBAS ;THEN CALCULATE THE NEW
SUB A,MLTNMF ;VALUE FOR THE COUNTER
AOJ A,
MOVEM A,MLTTMP
JRST SKPRET ;GO GET IT.
SUBTTL ESCAPE-Q HANDLING
ESC.Q:
MOVE A,CURFLD ;SAVE CURRENT FIELD #
SETZM CURFLD
SETZM SECFLG ;INITIALIZE SECTION TABLE
SKIPN MAXFLD ;IF NOT IN BACKUP YET
JRST [MOVEM A,MAXFLD ;THEN START BACKUP HERE
SETZM MAXELM
TXNN PRM,%MULT ;IF THIS IS A MULTIPLE SECTION
JRST .+1
MOVE E,MLTELM ;THEN SAVE THE CURRENT ELEMENT NUMBER
MOVEM E,MAXELM
JRST .+1]
TXNN PRM,%MULT ;IF NOT MULTIPLE -
JRST SKPRET ;RESTART CURRENT READ
PUSH P,A ;STORE THE OLD POINTERS FOR COMPARISON
PUSH P,MLTELM
ESC.QA:
MOVN E,MLTNMF ;PRESET A COUNTER
MOVEM E,MLTTMP
ESC.QB:
CALL GETOFF ;GET THE NEXT ONE
JFCL
TXNE PRM,%PROT ;IF PROTECTED
JRST ESC.QB ; THEN IGNORE IT
MOVE A,CURFLD ;SEE IF WE HAVE GOT BACK TO THE START
CAME A,-1(P)
JRST ESC.QC ; NO - OK, MUST BE FIRST USEFUL FIELD
MOVE A,MLTELM
CAME A,0(P)
JRST ESC.QC ;SAME AGAIN
CALL ESCROL ;WE WERE IN THE FIRST - SCROLL DOWN
JRST ESC.QC
SETZM CURFLD ;CLEAR INDEX AGAIN
JRST ESC.QA ;GO FOR THE FIRST AGAIN
ESC.QC:
ADJSP P,-2
SOS CURFLD ;BACK OFF THE FIELD NUMBER
SOS MLTTMP
JRST SKPRET
SUBTTL ESCAPE-R HANDLING
ESC.R: ;RE FORMAT SCREEN
PUSH P,INT.A ;SAVE SOME STUFF
PUSH P,SECFLG ;SAVE THE SECTION INITIALIZATION
PUSH P,CURFLD
PUSH P,FLDPTR ;SAVE POINTER TO FIELD DATA
PUSH P,A ;SAVE THE CHARACTER COUNT
SETZM SUBCNT ;MAKE SURE WE ARE IN THE RIGHT PLACE
SETZB INT.A,CURFLD
CALL $SCLEAR ;CLEAR ALL OF SCREEN
CALL .OINIT ;THEN CLEAR OPTIMISER AS WELL
CALL .OMSET ;RESET SCROLL FLAGS
ESC.RF: ;ESC.R LOOP
CALL FIND
JRST ESC.RG ;NOT-FOUND.
JRST ESC.RG ;RESTORE REGISTERS.
;FOUND IT.
TXZN PRM,%DSPLY ;DO THOSE PREVIOUSLY ON SCREEN
JRST ESC.RF
CALL GETFLD ;GET FIELD ATTRIBUTES
TXNE PRM,%MULT ;IF MULTIPLE FOUND THEN SPECIAL
JRST ESC.RM ; DO MULTIPLE SECTION WORK
CALL TWRITE ;WRITE THE TEXT IF THERE IS ANY
TXO PRM,%DSPLY ;RESET THE DISPLAY BIT
MOVE A,LENFLD ;IF THIS IS A DEFAULT DATE FIELD
TXNE PRM,%DFDT
CALL SV.NUMRD ;THEN WRITE SOMETHING SENSIBLE
CALL WRITE
CALL FILL
CALL $SCHKPNT ;FLUSH BUFFER IF NECESSARY
JRST ESC.RF
ESC.RG:
POP P,A ;RESTORE THE CHARACTER COUNT
POP P,FLDPTR ;MAKE SURE WE CLEAR THE RIGHT ONE
SKIPE MAXFLD ;DON'T RE-INIT THE FIELD IF BACKING UP
SKIPN A ; AND THE FIELD HAS NOT BEEN CHANGED YET
SKIPA
JRST ESC.RH
MOVE INT.A,0(P) ;RESTORE CURRENT FIELD.
SETZM CURFLD
MOVE A,LENFLD ;IF THIS IS A MULTIPLE FIELD
TXNN PRM,%MULT ;THEN WE NEED TO FILL THE
CALL SV.NUMRD ;WHOLE OF THE FIELD
CALL INITSD ;MAKE SURE WE POINT AT IT.
JFCL
POP P,CURFLD
POP P,SECFLG ;RESTORE SECTION TABLE STUFF
POP P,INT.A
JRST RDF.1
ESC.RH:
POP P,CURFLD
POP P,SECFLG ;RESTORE SECTION TABLE STUFF
POP P,INT.A
SOS CURFLD ;MAKE SURE WE POINT TO THE RIGHT THINGS
SOS MLTTMP
JRST SKPRET
ESC.RM: ;MULTIPLE SECTION IS SLIGHTLY DIFFERENT
TXO PRM,%DSPLY
CALL MRWRIT ;REWRITE THE MULTIPLE SECTION
JRST ESC.RF ;CONTINUE
;COMMON SUBROUTINE TO SCROLL BACK UP A LINE IF WE NEED TO
ESCROL:
CALL GETIDX ;FIND THE INDEX FIELD
SUB A,MLTDCT
AOS A
JUMPLE A,ESR.1 ;HAVEN'T SCROLLED YET
SETZM FLDATR ;DON'T ALLOW RENDITION
CALL $SEND ;MAKE SURE SCREEN IS CORRECT FIRST
CALL $SCRLD ;SCROLL DOWN
SOS MLTELM ;COUNT IT
SOS A,FSTELM ;POINT TO ELEMENT TO WRITE
SOS LSTELM ;REMEMBER WE SCROLLED DOWN
CALL WRTELM ;WRITE OUT THE ELEMENT
JRST SKPRET
ESR.1:
SOS A,MLTDSP ;BACK ONE LINE
CAML A,MLTLOR ;STILL OK?
JRST [SOS MLTELM ;YES - PREVIOUS ELEMENT
JRST SKPRET]
HRROI C,MSG.BU ;NO - WARN USER
MOVE INT.C,TXTTAB+.RDDBC
CALL INTERR
SOS CURFLD ;KEEP CORRECT FIELD
AOS MLTDSP ;STAY ON SAME LINE
MOVN E,MLTNMF ;RESET THE FIELD COUNTER
AOJ E,
MOVEM E,MLTTMP
RET
CKREQD: ;CHECK REQUIRED ATTRIBUTE
SKIPN A ;IF SOMETHING WAS ENTERED THEN OK
TXNN PRM,%REQD ;IF NOTHING ENTERED BUT FIELD OPTIONAL
AOS (P) ; THEN GIVE GOOD RETURN
RET ; ELSE GIVE BAD (NOSKIP)RETURN.
CKRQDM: ;CHECK FOR MULTIPLE ALLOWED EXIT
TXNN PRM,%MULT ;IF MULTIPLE
JRST CKRQDX
SKIPE SUMRED ;AND NO CHARACTERS YET
JRST CKRQDX
MOVE E,TRMCHR ;AND IT WAS AN EXIT CHAR
CAIG E,TRM.TB
JRST CKRQDX
SETOM MLTFLG ;THEN PRETEND AT END
RET
CKRQDX:
HRROI C,MSG.RQ ;ELSE IT REALY IS BAD
CALL INTERR
AOS (P) ;SKIP RETURN
RET
INICUF: ;INITIALIZE CUFRENT FIELD BEFORE HANDLING THE
; ESCAPE SEQUENCE.
PUSH P,B ;SAVE ESCAPE TYPE.
PUSH P,INT.A ; AS WELL AS THE FIELD NUMBER
PUSH P,CURFLD
SKIPE MAXFLD ;IF BACKING UP FIELDS
JRST INC.2 ;THEN TREAT LIKE PREVIOUS DUPE.
TXNE PRM,%PRDUP ;IF THIS IS A PREVIOUS DUPE FIELD
JRST INC.2 ; THEN HANDLE IT DIFFERENTLY.
MOVE INT.A,CURFLD ;RE-INITIALIZE FILLERS
SETZM CURFLD
CALL INITSD ; BY CALLING INTERNAL INITIALIZATION.
JFCL ;SHOULD NOT HAPPEN.
INC.1: ;COMMON EXIT.
POP P,CURFLD ;RESTORE THE FIELD INDICATORS
POP P,INT.A
POP P,B ; AND THE ESCAPE TYPE.
RET
INC.2: ;HANDLE THE PREVIOUS DUPE FIELD.
SKIPGE PREDUP ;IF FIRST CHAR OF PRE-DUP NOT TYPED
JRST INC.1 ; THEN FIELD IS STILL ON SCREEN
CALL FORMAT ;ELSE RESET WITH
CALL WS2VAL ; THE FILLERS.
CALL BLANK ; WITH FILLERS.
SETZ A, ;AND RESET THE COUNT
CALL SV.NUMRD
CALL $SCHKPNT ;SEND OUT BUFFER IF NECESSARY.
JRST INC.1
SUBTTL REFORM - REFORMAT VALUE => W.S. => VALUE
RFORMX: ;DO PARTIAL REFORM
SKIPE ISTAB ;IF PREVIOUS DUPE TABBED OVER
RET ; THEN OK
CALL SV.NUMRD ;SAVE NUMBER OF BYTES READ
MOVE E,OFFFLD
MOVE D,LENFLD ;DEST LENGTH
MOVE C,A ;PRESERVE COUNT
TXNE PRM,%ALPHA+%PUNCT ;IF NOT NUMERIC
JRST [MOVE B,VALFLD ; THEN LEFT JUSTIFY IT
EXTEND A,[MOVSLJ
SPACE]
JFCL
JRST RFX.2]
MOVE A,LENFLD ;IF NUMERIC - THEN USE THE FULL LENGTH
MOVE B,VALFLD
EXTEND A,[MOVSRJ
ZERO]
JFCL
PUSH P,FILCHR ;USE "0" TO BACK FILL
MOVEI A,ZERO
MOVEM A,FILCHR
TXNN PRM,%NEKO ;DON'T FILL IF NO-ECHO
CALL FILL2 ;FILL BEHIND THE DATA IF REQUIRED
POP P,FILCHR
RFX.2:
SKIPL DEFALT ;IF NOT DEFAULTING VALUES
CALL WS2VAL ;PUT SPACED OUT FIELD IN CORE TABLE
RET
REFORM:
SKIPE ISTAB ;IF PREVIOUS DUPE TABBED OVER
JRST SKPRET ;THEN IS IN GOOD FORM.
TXNN PRM,%ALPHA!%PUNCT
TXNN PRM,%NUMER ;NUMERIC
SKIPA
JRST RFM.1 ;YES - NEEDS SPECIAL CARE
CALL SV.NUMRD ;SAVE NUMBER OF BYTES READ
MOVE B,VALFLD
MOVE E,OFFFLD
MOVE D,A ;DEST LENGTH
EXTEND A,[MOVSLJ
SPACE]
JFCL ;DUMMY ERROR RETURN
SKIPL DEFALT ;IF NOT DEFAULTING VALUES
CALL WS2VAL ;PUT SPACED OUT FIELD IN CORE TABLE
JRST SKPRET ;SKIP RETURN = NO CHANGES
RFM.1: ;NUMERIC FIELD -- PUT NULL BYTE AT END
MOVE B,VALFLD ;SET-UP FOR RIGHT JUSTIFY MOVE
MOVE D,LENFLD
TXNN PRM,%FULL ;FULL FIELD REQUIRES NO MOD. OF SCREEN
CAMN A,D ;NONE NEEDED IF ALL OF FIELD FILLED
AOS (P) ;SET UP A SKIP IF ABOVE CONDITIONS MET
MOVE E,OFFFLD
TXNE PRM,%SFDEF ;IF THIS IS A SUBFIELD
JRST RFM.2 ; THEN DO IT
MOVE C,B ;CHECK FOR LEADING MINUS OR PLUS.
ILDB Z,C ;GET LEAD CHARACTER
PUSH P,Z ;SAVE Z
CAIE Z,"-" ;IF A SIGN WAS TYPED (EITHER MINUS OR
CAIN Z,"+" ;PLUS)
JRST [MOVEI Z,ZERO ;THEN REPLACE IT WITH A LEADING ZERO
DPB Z,C ; SO THAT MOVE CAN WORK EASILY AND
JRST .+1] ; CONTINUE NORMALLY.
TXNE PRM,%DATE ;IF FIELD IS A DATE AND
SKIPE C,A ; NO CHARACTERS TYPED USE ZERO LENGTH
MOVE C,D ; ELSE USE FULL LENGTH.
EXTEND A,[MOVSRJ ;MOVE & JUSTIFY
ZERO] ;ZERO FILL
JFCL ;IGNORE ERRORS
JRST RFM.3
RFM.2: ;TAKE CARE OF SUB-FIELD
MOVE C,B ;POINT TO VALUE
ILDB Z,C ;GET FIRST CHAR
PUSH P,Z ;SAVE IT FOR LATER
CAIE Z,"-" ;IF IT WAS A SIGN
CAIN Z,"+"
JRST [MOVEI Z,ZERO ;THEN REPLACE IT WITH ZERO
DPB Z,C
JRST .+1] ;AND CONTINUE
MOVE C,D ;SAVE LENGTH
EXTEND A,[MOVSLJ ;LEFT JUSTIFY & FILL FRACTION
ZERO]
JFCL
RFM.3:
POP P,Z ;RESTORE CHAR
MOVE B,OFFFLD ;POINTER TO NEW VALUE
CAIN Z,"-" ;IF FIRST CHARACTER IS MINUS SIGN
IDPB Z,B ;THEN RESAVE IT
MOVE A,C ;RESTORE LENGTH
CALL SV.NUMRD ;SAVE NUMBER READ
SKIPL DEFALT ;IF NOT DEFAULTING
CALL WS2VAL ; - XFER BACK TO VALUE
RET
SUBTTL CKRG?? - CHECK RANGES; LW=LOWER, UP=UPPER, DATE=DATE
CKRGUP:
TXNN PRM,%RANGU
JRST SKPRET ;NO RANGE CHECKING.
LOAD E,.URANG,C ;GET ADDRESS OF UPPER RANGE STRING.
ADD E,STRPNT ;PAGE.
HRLI E,(POINT 7,0) ;MAKE IT A BYTE POINTER
TXNN PRM,%DATE ;NO..BUT IS IT ANOTHER TYPE OF DATE?
JRST CKRGU2 ;NOT A DATE.
MOVE A,DATTYP ;GET THE TYPE OF DATE.
CAIN A,%DATJU ;IS IT JULIAN ?
JRST CKRGU2 ;YES..TREAT NORMALLY.
CALL DATRNG ;DATE (NON-JULIAN) SO DO SPECIAL.
SKIPL E ;IS UPPER RANGE .LT. DATE ?
AOS (P) ;NO.. THUS IT IS OK.
RET ;RETURN.
CKRGU2:
CALL CKRGSU ;DO SET-UP
CALL CMPRNG ;COMPARE RANGE (DATE:RANGE)
SKIPG C ;IF DATE .LE. RANGE
AOS (P) ;THEN SKIP RETURN.
RET
CKRGLW:
TXNN PRM,%RANGL
JRST SKPRET ;NO CHECK NEEDED
LOAD E,.LRANG,C ;ADDRESS OF LOWER RANGE STRING.
ADD E,STRPNT
HRLI E,(POINT 7,0) ;MAKE IT A BYTE POINTER
TXNN PRM,%DATE ;NO..BUT IS IT ANOTHER TYPE OF DATE?
JRST CKRGL2 ;NOT A DATE, TREAT NORMALLY.
MOVE A,DATTYP ;GET TYPE OF DATE.
CAIN A,%DATJU ;IS IT JULIAN ?
JRST CKRGL2 ;YES..TREAT NORMALLY.
CALL DATRNG ;DATE (NON-JULIAN) SO DO SPECIAL.
SKIPG E ;IS LOWER RANGE .GT. DATE ?
AOS (P) ;NO.. THUS IT IS OK.
RET ;RETURN.
CKRGL2:
CALL CKRGSU ;SET-UP
CALL CMPRNG ;COMPARE DATE:RANGE
SKIPL C ;IF DATE .GE. RANGE
AOS (P) ;THEN SKIP RETURN
RET ;ELSE FALL THRU.
CKRGSU:
MOVE A,LENFLD
MOVE D,A ;EQUAL LENGTHS
MOVE B,OFFFLD ;SRC PTR = VALUE AFTER REFORMAT
HRLI E,(POINT 7,0) ;FORM A BYTE POINTER.
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;IF THIS IS NUMERIC
SKIPA
MOVE B,[POINT 7,INTBUF] ;THEN USE STORED VALUE.
RET
;START OF ROUTINE TO COMPARE RANGE
CMPRNG:
;;A,B CONTAIN LENGTH, BYTE POINTER
;;D,E CONTAIN LENGTH, BYTE POINTER
PUSH P,A ;SAVE THE REGISTERS.
PUSH P,B
PUSH P,D
PUSH P,E
SETZM ISNEG ;INDICATE NO NEGATIVES SEEN.
EXTEND A,[CMPSE] ;COMPARE STRINGS EQUAL
SKIPA
JRST [SETZ C, ;INDICATE EQUAL
JRST CMPR90] ; AND RETURN
MOVE E,(P) ;RESTORE VALUES
MOVE D,-1(P)
MOVE B,-2(P)
MOVE A,-3(P)
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;IF FIELD IS ALPH OR ALPHANUMERIC
JRST CMPR20 ; THEN FORGET ABOUT MINUS SIGNS.
ILDB C,B ;DETERMINE IF FIRST BYTE OF
CAIE C,"-" ; OF DATA IS NEGATIVE
JRST CMPR10 ;AND IF NOT JUMP
ILDB C,E ;DETERMINE IF FIRST BYTE OF
CAIE C,"-" ; OF RANGE IS NEGATIVE
JRST [SETO C, ;AND IF NOT THEN D .LT. R
JRST CMPR90] ; AND EXIT.
SETOM ISNEG ;INDICATE THAT BOTH ARE NEGATIVE
JRST CMPR20
CMPR10: ;HERE WHEN DATA NOT NEGATIVE
ILDB C,E ;DETERMINE IF RANGE IS NEGATIVE
CAIN C,"-" ;IF IT IS NEGATIVE
JRST [MOVEI C,1 ; THEN DATA .GT. RANGE
JRST CMPR90] ; IS SET AND EXIT
CMPR20: ;HERE WHEN BOTH HAVE THE SAME SIGN AND NOT EQUAL
MOVE B,-2(P) ;RESTORE BYTE POINTERS
MOVE E,(P)
EXTEND A,[CMPSL] ;SO COMPARE STRINGS
SKIPA C,[1] ;INDCATE DATA .GT. RANGE
SETO C, ; OTHERWISE DATA .LT. RANGE
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;IF NOT A NUMERIC
JRST CMPR90 ;THEN WE ARE DONE
TXNE PRM,%DATE ; IF SPECIAL NUMERIC
JRST CMPR90 ; THEN DONE ALSO
SKIPE ISNEG ;IF BOTH SIGNS WERE NEGATIVE
MOVNS C ;THEN RESULT IS REVERSED
CMPR90:
POP P,E ;RESTORE THE ARGUMENTS
POP P,D
POP P,B
POP P,A
RET ;AND RETURN
DATRNG: ;TEST USER SUPPLIED DATE AGAINST RANGE
;AND SET 'E' -1,0,1 FOR (LT,EQ,GT)
MOVE F,[3 ;CANADA
4 ;COBOL
1 ;DASH
2 ;DEC
0 ;JULIAN (NOT DONE HERE)
2 ;MILITARY
1](A) ;SLASH
MOVE B,E ;COPY THE POINTER
SETZ INT.A, ;AND SET A FLAG
CALL INPD0 ;USE THE INTERNAL ENTRY POINT
JRST [SETZ E, ; ERROR - ASSUME DATE OK
RET]
PUSH P,B ;SAVE THE VALUE
MOVE B,VALFLD ;POINT TO THE DATE ENTERED
CALL INPD0 ;AND CONVERT IT AS WELL
JFCL
POP P,A ;NOW COMPARE WITH RANGE
SETO E,
CAML A,B
AOS E ;A>=B
CAMLE A,B
AOS E ;A>B
RET
MONTHL: ;TABLE OF MONTH LENGTHS
^D31
^D28
^D31
^D30
^D31
^D30
^D31
^D31
^D30
^D31
^D30
^D31
CKDATE: ;CHECK THE VALIDITY OF THE DATE
SKIPN FNUMRD ;SEE IF ANYTHING TYPED
SKIPE SFCERR ; OR AN ERROR OCCURED
SKIPA
JRST SKPRET ;NO - DON'T DO VALIDITY CHECK
MOVE A,DATTYP ;IF THIS IS JULIAN THEN DIFFERENT
CAIN A,%DATJU
JRST CKD.2 ;....
SKIPE A,MONTH ;GET MONTH NUMBER
SKIPN B,DAY ;AND THE DAY
RET ; BAD IF EITHER IS ZERO
CAMG B,MONTHL-1(A) ;IF THE DAY IS IN RANGE
JRST SKPRET ; THEN OK
CAIE A,2 ;ELSE IF FEBRUARY
RET
CAIE B,^D29 ;AND IT'S THE 29TH
RET
CKD.1:
MOVE A,YEAR ;THEN SEE IF IT'S A LEAP YEAR
TRNE A,3
RET ;NO - SO FAILED
SKIPN LONGDT ;IF SHORT FORMAT DATE
JRST SKPRET ; THEN ALL OK
IDIVI A,^D100 ;ELSE, ONLY LEAP YEAR IF NOT A CENTURY
SKIPE B
JRST SKPRET
TRNN A,3 ;OR IT IS A CENTURY AND THE CENTURY
AOS (P) ; IS DIVISIBLE BY 4
RET
CKD.2: ;SEE IF JULIAN DATE IS OK
SKIPN B,DAY
RET ; BAD IF ZERO
CAIG B,^D365 ;IF IN RANGE
JRST SKPRET ; THEN OK
CAIE B,^D366 ;IF NOT 366
RET ; THEN ALWAYS ERROR
JRST CKD.1 ;ELSE SEE IF LEAP YEAR
SUBTTL MULTIPLE SECTION SUPPORT ROUTINES
;THIS SET OF SUBROUTINES IS FOR THE SPLIT SCREEN SCROLLING FACILITY
SETOFF: ;PRESET THE IMPORTANT DATA
MOVE E,MLTIDX ;POINT TO INDEX FIELD VALUE
MOVEI A,ZERO ;AND SET IT TO ZERO
IDPB A,E
IDPB A,E
STF.1:
SETOM NOSCRL ;ENABLE SCROLLING
MOVE E,MLTLOR ;START AT THE TOP LINE OF THE AREA
MOVEM E,MLTDSP
MOVN E,MLTCNT ;SET UP NUMBER OF ELEMENTS
MOVEM E,MLTELM
STF.2:
MOVN E,MLTNMF ;AND SET NUMBER OF FIELDS
MOVEM E,MLTTMP
MOVEM INT.A,MLTSVA+2 ;SAVE PARTIAL CONTEXT
MOVE INT.A,CURFLD
MOVEM INT.A,MLTSVA+1
MOVE INT.A,SECFLG
MOVEM INT.A,MLTSVA
MOVN INT.A,MLTSEC ;FORCE THIS SECTION IN
SETZM SECFLG ;AT THE START
POPJ P,
GETOFF: ;FIND NEXT FIELD AND SET OFFSET
SETZM MLTFLG ;MAY NOT BE FIRST
AOSG MLTTMP ;MORE FIELDS?
JRST GETFA ;YES - OK
AOSL MLTELM ;NO - MORE ELEMENTS?
RET ;NO - DONE
AOS MLTDSP ;NEXT LINE OF DISPLAY
MOVE E,MLTHIR ;IF DISPLAY IS NOT -
CAML E,MLTDSP ;- OUTSIDE THE ASSIGNED AREA THEN OK
JRST [SKIPN MAXFLD ;IF NOT BACKING UP THEN NEW ELEMENT
CALL WRTELX ;DISPLAY NEW ELEMENT
JRST GETFB]
MOVEM E,MLTDSP ;ELSE - RESET IT
CALL $SCRLU ;SCROLL UP
AOS FSTELM ;REMEMBER THAT WE SCROLLED UP
SKIPE NOSCRL ;ONLY WRITE NEXT IF WE CAN
CALL WRTELX ;DISPLAY NEW ELEMENT
GETFB:
MOVN E,MLTNMF ;RESET THE FIELD COUNT
MOVEM E,MLTTMP
SETOM MLTFLG ;FIRST FIELD IN ELEMENT
AOS MLTTMP ;BECAUSE NORMAL ENTRY WOULD!
SETZM IDXSET ;SO WE GET INDEX SET UP
SETZM SUMRED ;NOTHING READ IN THIS ELEMENT YET
SETZM CURFLD ;FORCE RESTART
GETFA:
CALL FIND ;A FIELD
RET ;FAILED
RET
CALL GETFLD ;GET FIELD ATTRIBUTES
CALL GETMFD ;GET OFFSET & LINE
CALL LD.NUMRD ;RESET BECAUSE IT IS NOW WRONG
MOVE E,CURFLD ;IF FIRST UNPROTECTED FIELD
CAMN E,ML1UNP ; IN SECTION
SETOM MLTFLG ; THEN SET THE FLAG
AOS (P) ;A GOOD RETURN
RET
CHKIDX: ;CHECK FOR EMPTY ELEMENT
CALL GETIDX ;GET INDEX FIELD
AOS (P) ;ASSUME GOOD RETURN
MOVEI A,2
MOVEI D,2 ;SET UP FOR COMPARE
MOVE E,[POINT 7,[ASCIZ '00']]
EXTEND A,[CMPSN
0
0]
SOS (P) ;ITS EMPTY!
RET
GETIDX: ;GET INDEX FIELD BYTE PTR INTO "B"
MOVE B,MLTELM
ADD B,MLTCNT ;+VE ELEM. NUMBER
MOVE A,B ;CALLER MAY WANT IT
IMUL B,MLTSIZ ;*SIZE
ADJBP B,MLTIVP
RET
FNDLST: ;FIND THE FIRST FREE ELEMENT
MOVN A,MLTCNT ;COUNT OF ELEMENTS TO SEARCH
MOVEM A,MLTELM
FLS.1:
CALL CHKIDX ;SEE IF ELEMENT IF EMPTY
JRST FLS.2 ; IT IS - END OF SEARCH
AOSGE MLTELM ;COUNT IT
JRST FLS.1 ;AND KEEP LOOKING
MOVE A,MLTELM ;THIS IS HOW FAR WE GOT
RET ;BUT IT MAY BE AN ERROR
FLS.2:
MOVE A,MLTELM ;THIS IS HOW FAR WE GOT
AOS (P) ;GOOD RETURN
RET
GETMFD: ;GET OFFSET &LINE
MOVE E,MLTELM ;NOW SET OFFFLD TO BE -
ADD E,MLTCNT ;OFFFLD + MLTSIZ * (MLTELM + MLTCNT)
IMUL E,MLTSIZ ;CHARACTERS!
ADJBP E,OFFFLD ;OFFSET IT
MOVEM E,OFFFLD ;RESTORE IT
MOVE E,MLTDSP ;AND SET UP THE DISPLAY LINE
MOVEM E,LINFLD
MOVE E,MLTELM ;NOW FOR THE VALUE AREA
ADD E,MLTCNT
PUSH P,A
MOVE A,LENFLD
ADDI A,5
IDIVI A,5 ;MAKE NUMBER OF WORDS
IMUL E,A
ADDM E,VALFLD ;POINT TO REAL VALUE
POP P,A
;
;CALCULATE THE NEW BYTE POINTER FOR THE ENTRY INTO THE
;NUMBER-OF-CHARACTERS-READ TABLE (MULTAB).
;
MOVE E,MLTELM
ADD E,MLTCNT ;COLUMN NUMBER
IMULI E,^D16
ADD E,MLTTMP
ADD E,MLTNMF ;PLUS RELATIVE FIELD NUMBER
ADJBP E,MULTAB ;GENERATE THE POINTER
MOVEM E,MULTPT ;AND SAVE IT
RET
SUBTTL GCURDT - GET CURRENT DATE
;THIS ROUTINE GETS THE DATE STRING INTO THE CORRECT FORMAT FOR THE FIELD.
;THIS TABLE CONTAINS THE NUMBER OF DAYS PRIOR TO THE MONTH
MLSTAB: 0
^D31
^D59
^D90
^D120
^D151
^D181
^D212
^D243
^D273
^D304
^D334
GCURDT:
SETO B, ;WANT CURRENT DATE
MOVE A,DATTYP ;GET SUBTYPE
CAIN A,%DATJU ;SKIP IF NORMAL
JRST GCD.1
PUSH P,A ;SAVE SUBTYPE
MOVE C,ODTAB(A) ;GET FLAGS WORD
MOVE A,[POINT 7,CURDAT]
SKIPE LONGDT ;IF LONG FORMAT
TXO C,OT%4YR ; THEN MAKE SURE OF IT
ODTIM
ERJMP [ADJSP P,-1
RET]
MOVE B,[POINT 7,CURDAT]
MOVE C,VALFLD ;SET UP FOR COPY
MOVEI D,6 ;NUMBER OF CHARS
SKIPE LONGDT ;IF LONG FORMAT
MOVEI D,^D8 ; THEN IT IS LONGER
MOVE A,(P) ;IF THE DATE IS COBOL FORMAT
CAIN A,%DATCB
JRST [MOVE B,[POINT 7,CURDAT+1,6] ; THEN POINT TO THE YEAR FIRST
SKIPE LONGDT ; AND COPY 4 DIGITS IF
CALL CMOV2 ; LONG FORMAT
JRST .+1]
CALL CMOV2
IBP B
MOVE A,(P)
CAIN A,%DATCB ;IF THIS IS COBOL DATE
MOVE B,[POINT 7,CURDAT] ; THEN GO FOR MONTH NOW
CALL CMOV2
MOVE A,(P)
CAIE A,%DATDE ;IF DATE DEC
CAIN A,%DATMI ; OR MILITARY
JRST [CALL CMOV1 ; THEN DO ONE MORE BYTE
AOJ D, ; AND INCREASE THE COUNTER
JRST .+1]
IBP B
ILDB A,B
IDPB A,C
ILDB A,B
IDPB A,C
POP P,A ;GET SUBTYPE
CAIE A,%DATCB ;IF NOT COBOL
SKIPN LONGDT ; AND LONG FORMAT
SKIPA
CALL CMOV2 ; THEN COPY ANOTHER 2 CHARACTERS
MOVE A,D ;COPY NUMBER OF CHARS
RET
GCD.1: ;JULIAN DATE IS SPECIAL
SETZ D,
ODCNV
PUSH P,C ;DAY,,0
PUSH P,B ;YEAR,,MONTH
HLRZS B ;YEAR
SKIPN LONGDT ;IF SHORT FORM DATE
SUBI B,^D1900 ;ASSUME 20TH CENTURY!
PUSH P,B
MOVE A,VALFLD
MOVE C,[NO%LFL+NO%ZRO+2B17+^D10]
SKIPE LONGDT ;IF LONG FORMAT DATE - SET IT UP
MOVE C,[NO%LFL+NO%ZRO+4B17+^D10]
NOUT ;YEAR NUMBER
ERJMP [ADJSP P,-3
RET]
POP P,C
POP P,B
HRRZS B ;MONTH
MOVE B,MLSTAB(B) ;DAYS TO START OF IT
TRNE C,3 ;LEAP YEAR?
JRST GCD.3 ;NO
SKIPN LONGDT ;IF SHORT FORMAT
JRST GCD.2 ; THEN SEE TO IT
IDIVI C,^D100 ;ELSE SEE IF CENTURY YEAR
SKIPN D
TRNN C,3 ;AND IS DIVISIBLE BY 4
SKIPA
JRST GCD.3
GCD.2:
CAIL B,^D59 ;DO ANYTHING?
AOJ B, ;YES - ADD ONE
GCD.3:
POP P,C
HLRZS C ;DAYS
ADD B,C ;TOTAL DAYS
AOJ B, ;JULIAN CONVENTION
MOVE C,[NO%LFL+NO%ZRO+3B17+^D10]
NOUT ;DAYS
RET
MOVE A,LENFLD ;NUMBER OF CHARS
RET
ODTAB: ;PARAMS TABLE FOR ODTIM
OT%NTM+OT%NMN+OT%SLA ;CANADA
OT%NTM+OT%NMN+OT%DAM ;COBOL
OT%NTM+OT%NMN+OT%DAM ;DASH
OT%NTM ;DEC
0 ;JULIAN
OT%NTM ;MILITARY
OT%NTM+OT%NMN+OT%DAM+OT%SLA ;SLASH
SUBTTL CHKHSC - CHECK HIDDEN SECTIONS
;
; THIS ROUTINE CHECKS THE CURRENT CALL FOR A HIDDEN SECTION. IF IT IS,
; AND IT IS NOT ON THE SCREEN ALREADY, THEN ALL FIELDS OF THE OLD HIDDEN
; SECTION (IF THERE IS ONE) ARE FLAGGED AS NOT DISPLAYED AND THE NEW
; SECTION IS DISPLAYED.
; RETURNS ARE: +1 ERROR IN FIND ROUTINE
; +2 MULTIPLE SECTION OK
; +3 MULTIPLE SECTION ERROR
; +4 NORMAL
; VALUES IN INT.A ARE: + FIELD
; 0 FORM
; - SECTION
;
CHKHSC:
JUMPE INT.A,SKPRT3 ;OK IF THE WHOLE FORM
JUMPG INT.A,CKH.3 ;SINGLE FIELD
TLNN INT.A,7000
JRST CKH.3 ;ALSO A SINGLE FIELD (NAME)
MOVN A,INT.A ;GET SECTION NUMBER
CAMN A,MLTSEC ;IS IT A MULTIPLE SECTION?
JRST SKPRET ;YES
SOJ A,
IDIVI A,^D36 ;FIND OFFSET AND BIT NUMBER
ADD A,HDNSEC ;AND POINT TO THE MASKS
MOVEI C,1 ;A BIT
LSH C,(B) ;LINE IT UP
TDNN C,(A) ;IS IT A HIDDEN SECTION?
JRST SKPRT3 ;NO
CAMN INT.A,CURHSC ;IS THIS ON THE SCREEN?
JRST SKPRT3 ;YES - OK
PUSH P,INT.A ;SAVE SECTION NUMBER
MOVE INT.A,CURHSC ;OLD SECTION NUMBER
JUMPE INT.A,CKH.2 ;NOT THERE
SETZM SECFLG
CKH.1:
CALL FIND ;GET A FIELD
JRST [POP P,INT.A ;ERROR - TIDY UP
RET]
JRST CKH.2 ;DONE
CALL GETFLD ;GET FIELD ATTRIBUTES
TXZ PRM,%DSPLY ;CLEAR DISPLAY BIT
CALL STRPRM ;RESAVE PARAMS
CALL ABLANK ;REMOVE IT FROM SCREEN
JRST CKH.1
CKH.2:
POP P,INT.A
MOVEM INT.A,CURHSC ;SET THIS ONE AS CURRENT
SETZM SECFLG
CALL INITAL ;INIT THE SECTION
JRST SKPRT3
CKH.3: ;SINGLE FIELD - MUST NOT BE MULTIPLE
SETZM SECFLG
CALL FIND ;LOOK FOR IT
RET
RET ; ERROR
TXNN PRM,%MULT ;IF NOT MULTIPLE
AOS (P) ; THEN OK
SETZM CURFLD ;MAKE SURE FIND WORKS
JRST SKPRT2
SUBTTL FLDRD - READ A FIELD AND SET .NUMRD & PRDUP IF MSDUP
; FLDRD - read a field by splitting it into its subfields
; and calling INTRD to read each subfield in turn. On
; return:
; AC1 = number of characters read
; AC2 = terminating character
FLDRD:
SKIPE BYPASS ;IF IN BYPASS MODE
JRST FLR.2A ; THEN BYPASS THE SETUP
SETZM DAY ;PRESET DATE COLLECTORS
SETZM MONTH
SETZM YEAR ;IN CASE OF A TAB PART WAY THROUGH
SETOM SEPFND ;ALWAYS ENTER WITH PENDING SEPARATOR
CALL FLR.6 ;PRESET THE SUBFIELD SYSTEM
FLR.1:
ADDM C,SUBTOT ;ALSO COUNT IT FOR BACKUPS
ADDM C,FLDPOS ;UPDATE THE IN-FIELD POSITION
CALL SUBFLD ;GET THE NEXT SUBFIELD
JRST FLR.5 ;NO MORE - DONE
JUMPL B,FLR.1 ;SKIP SEPARATORS
MOVEM C,SUBLEN ;SAVE THE LENGTH OF THIS SUBFIELD
FLR.2: ;READ THE NEXT SUBFIELD
MOVEM A,SFTYPE ;SAVE THE SUBFIELD FLAGS
TXNE A,%T.DIG ;IF NOT NUMERIC
TXNN PRM,%SIGND ; OR SIGNS ARE NOT ALLOWED
SETOM SGNLGL ; THEN DON'T ALLOW SIGNS
FLR.2A:
CALL INTRD ;READ THIS SUBFIELD
JRST FLR.3 ; HANDLE BACKUP TO PREVIOUS SUBFIELD
SETZM BACKSF ;NOT BACKING UP NOW
SETOM SGNLGL ;SIGN IS NOT LEGAL IN NEXT SUBFIELD
AOS SUBCNT ;COUNT THE SUBFIELD
SKIPGE TOTNRD ;IF NEGATIVE BECAUSE OF DELETES
SETZM TOTNRD ; THEN CLEAR IT FIRST
ADDM A,TOTNRD ;UPDATE THE NUMBER READ
ADDM A,SUMRED ;KEEP TRACK FOR MS REQUIRED TEST
MOVE E,TRMCHR
SKIPN B ;IF ESCAPE ENDED THE READ
CAIE E,TRM.LN ; OR IT WAS NOT A FULL FIELD
JRST FLR.5 ; THEN FINISH OFF
MOVE C,A ;ELSE RESET THE POINTER READY
MOVE A,TOTNRD ;SET POINTER TO RIGHT PLACE
ADJBP A,VALFLD ; FOR THE NEXT SUBFIELD
MOVEM A,SUBPTR
JRST FLR.1
FLR.3: ;BACKUP TO PREVIOUS SUBFIELD
SETOM BACKSF ;SET THE FLAG
SETZM SEPFND ;ALSO LOSE SEPARATOR IF WE HAD ONE
SOS A,SUBCNT ;GET NUMBER OF PREVIOUS SUBFIELD
PUSH P,A ;AND SAVE IT FOR COMPARE
CALL FLR.6 ;PRESET THE SYSTEM
SETOM SUBCNT ;AND FORCE THE PREVIOUS ONE NEXT TIME
FLR.4: ;LOOP TO FIND THE PREVIOUS SUBFIELD POSITION
ADDM C,FLDPOS ;UPDATE THE IN-FIELD POSITION
ADDM C,SUMRED ;KEEP TRACK FOR MS REQUIRED TEST
CALL SUBFLD ;GET THE NEXT SUBFIELD
JRST [ADJSP P,-1 ; NONE! - CLEAN THE STACK
RET]
JUMPL B,FLR.4 ;SKIP SEPARATORS
ADDM C,TOTNRD ;AND KEEP TRACK OF NUMBER OF CHARS
AOS B,SUBCNT ;SEE IF WE ARE BACK TO THE RIGHT PLACE
CAME B,0(P)
JRST FLR.4 ;NO - KEEP GOING
MOVEM C,SUBLEN ;SAVE THE SUBFIELD LENGTH
SETZM SGNLGL ;ASSUME SIGN IS LEGAL
CAIE B,1 ;UNLESS THIS IS NOT THE FIRST SUBFIELD
SETOM SGNLGL ; IN WHICH CASE SIGN IS ILLEGAL
MOVE B,TOTNRD ;RESET THE POINTER
SUB B,C
MOVEM B,SUBTOT ;NOW BACKED UP TO PREVIOUS S.F
ADJBP B,VALFLD
MOVEM B,SUBPTR
ADJSP P,-1 ;CLEAN THE STACK
JRST FLR.2 ;GO AND READ IT
FLR.5: ;FINISH UP THE PROCESSING
SETZM FLDPOS ;ZERO IN CASE OF ERROR
SKIPN A,TOTNRD ;IF NOTHING TYPED
RET ; THEN DONE
SKIPL PREDUP ;IF NEW DATA IN PREVIOUS DUPE
SETOM NEWDAT ; THEN SAY SO
RET
FLR.6: ;PRESET READY TO READ SUBFIELDS
SETZM SUBTOT ;PRESET COUNTER FOR BACKUP
SETZM SGNLGL ;ASSUME SIGN IS LEGAL
SETZM SUBCNT ;POINT TO FIRST SUBFIELD
SETZM SUBLEN ;NO LENGTH YET
SETZM FLDPOS ;ALSO CLEAR IN-FIELD POSITION
SETZB C,TOTNRD ;NONE READ SO FAR
PJRST SFINIT ;INIT THE POINTERS
SUBTTL INTRD - INTERNAL READ ROUTINE FOR ONE FIELD
; INTRD - Read the next subfield from the screen. To do this
; the sequence of operations is as follows:
;
; 1 - position the cursor to the start of the subfield
; 2 - set up a pointer to the value in core.
; 3 - tell TOPS-20 the field type.
; 4 - call TEXTI. to read until full or illegal character.
; 5 - handle termination character and return.
INTRD: ;INTERNAL READ OF A FIELD
SKIPE BYPASS ;IF IN BYPASS MODE
JRST INR.E4 ; THEN ASSUME A DELETE WAS SEEN
DMOVE A,LINFLD ;WITH FIELD'S LINE AND COLUMN,
ADD B,FLDPOS ;ADD THE IN-FIELD POSITION
SKIPE BACKSF ;AND, IF BACKING UP
ADDI B,(C) ; THEN OFFSET TO LAST CHAR+1
CALL $POSIT ; POSITION CURSOR
MOVE A,SUBPTR ;SET UP POINTER TO CORE VALUE AREA.
MOVEM A,TXTTAB+.RDDBP ;DESTINATION BYTE POINTER
MOVEM A,TXTTAB+.RDBFP ;BACKUP LIMIT FOR CTRL-U ETC.
SKIPE BACKSF ;IF BACKING UP TO PREVIOUS SUBFIELD
JRST [MOVE C,SUBLEN ; THEN GET THE LENGTH OF THE SUBFIELD
ADJBP C,A ; AND POINT TO THE RIGHT PLACE
MOVEM C,TXTTAB+.RDDBP
JRST .+1]
TXNE PRM,%YN ;IF A YES/NO FIELD
JRST [MOVE A,MSKYNF ; THEN USE A SPECIAL MASK
JRST INR.1]
MOVE A,SFTYPE ;COPY THE CLASS BITS
ANDX A,%SFLGL ;AND KEEP ANY SUBFIELD CHARACTER BITS
TXNE A,%PUNCT ;IF PUNTUATION SET
SETZ A, ;THEN ASSUME ANYTHING GOES
ASH A,-3 ;MAKE IT AN OFFSET
MOVE A,MSKTAB(A) ;GET ADDRESS AND FLAGS
INR.1:
HLRZ C,A ;GET ADDRESS OF ARGUMENT BLOCK
CAME A,FLDTYP ;IF NOT SAME AS OLD TYPE
CALL SETTYP ;THEN SET IT UP
MOVEM A,FLDTYP ;SAVE THIS AS THE 'NEW' OLD TYPE
MOVE INT.C,SUBLEN ;SAVE MAX LENGTH AVAIL FOR INPUT
MOVEM INT.C,TXTTAB+.RDDBC ;DESTINATION BYTE COUNT
SKIPE BACKSF ;IF BACKING UP
JRST [SETZM TXTTAB+.RDDBC ; THEN CLEAR THE BYTE COUNT
JRST INR.E4] ; AND DO IT
INR.2:
SETZM TRMCHR ;NO TERM CHAR YET
SETZM ISTAB ;NO TAB SEEN YET FOR PREVIOUS DUPE
CALL TEXTI. ;READ THE FIELD,RETURN LAST CHAR IN 'E'.
JUMPE E,INR.LN ;IF ZERO - FIELD WAS FILLED
CAIL E,SPACE ;SKIP THIS IF A CONTROL CHAR
JRST INR.4
IFN FT%V05,<CALL $DOCC ;CONVERT CONTROL CHARS IF REQUIRED
>
CAIL E,BACKSP ;IF IN RANGE
CAILE E,CR ; THEN DISPATCH TO THE RIGHT PLACE
JRST INR.4 ; NOT - SO KEEP CHECKING
INR.2A:
PUSH P,E ;SAVE THE CHARACTER
TXNE PRM,%FULL ;IF THIS IS A FULL FIELD
SKIPN TXTTAB+.RDDBC ; AND IT WASN'T FILLED
SKIPA
JRST [CAIN E,BACKSP
JRST INR.3 ; THEN DON'T JUSTIFY IT
MOVE E,SUBCNT
CAMN INT.C,TXTTAB+.RDDBC ;IF IT IS THE FIRST CHARACTER
JUMPE E,INR.3 ;AND IT IS FIRST SUBFIELD, THEN OK
POP P,E ;CLEAN THE STACK
JRST INR.16] ;REPORT THE ERROR
CAIN E,BACKSP ;IF A BACKSPACE
JRST INR.3 ; THEN DON'T JUSTIFY
SKIPN SUBCNT ;IF IN FIRST SUBFIELD
CAME INT.C,TXTTAB+.RDDBC ; AND ITS EMPTY - DON'T JUSTIFY
CALL SFJUST ; TRY TO JUSTIFY THE SUBFIELD
JFCL ; ALL WAYS ARE THE SAME HERE
INR.3:
POP P,E
JRST @[INR.E4 ;BACKSPACE
INR.TB ;TAB
INR.LF ;LINE FEED
INR.VT ;VERTICAL TAB
INR.FF ;FORM FEED
INR.CR]-BACKSP(E) ;CARRIAGE RETURN
INR.4:
CAIN E,ESC ;ESCAPE
JRST INR.ES
CAIN E,"?" ;QUERY = HELP
JRST [CALL DOABS ;BACKUP THE CURSOR AND DELETE THE QUERY
CALL $HELP ;SEND THE HELP MESSAGE
JRST INR.18]
CAIN E,"W"-100 ;CONTROL-W
JRST [MOVEI B,5 ; REREAD THIS FIELD
MOVEM B,PREDUP ;SET A FLAG
JRST INR.18]
CAIN E,"P"-100 ;CONTROL-P
JRST [SETZM PAGFLG
CALL $OPLST ;COPY THE SCREEN TO TFRLPT:
JRST .+1 ; FAILED = ERROR
JRST INR.2]
REMARK TEST FOR LEADING OPERATION SIGN IF NUMERIC
SKIPE SGNLGL ;IF SIGN IS ILLEGAL THEN CONTINUE
JRST INR.5
MOVE A,SUBLEN
CAME A,TXTTAB+.RDDBC ;IF NOT FIRST CHARACTER IN FIELD
JRST INR.5 ; THEN CONTINUE
SKIPE SUBCNT ;IF NOT THE FIRST SUB FIELD
JRST INR.5 ;THEN ALSO CAN'T BE SIGN
CAIE E,"-" ;LEADING SIGN
CAIN E,"+"
SKIPA ;YES-OK.
JRST INR.5 ;NO - ILLEGAL CHARACTER
CAIN E,"+" ;IS IT A PLUS ?
MOVEI E,ZERO ; YES - REPLACE IT WITH ZERO
IDPB E,TXTTAB+.RDDBP ;REPLACE IT.
SOS TXTTAB+.RDDBC ;AND COUNT THE CHARACTER
JRST INR.2 ;CONTINUE
INR.5:
TXNN PRM,%SFDEF ;IF THIS IS NOT SUBFIELD
JRST INR.11 ; THEN IT MUST BE BAD
MOVE A,SUBLEN
CAME A,TXTTAB+.RDDBC ;IF THIS IS THE FIRST CHARACTER
JRST INR.6 ; WHICH IT ISN'T
SKIPE SEPFND ;AND IF NO SEPARATOR PENDING
JRST INR.6 ; WHICH THERE IS
MOVE B,LSTSEP ;GET THE LAST SEPARATOR
CAIE B,(E) ;IF IT WASN'T THE SAME
JRST INR.11 ; THEN FAIL
CALL DOABS ;ELSE REMOVE IT FROM THE SCREEN
SETOM SEPFND ;HAD SEPARATOR NOW
JRST INR.2 ;AND REREAD THE SUBFIELD
INR.6: ;CHECK FOR SEPARATOR ENDING A SUBFIELD
MOVE A,SFPNTR ;POINT TO THE DESCRIPTOR
INR.7:
ILDB B,A ;GET THE NEXT BYTE
JUMPE B,INR.11 ;IF NONE THEN ILLEGAL CHARACTER
TXZN B,%SFSEP ;IS THIS A SEPARATOR
JRST INR.11 ; NO - ILLEGAL
CAIE B,(E) ;YES - SEE IF IT MATCHES
JRST INR.7 ; NO - TRY FOR ANOTHER
SETZ E, ;CLEAR THIS AS A FLAG FOR SFJUST
SETOM SEPFND ;HAD SEPARATOR NOW
TXNE PRM,%FULL ;IF THIS IS A FULL FIELD
JRST [SKIPN TXTTAB+.RDDBC ; AND IT WASN'T FILLED
JRST .+1
CALL DOABS ; DON'T JUSTIFY
JRST INR.16]
CALL SFJUST ;TRY TO JUSTIFY THE FIELD
CALL DOABS ;REMOVE CHARACTER FROM NON-NUMERICS
JRST INR.LN ;DONE SUBFIELD
;;;;;;;;;;;;;;;;;;; ERRONEOUS CHARACTER ;;;;;;;;;;;;;;;;
INR.11:
TXNE PRM,%YN ;IF YES/NO
JRST [HRROI C,MSG.YN ; THEN TELL THE USER
JRST INR.12]
MOVE A,SFTYPE ;USE SUBFIELD TYPE
LDB C,[POINT 2,A,32] ;GET TYPE INDICATOR
HRRO C,[MSG.NN ; NUMERIC
MSG.AO ; ALPHABETIC
MSG.NA]-1(C) ; ALPHANUMERIC
INR.12:
PUSH P,E ;SAVE THE CHARACTER.
CALL INTERR ;INTERNAL ERROR CALL
POP P,E ;RESTORE THE CHARACTER.
CAIGE E,40 ;IF AN ILLEGAL CONTROL CHARACTER
JRST [CALL $BACKCU ;BACKUP THE CURSOR
JRST INR.2] ; AND CONTINUE.
CALL DOABS ;BACKSPACE CURSOR ON SCREEN IF ANY
JRST INR.2 ;DO TEXTI WITHOUT REINITTING
INR.LN: MOVEI A,TRM.LN ;READ TERMINATED ON LENGTH.
JRST INR.13
INR.TB: MOVEI A,TRM.TB ;TAB TERMINATOR
JRST INR.13 ;COMMON ENDING
INR.LF: MOVEI A,TRM.LF ;LINE FEED ENDED READ
JRST INR.14
INR.VT: ;YOUR GUESS IS AS GOOD AS MINE WHY
; HE CAME HERE - I DIDN'T TELL HIM
; ABOUT 'VT'. MAYBE HE SNEEZED!
INR.FF: MOVEI A,TRM.FF ;FORM FEED ENDED READ
JRST INR.14
INR.CR: MOVEI A,TRM.CR ;CARRIAGE RETURN ENDED READ
SKIPE OLDCR ;IF USER WANT'S CR.EQ.LF
MOVEI A,TRM.LF ;THEN DO IT.
;FALL INTO INR.14
INR.14:
MOVEI Z,1
MOVEM Z,DEFALT ;JUSTIFY LAST FIELD IF REQUIRED
;;;;;;;; FIELD OR SUBFIELD ALL IN -- SO CHECK LEGALITY ;;;;;;;;
INR.13:
MOVEM A,TRMCHR ;SAVE THE TERMINATION CODE.
CALL SUBCHK ;CHECK SUBFIELD RANGE IF REQUIRED
JRST [HRROI C,MSG.IV ; ILLEGAL VALUE ENTERED
CALL INTERR
DMOVE A,LINFLD ;MAKE SURE CURSOR IS IN THE RIGHT PLACE
ADD B,FLDPOS
CALL $POSIT
SETZM BACKSF ;NOT BACKSPACING NOW
SETOM PREDUP ;SUBFIELD SHOULD BE CLEARED ON NEW DATA
SETOM SFCERR ;FLAG THE ERROR
JRST INTRD]
TXNN PRM,%FULL ;IF THIS IS NOT A FULL FIELD
JRST INR.17 ; THEN DO NOT CHECK FOR IT.
SKIPN A,TXTTAB+.RDDBC ;IF FIELD WAS FULL
JRST INR.17 ; THEN OK SO FAR
SUB A,INT.C ;ELSE - IF FIELD WAS EMPTY
SKIPL PREDUP ;IF NOT PREVIOUS DUPE
TXNN PRM,%REQD ; OR IF REQUIRED FIELD
SKIPE A ; OR NOT REQUIRED AND PART FILLED
SKIPA ; THEN FAILED
JRST INR.17 ; ELSE ALL IS OK
INR.16:
HRROI C,MSG.FF ;ELSE DO THE ERROR MESSAGE.
CALL INTERR
CALL DOABS ;PUT CURSOR TO RIGHT PLACE
JRST INR.2
;END OF VALIDITY CHECKING ON SUBFIELD LEVEL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
INR.17:
SETZ B, ;RETURN LENGTH AND TERMINATOR.
INR.18:
SETOM NEWDAT ;INDICATE NEW DATA WAS ENTERED.
MOVE A,INT.C ;COMMON EXIT --COMPUTE # CHARS READ.
SUB A,TXTTAB+.RDDBC ;BYTES READ
SKIPE A ;IF USER ENTERED DATA THEN
JRST SKPRET ; RETURN WITH COUNT IN 'A'.
SETZM NEWDAT ;INDICATE NO NEW DATA WAS ENTERED.
TXNE PRM,%DFDT ;DEFAULT DATE
JRST INR.19 ;USE PREVIOUS LENGTH
CAIE B,3 ;IF THIS WAS PF3 (BLACK)
SKIPN MAXFLD ; OR WE ARE NOT BACKING UP
SKIPA ; THEN CONTINUE
JRST INR.19 ;ELSE GET THE OLD COUNT.
SKIPN PREDUP ;RET IF NORMAL FIELD
JRST SKPRET
MOVE E,TRMCHR ;IF TAB OUT OF PREVIOUS DUPE
INR.19:
CALL LD.NUMRD ;USE PREVIOUS LENGTH
JRST SKPRET
INR.ES: ;ESCAPE ENDED READ
CALL ECOOFF ;TURN OFF ECHO
CALL $GTESC ;GET THE ESCAPE SEQUENCE
TXNN PRM,%NEKO ;DONT DO IT IF NO-ECHO
CALL ECOON ;BACK ON
TRZ A,40 ;MAKE SURE ITS UPPER CASE - HE MAY HAVE
;BEEN IN A LOWER CASE FIELD AND DONE
;THE ESCAPE SEQUENCE MANUALLY.
MOVE A,ECHAR ;PICK UP ESCAPE FROM SAVE AREA
SETZM ECHAR ; AND RESET THE FLAG
CAIE A,"A" ;IF UP ARROW OR
CAIN A,"B" ; DOWN-ARROW THEN
JRST [SKIPE OLDUD ;IF UP-DOWN ARROW ILLEGAL THEN
JRST INR.E1 ; THEN DO NOT CHECK ON ARROWS.
SUBI A,"A" ;OFFSET
ADDI A,TRM.UA ;SET UP RETURN CODE
JRST INR.14]
CAIE A,"C" ;IF RIGHT-ARROW OR
CAIN A,"D" ; LEFT ARROW THEN
JRST [SKIPN OLDAR ;IF SPECIAL TREATMENT
JRST INR.E3 ; THEN DO IT
MOVEI E,CR ;ELSE TREAT AS CR
JRST INR.2A]
INR.E1: ;NOT AN ESC-ARROW OR NOT PROCESSING THESE.
SETZB B,IDXSET ;RE-ENABLE INDEX SETTING
CAIL A,"P" ;IF THIS IS A VALID ACTION KEY (PF1-PF4)
CAILE A,"S"
SKIPA
MOVEI B,1-"P"(A) ;THEN SET THE INDEX = (A) + 1 - "P"
CAIN B,4 ;IF IT WAS PF4
CALL $HELP ; THEN GIVE SOME HELP
JUMPN B,INR.18
CAIE A,"L" ;<ESC>L PUTS OUTPUT TO TFRLPT:
JRST INR.E2 ;NO - ASSUME ITS BAD
SETZM PAGFLG ;DON'T SEND FORM-FEED
CALL $OPLST ;OUTPUT THE SCREEN
JRST INR.E2 ;FAILED - TREAT AS ILLEGAL CODE
JRST INR.2
INR.E2:
HRROI C,MSG.ES ;BAD ESCAPE SEQUENCE
CALL INTERR
CALL DOABS
JRST INR.2 ;INPUT SOME MORE
INR.E3: ;SPECIAL HANDLING FOR RIGHT AND LEFT ARROW.
CAIN A,"D" ;IF LEFT-ARROW
JRST INR.E4 ; THEN GO PROCESS IT
MOVEI E,TAB ;ELSE TREAT IT AS A TAB
JRST INR.2A
INR.E4: ;LEFT ARROW AND BACKUP CODE
SETZM BYPASS ;BACK TO NORMAL MODE NOW
CALL BACKUP ;DO A LOGICAL BACKUP
JRST [CALL DOABS ;THERE WAS A CHARACTER
SKIPN SUBCNT ;IF THIS IS LEAVES US AT THE FIRST
CAIE E,BACKSP ;CHARACTER IN THE FIRST SUBFIELD
JRST INR.2 ;AFTER A BACKSPACE (DELETE) THEN ...
MOVE Z,TXTTAB+.RDDBC
CAMN Z,SUBLEN
JRST INR.2 ;FINISH TEXTI
MOVEM E,PREDUP ;... SET A FLAG TO SAY SO
TXNE PRM,%SIGND ;AND IF THE FIELD CAN HAVE A SIGN
SETZM SGNLGL ; THEN RE-ALLOW IT NOW
JRST INR.2] ;FINISH TEXTI
SKIPE SUBCNT ;IF NOT IN THE FIRST SUBFIELD
RET ; THEN WE CAN BACKUP
HRROI C,MSG.BU ;BACK UP NO FURTHER
SOS INT.C ;MAKE SURE CURSOR GOES TO RIGHT PLACE
CALL INTERR ;TELL USER
AOS INT.C
JRST INR.2 ;TRY AGAIN
;THIS TABLE CONTAINS THE RANGES FOR SUBFIELD CHECKING
; XWD LOW-LIMIT, HIGH-LIMIT
RNGTAB:
XWD 0,^D59 ;MINUTES OR SECONDS
XWD 0,^D24 ;HOURS
XWD 1,^D31 ;DAYS
XWD 1,^D12 ;MONTHS
XWD 0,^D9999 ;YEARS
XWD 1,^D366 ;JULIAN DAYS
XWD 0,0 ;SPARE
DEFINE TBL(MONTH,NUMBER),<
[ASCIZ /MONTH/],,NUMBER>
MTHTAB: ^D12,,^D12 ;TABLE OF MONTH NAMES AND NUMBERS
TBL <APRIL>,^D4
TBL <AUGUST>,^D8
TBL <DECEMBER>,^D12
TBL <FEBRUARY>,^D2
TBL <JANUARY>,^D1
TBL <JULY>,^D7
TBL <JUNE>,^D6
TBL <MARCH>,^D3
TBL <MAY>,^D5
TBL <NOVEMBER>,^D11
TBL <OCTOBER>,^D10
TBL <SEPTEMBER>,^D9
;THE FOLLOWING SUBROUTINE CHECKS A SUBFIELD TO SEE IF IT IS
;WITHIN A SPECIFIED RANGE. CURRENTLY ONLY DATES AND TIMES ARE
;SUBJECT TO THIS CHECKING.
SUBCHK:
MOVE E,SFTYPE ;GET THE SUBFIELD FLAGS
TXNE E,%SFTYP ;IF NO TYPE CODE SET OR
TXNN PRM,%SFDEF ; IF THERE ARE NO SUBFIELDS
JRST SKPRET ; THEN ASSUME IT'S OK
MOVE D,SUBLEN ;NUMBER OF DIGITS TO CONVERT
CAMN D,TXTTAB+.RDDBC ;IF THE FIELD IS EMPTY
SKIPE SUBCNT ; AND THIS IS THE FIRST SUBFIELD
SKIPA
JRST SKPRET ; THEN IT PASSED THE CHECKS OK
MOVE A,SUBPTR ;POINT TO THE SUBFIELD
TXNE E,%ALPHA!%PUNCT ;IF NOT NUMERIC
JRST SBC.2 ; THEN DO ALPHA CHECKS
SETZ C, ;CLEAR TOTAL
SBC.1:
ILDB B,A ;GET A DIGIT
IMULI C,^D10 ;STEP THE TOTAL UP
ADDI C,-ZERO(B) ;ADD IN THE NEW DIGIT
SOJG D,SBC.1 ;LOOP TILL DONE
ANDI E,%SFTYP ;KEEP ONLY THE TYPE CODE
HLRZ A,RNGTAB-1(E) ;GET LOWER LIMIT
CAIGE C,(A) ;IF TOO LOW
RET ;THEN FAILED
HRRZ A,RNGTAB-1(E) ;ELSE TRY THE UPPER LIMIT
CAIN E,%T.MIN ;IF MINUTES OR SECONDS
SKIPN HOUR24 ; AND THE HOUR WAS 24
SKIPA
SETZ A, ; THEN ONLY ZERO IS ALLOWED (24:00:00)
CAILE C,(A)
RET ;TOO HIGH
MOVEM C,@[C ;SAVE THE NUMBER FOR LATER - MIN/SEC
C ; - HOURS
DAY ; - DAYS
MONTH ; - MONTHS
YEAR ; - YEARS
DAY ; - DAYS (JULIAN)
C]-1(E)
CAIE E,%T.HOR ;IF HOURS
JRST SKPRET
SETZM HOUR24 ;THEN ASSUME NOT 24:00:00
CAIN C,^D24 ;UNLESS IT REALY IS
SETOM HOUR24 ; FLAG IT FOR LATER
JRST SKPRET
SBC.2: ;ALPHA CHECKS
CAIE E,%T.AM ;IF NOT MONTH
JRST SKPRET ; THEN ASSUME OK
MOVE C,[POINT 7,INTBUF] ;POINT TO TEMP AREA
SBC.3:
ILDB B,A ;COPY THE SUBFIELD
IDPB B,C
SOJG D,SBC.3
SETZ B, ;AND END ON A NULL
IDPB B,C
MOVEI A,MTHTAB ;SET UP FOR A TABLE LOOKUP
MOVE B,[POINT 7,INTBUF]
TBLUK
TXNE B,TL%NOM!TL%AMB ;IF NOT FOUND OR AMBIGUOUS
RET ; THEN FAILED
HRRZ B,(A) ;ELSE GET THE MONTH NUMBER
MOVEM B,MONTH ;AND SAVE IT FOR LATER
JRST SKPRET
SFJUST: ;JUSTIFY SUBFIELD
MOVE Z,PRM ;SEE IF THIS IS A NUMERIC FIELD
TXNN PRM,%DATE ;DATE SUBFIELDS ARE ALWAYS JUSTIFIED
SKIPE NEWNSJ ;UNLESS WE CAN ALWAYS JUSTIFY IT
MOVE Z,SFTYPE ; SEE IF THIS IS A NUMERIC SUB-FIELD
TXNN Z,%NUMER
JRST SFJ.3 ; NO
TXNE Z,%ALPHA!%PUNCT
JRST SFJ.3 ; STILL NOT
MOVE A,INT.C ;GET NUMBER OF CHARS
SUB A,TXTTAB+.RDDBC
JUMPE A,SFJ.4 ;BLANK SUBFIELD IF ZERO
SKIPE E ;IF SEPARATOR FOUND, OR
SKIPN NEWMNY ;IF USING NEW MONEY SPEC
JRST SFJ.0 ; THEN CONTINUE
MOVE E,LENFLD ;ELSE WORK TO V2A SPEC (APPROX)
SUB E,SUBLEN
SKIPE SUBCNT ;IF IN SECOND SUBFIELD
ADD A,E ; THEN ACCOUNT FOR THE FIRST ONE
MOVE E,LENFLD
MOVEM E,SUBLEN ;USE WHOLE FIELD
MOVE E,VALFLD
MOVEM E,SUBPTR
SETZM SUBCNT ;DON'T CARE ABOUT SUBFIELDS NOW
SFJ.0:
MOVE D,SUBLEN ;DEST LENGTH
MOVE B,SUBPTR
MOVE E,[POINT 7,INTBUF] ;FORMAT IT IN TEMP BUFFER
TXNE PRM,%MONEY ;IF THIS IS A MONEY FIELD
SKIPN SUBCNT ; AND WE ARE NOT IN THE FIRST SF
SKIPA
JRST [EXTEND A,[MOVSLJ ; THEN LEFT JUSTIFY IT
ZERO]
JFCL
JRST SFJ.1]
ILDB Z,B ;GET THE FIRST CHARACTER
PUSH P,Z ;SAVE IT FOR LATER
CAIE Z,"-" ;IF IT WAS A SIGN
CAIN Z,"+"
JRST [MOVEI Z,ZERO ; THEN REPLACE IT WITH ZERO
DPB Z,B
JRST .+1]
MOVE B,SUBPTR ;RESTORE THE POINTER
EXTEND A,[MOVSRJ
ZERO] ;RIGHT JUSTIFY & FILL WITH ZEROS
JFCL
POP P,Z ;IF THE LEADING CHARACTER WAS
CAIE Z,"-" ; A MINUS SIGN
JRST SFJ.1
MOVE B,[POINT 7,INTBUF] ;THEN PUT IT BACK IN THE STRING
IDPB Z,B
SFJ.1:
MOVE A,SUBLEN ;NOW COPY THE STRING BACK TO VALFLD
MOVE B,[POINT 7,INTBUF]
MOVE D,A
MOVE E,SUBPTR
EXTEND A,[MOVSRJ] ;DON'T NEED FILL
JFCL
MOVE Z,SFTYPE ;SEE IF LEADING ZEROS ARE OK
TXNE Z,%ZERO
JRST SFJ.2 ; YES - DON'T REPLACE THEM
MOVEI Z,SPACE ;REPLACE WITH SPACES
MOVE C,SUBLEN ;TEST ALL THE SUBFIELD
MOVE E,SUBPTR
MOVEM E,SUBTMP ;SAVE IT FOR THE SUBROUTINE
SETZB D,ISNEG ;NOT NEGATIVE (YET)
CALL REPZLP ;REPLACE THE ZEROS
JRST [MOVEI Z,ZERO ;ALL WAS BLANK - PUT IN AT LEAST
TXNE PRM,%SFDEF ;IF NOT SUBDIVIDED
TXNE PRM,%MONEY ; OR MONEY
DPB Z,E ; THEN INSERT ONE ZERO
JRST .+1]
SFJ.2:
PUSH P,SUBPTR
PUSH P,SFPNTR
PUSH P,VALFLD
PUSH P,LINFLD
PUSH P,COLFLD
PUSH P,SUBCNT ;WRITED CHANGES THIS
MOVE C,SUBLEN ;WRITE ONLY THIS SUBFIELD
ADD C,FLDPOS ;MAKE THIS THE LENGTH SO FAR
MOVE A,DATTYP ;JULIAN DATES ARE SPECIAL
TXZ A,%LONGD ;(EVEN IF LONG)
TXNE PRM,%DATE
CAIE A,%DATJU
SUB C,SUBCNT ;LEAVE OUT SEPARATORS
CALL WRITED ;WRITE IT TO THE SCREEN
POP P,SUBCNT
POP P,COLFLD
POP P,LINFLD
POP P,VALFLD
POP P,SFPNTR
POP P,SUBPTR
AOS (P) ;SET UP A SKIP RETURN
SFJ.3:
TXNN PRM,%SFDEF ;IF NOT A SUBFIELD
RET ; THEN NOT LENGTH TERMINATED
MOVE INT.C,SUBLEN ;FORCE LENGTH TERMINATED
SETZM TXTTAB+.RDDBC ;DONE THIS ONE
RET
SFJ.4: ;HANDLE EMPTY NUMERIC SUBFIELD
JUMPN E,[SKIPE SUBCNT ;IF NOT SEPARATOR, AND FIRST S.F.
TXNN Z,%ZERO ; OR ZERO'S NOT REQUIRED
JRST SKPRET ; THEN DONE
JRST .+1]
MOVE A,[ASCII /00000/] ;FILL INTBUF WITH ZEROS
MOVEM A,INTBUF
MOVE A,[INTBUF,,INTBUF+1]
BLT A,INTBUF+20 ;ENOUGH FOR A BIG FIELD!
JRST SFJ.1 ;THEN CONTINUE AS BEFORE
BACKUP:
CAMG INT.C,TXTTAB+.RDDBC ;ANY BYTES LEFT ?
JRST SKPRET ;SKIP RETURN IF NONE LEFT
MOVEI Z,SPACE ;REPLACE THE CHARACTER JUST DELETED
TXNN PRM,%ALPHA!%PUNCT
MOVEI Z,ZERO ;WITH ZERO IF NUMERIC
DPB Z,TXTTAB+.RDDBP
SETO A, ;MINUS ONE BYTE
IBP A,TXTTAB+.RDDBP ;IN B
MOVEM A,TXTTAB+.RDDBP
MOVE A,SUBTOT ;BACKUP TO END OF PREVIOUS SUBFIELD
MOVEM A,TOTNRD
AOS TXTTAB+.RDDBC ;UP BYTES REMAINING
RET
DOABS: ;REPOSITION THE CURSOR TO LAST CHARACTER
PUSH P,A
PUSH P,B
MOVE B,TRMCOL ;IF WE HAVE PASSED THE
CAMG B,.ONCOL ; END OF THE SCREEN
JRST [DMOVE A,LINFLD ; THEN POSITION THE HARD WAY
SETOM INTCOL
CALL $POSIT
JRST DAB.1]
CALL $BACKCU ;ELSE JUST BACKUP THE CURSOR.
DAB.1:
TXNE PRM,%NEKO ;IF NOECHO THEN DONE
JRST DAB.2
MOVE A,FILCHR ;SET UP THE FILLER CHARACTER.
CALL $SCHAR ;SEND CHARACTER IN 'A'
SKIPGE INTCOL ;IF THE LAST CHARACTER WAS OFF SCREEN
JRST [AOS INTCOL ; THEN MERELY CONTINUE
JRST DAB.2]
CALL $BACKCU ; ELSE BACKUP CURSOR.
DAB.2:
POP P,B
POP P,A
RET
SUBTTL ----- PHYSICAL DATA ENTRY ROUTINE -- TEXTI.
;**********************************************
;
; ROUTINES FOR SIMULATING TEXTI. ROUTINE
;
;**********************************************
TEXTI.: ;REPLACEMENT ROUTINE FOR TEXTI JSYS
CALL $SEND ;MAKE SURE THE SCREEN IS OK
SETZ E, ;PRESET THE TERMINATOR
SKIPN C,TXTTAB+.RDDBC ;IF THERE ARE NONE TO READ
RET ; THEN EXIT
SKIPN PREDUP ;IF THIS IS PREVIOUS DUPE
SKIPE ERRDSP ; OR THERE WAS AN ERROR LAST TIME
SKIPA ; THEN SEE TO IT
JRST TXT.2 ; ELSE CONTINUE
TXT.1:
MOVEI C,1 ;ONLY READ THE FIRST CHARACTER
CALL READST
MOVEM E,SUBTMP ;SAVE THE CHARACTER FOR NOW
SKIPE ERRDSP ;IF THERE WAS AN ERROR MESSAGE
CALL TXTERR ; THEN SEE TO IT
SKIPE PREDUP ;IF THIS IS PREVIOUS DUPE
JRST [CALL TXTPRE ; THEN SEE TO IT
JRST .+1 ; AND CONTINUE
JRST TXT.1] ;AND TRY AGAIN
MOVE C,TXTTAB+.RDDBC ;DEFAULT TO NO CHARACTERS READ YET
SKIPE E,SUBTMP ;IF IT WAS A TERMINATOR
RET ; THEN DONE
DPB A,TXTTAB+.RDDBP ;SAVE THE CHARACTER JUST READ
SOSN C,TXTTAB+.RDDBC ;IF THERE WERE NO MORE CHARACTERS
RET ; THEN DONE
TXNE PRM,%NEKO ;IF NO-ECHO
JRST [CALL $CRSRT ; THEN MOVE CURSOR RIGHT
CALL $SEND
JRST TXT.3]
TXT.2:
TXNE PRM,%NEKO ;IF NO-ECHO
JRST TXT.3 ; THEN DIFFERENT
CALL READST ;READ THE FIELD
MOVEM C,TXTTAB+.RDDBC ;AND SAVE THE NEW COUNT
RET
TXT.3: ;NO-ECHO READ
MOVEI C,1 ;READ ONE AT A TIME
CALL READST
SKIPE E ;IF TERMINATOR
RET ; THEN DONE
CALL $CRSRT ;MOVE CURSOR RIGHT
CALL $SEND
SOSE TXTTAB+.RDDBC ;IF MORE TO READ
JRST TXT.3 ; THEN DO IT
RET
TXTERR: ;ERROR ON LAST CHARACTER---CLEAR IT.
CAIN A,ESC ;IF AN ESCAPE THEN
RET ; HONOR IT.
PUSH P,A
CALL CLRERR ;CLEAR OFF THE ERROR MESSAGE
SETZM ERRDSP ;TURN OFF INDICATOR
DMOVE A,LINFLD ;GET THE LINE NUMBER
ADD B,SUBLEN ;GENERATE THE CORRECT COLUMN NUMBER
ADD B,FLDPOS
SUB B,TXTTAB+.RDDBC ;TO RESTART IN
TXNN PRM,%NEKO ;THE MOVE RIGHT IS DONE LATER FOR NOECHO
AOS B
CALL $POSIT ;POSITION
MOVE A,(P) ;GET THE CHARACTER BACK
CAIN A,BACKSP ;IF THIS IS A BACKSPACE
CALL $BACKCU ;SEND THE CHARACTER OUT
CALL $SEND ;MAKE SURE IT GOT THERE
POP P,A ;RESTORE THE CHARACTER
RET
TXTPRE: ;STARTING A PREVIOUS DUP FIELD
MOVEI B,FCCCHR+CONCHR ;LEAVE PREDUPE FIELD ON ANY
TDNN B,CHRTAB(A) ;END OF FIELD CHAR.
JRST TXP.1 ;NO..USER IS TYPING A NEW VALUE
SETOM ISTAB ;INDICATE TABBED OUT OF PREVIOUS DUPE.
CAIE A,BACKSP ;IF THIS IS NOT A BACKSPACE
RET ;THEN CONTINUE NORMALLY.
SKIPE SUBCNT ;BACKSPACE IN FIRST SF IS SILLY HERE
JRST [MOVE B,TXTTAB+.RDBFP ; ELSE IF BACKSPACE THEN BACKUP
MOVEM B,TXTTAB+.RDDBP
CALL $SEND ;FORCE THE BACKSPACE OUT
RET]
SKIPE TXTTAB+.RDDBC ;IF SOME CHARACTERS IN BUFFER
RET ; THEN THIS IS OK
AOS (P) ;DO NOT DEPOSIT CHARACTER
SOS INT.C ;TELL THE USER ITS SILLY
HRROI C,MSG.BU
CALL INTERR
AOS INT.C
PJRST $SEND
TXP.1: ;HERE WHEN USER WANTS TO CONTINUE.
SKIPL PREDUP ;IF THE FLAG WAS SET BY DELETE
JRST [SETZM PREDUP ; THEN JUST MARK IT AND RETURN
RET]
SETZM PREDUP ;FLAG PREVIOUS DUPE INDICATOR
PUSH P,A ;SAVE THE CHARACTER
SKIPN SUBCNT ;IF THIS IS THE FIRST SUBFIELD
JRST TXP.4 ; THEN CLEAR ALL THE FIELD
MOVE E,SUBPTR ;POINT TO THE CURRENT DATA
IBP E ; AND SKIP THE CURRENT CHARACTER
MOVE D,SUBLEN ;GET THE LENGTH TO CLEAR
SOJ D, ; AND UPDATE IT
MOVEI A,SPACE ;ASSUME ALPHA
TXNN PRM,%ALPHA
MOVEI A,ZERO ; UNLESS IT IS NUMERIC
MOVEM A,MOVFILL+1 ;SAVE THE FILLER
SETZB A,B ;NO SOURCE LENGTH
EXTEND A,MOVFILL ;FILL THE STORED DATA
JFCL
TXNE PRM,%NEKO ;IF THIS IS NOT ECHOING
JRST TXP.3 ; THEN DON'T CHANGE THE SCREEN
DMOVE A,LINFLD ;GET POSITION OF THIS FIELD
ADD B,FLDPOS ;POINT TO THE RIGHT PLACE
AOJ B, ; ON THE SCREEN
CALL $POSIT
MOVE A,FILCHR ;REPLACE BAD TEXT WITH FILLER
MOVE C,SUBLEN ;THE RIGHT NUMBER OF TIMES
SOJ C,
CALL $SMCHAR ;DO IT
DMOVE A,LINFLD ;GET POSITION OF THIS FIELD
ADD B,FLDPOS ;POINT TO THE RIGHT PLACE
AOJ B, ; ON THE SCREEN
CALL $POSIT
TXP.2:
CALL $SEND ;MAKE SURE IT GOES OUT
TXP.3:
POP P,A ;RESTORE THE CHARACTER
RET ;AND CONTINUE NORMALLY.
TXP.4: ;CLEAR OUT WHOLE FIELD
PUSH P,SUBPTR ;SAVE THE SUBFIELD INFO
PUSH P,SFPNTR
PUSH P,SUBTMP
PUSH P,INT.A ;AND SAVE SOME CONTEXT INFO
PUSH P,CURFLD
SETOM HXFLAG ;HIDDEN FIELDS CAN BE INITED OK
MOVE A,LENFLD ;FORCE THE FIELD TO BE CLEARED
CALL SV.NUMRD
MOVE INT.A,CURFLD ;ONLY DO THIS FIELD
SETZM CURFLD
CALL INITAL ;INIT THE FIELD
SETZM HXFLAG ;BACK TO NORMAL
SETZ A, ;AND RESET THE COUNT
CALL SV.NUMRD
POP P,CURFLD ;RESTORE CONTEXT AGAIN
POP P,INT.A
POP P,SUBTMP
POP P,SFPNTR ;RESTORE NORMALITY
POP P,SUBPTR
DMOVE A,LINFLD ;POSITION TO START OF FIELD
CALL $POSIT
MOVE A,(P) ;GET THE CHARACTER BACK
TXNN PRM,%NEKO ;IF ECHOING
CALL $SCHAR ; THEN SEND THE CARACTER AGAIN
JRST TXP.2 ;COMPLETE AS ABOVE
READST: ;READ A STRING FROM THE SCREEN
SKIPN C ;IF NOTHING TO READ
RET ; THEN EXIT
CALL SETLEN ;SET THE LENGTH OF THE FIELD
MOVE D,FLDTYP ;GET THE FIELD ATTRIBUTES
RDS.1: ;READ A CHARACTER
CALL $RDCHAR
MOVEI E,(A) ;SAVE THIS CHARACTER
TDNE D,CHRTAB(E) ;IF IT IS A TERMINATOR
RET ; THEN JUST RETURN
IDPB A,TXTTAB+.RDDBP ;ELSE STORE IT
SETZM SEPFND ;SEPARATOR NOT PENDING IF GOOD CHAR.
SOJG C,RDS.1 ;AND COUNT DOWN TILL DONE
SETZ E, ;NO MORE - SET A FLAG
RET
SUBTTL TFRCLR - CLEARS A FIELD, SECTION, OR FORM FROM SCREEN
; TFRCLR clears areas of the screen. Individual fields, sections,
; or the whole screen can be cleared. In the latter case the
; terminal is also reset. TFRCLR or TFRSTP should be called just
; before the program exits.
;
; CALL TFRCLR (field-or-section-identifier,
; error-code)
ENTER CLR,2,0,X ;ALLOW TWO OR ZERO
CALL $SBEGIN ;RESET THE OUTPUT BUFFER.
SETZM MLTCT1 ;CLEAR FLAG FOR MULT SECTION
SETZM ALLCLR
CALL $TTOPN ;MAKE SURE TERMINAL IS OPEN
HLRZ A,-1(ARG) ;GET ARG COUNT
JUMPN A,CLR.1 ;MORE THAN ZERO - JUMP
SETOM ALLCLR
SETZ INT.A,
SKIPN DATJFN ;ANY FORMS INITED YET ?
JRST CLR.9 ;NO - JUST CLEAR SCREEN
JRST CLR.2
CLR.1:
GETITM 0,ANY ;GET A NAME OR NUMBER
SKIPN INT.A ;IF ZERO
SETOM ALLCLR ; THEN SET FLAG TO CLEAR SCREEN.
SETZM @1(ARG) ;INDICATE VALID ERROR RETURN.
CLR.2:
CALL FIND ;SETUP NEXT FIELD.
JRST CLR.5 ;NOT FOUND = ERROR
JRST CLR.6 ;NO MORE = DONE
TXNE PRM,%MULT ;IF MULTIPLE -
SETOM MLTCT1 ;THEN SET THE FLAG
TXNE PRM,%DSPLY ;ON SCREEN
JRST CLR.3 ;YES
SKIPE ALLCLR ;NO--CLEAR EVERYTHING?
JRST CLR.2
JRST CLR.7
CLR.3:
SKIPN INT.A ;IF CLEARING THE WHOLE SCREEN
JRST CLR.4 ; THEN JUST MARK EACH FIELD.
CALL GETFLD ;GET FIELD ATTRIBUTES
CALL ABLANK ;BLANK WHOLE FIELD
CALL $SCHKPNT ;WRITE OUT TERMINAL BUFFER IF NECESSARY.
CLR.4:
TXZ PRM,%DSPLY ;INDICATE FIELD NOT ON SCREEN.
CALL STRPRM ;PUT PRM BACK
JRST CLR.2 ;GO FOR NEXT FIELD
CLR.5:
MOVEI Z,ERR.NF ;FIELD NOT FOUND ERROR.
MOVEM Z,@1(ARG)
RET
CLR.6: ;NORMAL EXIT
JUMPE INT.A,CLR.8 ;JUMP IF NO ARGUMENT OR FORM SPECIFIED.
CALL $HOME
CALL $SEND ;CLEAR THE OUTPUT BUFFER
MOVE Z,@1(ARG) ;RETURN ERROR IN AC0
RET
CLR.7:
MOVEI A,ERR.ND ;FIELD NOT DISPLAYED ERROR.
MOVEM A,@1(ARG) ;NOT DISPLAYED FIELD ERROR
JRST CLR.2 ;CONTINUE TILL REQUEST EXHAUSTED.
CLR.8: ;RESET TTY MODE WORD IF FORM CLEAR
HLRZ A,-1(ARG) ;CLEARING WHOLE SCREEN.
JUMPE A,CLR.9 ;IF USER SPECIFIED 'FORM',
CALL $SCLEAR ; THEN CLEAR THE SCREEN AND
CALL $SEND ; FORCE CLEAR OUT
MOVE Z,@1(ARG) ;RETURN ERROR IN AC0
RET ; RETURN TO CALLER
CLR.9: ; ELSE
CALL $TTCLS ; CLEAR SCREEN AND CLOSE TERMINAL.
SKIPE A,LPTJFN ;IF THE "LPT" IS STILL OPEN
CLOSF ; THEN CLOSE IT
JFCL
SETZB Z,LPTJFN ;MAKE SURE ITS DEAD
RET
SUBTTL CLRERR -- CLEAR ERROR LINE
CLRERR:
MOVE A,ERRLIN ;LOCATION OF ERROR LINE FOR FORM.
MOVEI B,1 ;STARTING AT FIRST POSITION
PUSH P,PRM ;SAVE RENDITION ETC
SETZ PRM, ;AND CLEAR THE BITS
CALL $POSIT ;POSTION TO LINE AND COLUMN
CALL $ERASE ; AND ERASE THE LINE.
POP P,PRM
RET ;RETURN TO CALLER
SUBTTL TFRERR - USER GENERATED ERROR MESSAGES
; TFRERR is called to put a message on the error line. The
; message will be displayed with the prevailing error line
; attributes. A field can also be initialised at the same
; time.
;
; CALL TFRERR (error-message,
; [field-identifier,
; error-code])
ENTER ERR,3,1
SETZM CURERR ;NO ERRORS YET
CAIN B,1 ;IF ONLY ONE ARGUMENT
JRST TFE.1 ;THEN JUST SEND MESSAGE
SETZM @2(ARG) ;ERROR RET
CALL $SBEGIN ;INITIALIZE TERMINAL OUTPUT BUFFER
MOVE A,CURFLD ;SAVE FOR LATER
PUSH P,A
GETITM 1,ANY ;GET FIELD IDENT
SETOM HXFLAG ;HIDDEN FIELDS CAN BE INITED OK
PUSH P,INT.A ;SAVE
SKIPLE INT.A
CALL INITAL
POP P,INT.A ;RESTORE
POP P,A ;&CURFLD
SETZM HXFLAG
MOVEM A,CURFLD
MOVE A,CURERR
SKIPE A ;NO ERROR
MOVEM A,@2(ARG)
TFE.1:
GETITM ;GET THE POINTER TO THE MESSAGE
MOVE A,INT.A
MOVE B,INT.B
PUSH P,A ;SAVE THE BYTE POINTER
CALL TRNCBL ;AND THEN FIND LAST NON-BLANK.
MOVEI A,(B) ;GET LENGTH.
POP P,B ;RESTORE BYTE POINTER TO 'B'
MOVEI D,(A) ;AND USE LENGTH RETURNED FROM TRNCBL
MOVE E,[POINT 7,INTBUF] ;IN ORDER TO MOVE THE SIGNFICANT
EXTEND A,[MOVSLJ] ;CHARACTERS TO INTBUF.
JFCL
SETZ A, ;STORE A NULL BYTE AT THE
IDPB A,E ;END IN ORDER TO MAKE ASCIZ STRING
HRROI C,INTBUF ;STARTING AT INTBUF WHICH IS
CALL PUTMSG ;TO BE PUT ON ERROR LINE
CALL $HOME1
CALL $SEND ;FORCE THE MESSAGE OUT.
MOVE Z,CURERR ;RETURN ERRORS IN AC0
RET
PUTERR: ;PUT OUT A MESSAGE BUT DON'T REPOSITION
CALL PUTMSG
JRST INTER2
INTERR: ;INTERNAL CALL TO ERROR
CALL PUTMSG
DMOVE A,LINFLD
ADD B,FLDPOS ;POINT TO RIGHT PLACE IN FIELD
ADDI B,1(INT.C)
MOVEM B,INTCOL ;FLAG THAT WE ARE OFF THE SCREEN.
SUB B,TXTTAB+.RDDBC ;FORM NEW POSITION
CALL $POSIT
INTER2:
CALL $CLIBF ;CLEAR TERMINAL INPUT BUFFER.
SETZM DEFALT ;CLEAR DEFAULTING
RET
PUTMSG:
SKIPE ERRDSP ;IF ERROR ON DISPLAY, THEN
CALL CLRERR ; CLEAR ERROR LINE
CALL $BELL ;SEND A BELL
PUSH P,FLDATR ;SAVE RENDITION BITS ETC
MOVE A,EPARAM ;COPY THE ERROR-LINE ATTRIBUTES
MOVEM A,FLDATR
MOVE A,ERRLIN ;GET ERROR-LINE POSITION
MOVEI B,1
CALL $POSIT
POP P,FLDATR
MOVE B,CHARST ;IF GRAPHIC CHAR SET IS -
CAIN B,%CSGR ;IN USE THEN REVERT TO US
JRST [SKIPE .TMOPT
CALL $SEND ;UPDATE THE SCREEN FIRST
PUSH P,OPTTTY ;SAVE THE OPTIMISER STATE
MOVE A,TTYPE
MOVEM A,OPTTTY ;AND SET TO PHYSICAL
HRROI A,[BYTE (7)ESC,"(","B",0,0]
CALL $SASCIZ
POP P,OPTTTY ;RESET
JRST .+1]
MOVE A,C ;DISPLAY MSG
CALL $SASCIZ ;SEND ASCII STRING
CAIN B,%CSGR ;RESTORE IF REQD
JRST [PUSH P,MLTHIR ;PRETEND NO MULT SECT.
SETZM MLTHIR
CALL $TTSTR ;SET THE CHARACTER MODE
POP P,MLTHIR
JRST .+1]
SETOM ERRDSP ;SAY ERROR IS ON SCREEN
SKIPN B,ERRRNG ;OUTPUT RANGE IF NEEDED
RET
MOVEI A,""""
CALL $SCHAR ;SEND THE CHARACTER OUT.
MOVE A,B
CALL $SASCIZ ;SEND ASCII STRING
MOVEI A,""""
CALL $SCHAR ;SEND THE CHARACTER OUT.
SETZM ERRRNG
RET
SUBTTL TFRCHG - CHANGE ATTRIBUTES OF FIELDS
; TFRCHG allows field attributes to be changed. It can be called
; at any level and has immediate effect.
;
; CALL TFRCHG (field-identifier,
; new-attribute-1,
; . . . . .
; new-attribute-n,
; error-code)
ENTER CHG
SETZM CVTUC ;ALL STRING MOVES ARE IMAGE
HLRE D,-1(ARG) ;GET AND SAVE ARGUMENTS FROM CALLER.
MOVN D,D
CAIGE D,3 ;IF NOT AT LEAST 3 ARGUMENTS
RET ; THEN RETURN TO CALLER.
GETITM 0,ANY ;GET THE FIELD IDENT
CHG.1:
SETZ E, ;POINT TO ATTRIB - 1
MOVE C,D
SUBI C,2
PUSH P,D ;FIND THE CORRECT FIELD.
PUSH P,E
PUSH P,C
CALL FIND ;FIND IT
JRST CHG.3 ;NOT THERE.
JRST CHG.4 ;DONE
CALL GETFLD ;GET FIELD ATTRIBUTES
POP P,C
POP P,E
POP P,D
CHG.2:
SOJL C,CHG.1 ;IF NO MORE ATTRIBUTES THEN LOOP
AOS INT.A,E ;GET OFFSET OF NEXT ATTRIBUTE
PUSH P,E
PUSH P,D
DMOVE D,[130
POINT 7,INTBUF] ;MOVE TO INTBUF
CALL GETARG ;GET THE ARGUMENT (STRING)
MOVE A,INT.B ;AND ITS LENGTH
MOVE B,INT.A
MOVE D,A ;LENGTH OF DEST
CALL MOV6OR7 ;MOVE DATA CONVERTING TO ASCII.
SETZ A, ;PUT NULL BYTE AT END OF STRING.
IDPB A,E
POP P,D
POP P,E
MOVEI A,CGTBL
MOVE B,[POINT 7,INTBUF]
PUSH P,C
TBLUK ;DO TABLE SEARCH FOR ARGUMENT.
POP P,C
TXNN B,TL%EXM!TL%ABR ;IF NOT FOUND
JRST CHG.5 ; THEN TRY NEXT ONE.
PUSH P,C ;DON'T LET IT GET LOST IN WRITE:
HRRZ A,(A) ; ELSE GET ADDRESS OF PROPER ROUTINE.
PUSHJ P,(A) ;DISPATCH TO ROUTINE
CALL STRPRM ;SAVE THE 'PRM' SETTINGS.
POP P,C
JRST CHG.2
CHG.3:
MOVEI A,ERR.NF ;FIELD WAS NOT FOUND ERROR.
JRST CHG.6
CHG.4:
SETZ A, ;GOOD RETURN.
JRST CHG.6
CHG.5:
MOVEI A,ERR.IA ;INVALID ATTRIBUTE ERROR.
SETZM CURFLD ;DON'T FORGET TO RESET - EARLY EXIT
JRST CHG.7
CHG.6:
POP P,C ;RESTORE SAVED
POP P,E ; REGISTERS.
POP P,D
CHG.7:
SOJ D, ;ONE LESS ARG
ADDI D,(ARG)
MOVEM A,@(D) ;SET ERR CODE
PUSH P,A
CALL $HOME1 ;HOME THE CURSOR
SKIPN SCNUPD ;IF UPDATING EVERY TIME
CALL $SEND ;AND SEND ANYTHING SO FAR
POP P,Z ;PUT ERROR CODE IN AC0
RET
SUBTTL CG---- ROUTINES FOR USE BY TFRCHG
CGAB:
TXZ PRM,%CLASS
TXO PRM,%ALPHA
RET
CGAN:
TXZ PRM,%CLASS ;SET THE ALPHA ONLY OR NUMERIC
TXO PRM,%ALPHA+%NUMER ; ONLY BITS.
RET
CGANY:
TXO PRM,%CLASS ;ALLOW ANY CHARACTERS
RET
CGMD:
TXZ PRM,%DUPE
TXO PRM,%MSDUP
SKIPE FNUMRD ;IF FIELD HAS INFORMATION IN IT
TXO PRM,%PRDUP ;THEN MARK 'MASTER SET'.
RET
CGND:
TXZ PRM,%DUPE
RET
CGN:
TXZ PRM,%CLASS
TXO PRM,%NUMER
RET
CGO:
TXZ PRM,%FULL+%REQD
RET
CGPD:
TXZ PRM,%DUPE
TXO PRM,%PRDUP
RET
CGP:
TXO PRM,%PROT
RET
CGR:
TXO PRM,%REQD
RET
CGUP:
TXZ PRM,%PROT
RET
CGALC: ;ALLOW LOWERCASE
TXO PRM,%LOWER
RET
CGRLC: ;RAISE-LOWERCASE
TXZ PRM,%LOWER
RET
CGAUTO: ;SET AUTO-TAB
TXZ PRM,%NAUTO
RET
CGNATO: ;SET NO-AUTO-TAB
TXO PRM,%NAUTO
RET
CGFULL: ;SET FULL-FIELD
TXO PRM,%FULL
RET
CGNFUL: ;SET NOT-FULL-FIELD
TXZ PRM,%FULL
RET
CGLEAD: ;SET LEADING-ZEROS
TXO PRM,%ZERO
RET
CGNLZR: ;SET NO-LEADING-ZEROS
TXZ PRM,%ZERO
RET
CGSPC: ;SET SPACES
TXO PRM,%SPACE
RET
CGNSPC: ;SET NO-SPACES
TXZ PRM,%SPACE
RET
CGFILL: ;CHANGE FILLER CHARACTER
AOS INT.A,E ;UPDATE THE OFFSET
CALL GETARG ;GET THE POINTER
ILDB INT.B,INT.A ;GET A CHARACTER
TLNN INT.A,100 ;IF IT WAS SIXBIT
ADDI INT.B,SPACE ; THEN MAKE IT ASCII
STORE INT.B,.FILLR
MOVEM INT.B,FILCHR ;SAVE IT FOR LATER USE
RET
CGBO: ;SET BOLD BIT
TXO PRM,%BOLD
JRST CGWRTF ;REWRITE IT
CGBL: ;SET BLINKING BIT
TXO PRM,%BLNK
JRST CGWRTF ;REWRITE IT
CGRV: ;SET REVERSE-VIDEO BIT
TXO PRM,%RVRS
JRST CGWRTF ;REWRITE IT
CGUS: ;SET UNDERSCORE BIT
TXO PRM,%UNDR
JRST CGWRTF ;REWRITE IT
CGNR: ;SET NORMAL RENDITION
TXZ PRM,%BOLD+%BLNK+%RVRS+%UNDR
JRST CGWRTF ;REWRITE IT
CGECHO: ;ALLOW ECHOS
TXZ PRM,%NEKO
RET
CGNE: ;SECURE FIELD
TXO PRM,%NEKO
RET
CGLR: ;LOWER RANGE
MOVE F,.LRANG ;DESTINATION POINTER
MOVX G,%RANGL ;PRM FLAG
PJRST CGRGCM
CGUR: ;UPPER RANGE
MOVE F,.URANG ;DESTINATION POINTER
MOVX G,%RANGU ;PRM FLAG
;FALL INTO CGRGCM
CGRGCM: ;MOVE INTBUF TO DESTINATION & PAD
AOS INT.A,E ;NEXT ATTRIBUTE
SOSGE C ;ONE LESS AROUND
PJRST SKPRET ;BOMB IF NONE LEFT
PUSH P,C
PUSH P,D
PUSH P,E
CALL GETARG ;GET POINTER AND LENGTH
TDZ PRM,G ;TURN OFF LOWER RANGE CHKING.
JUMPE INT.B,CGREX ;IF NULL LENGTH, THEN NO RANGE CHK.
MOVE A,INT.B
MOVE B,INT.A ;COPY LENGTH AND POINTER
CALL CGRGMV ;MOVE TO INTBUF
MOVE B,[POINT 7,INTBUF] ;IF LOW VALUES
ILDB C,B ;THEN LOWER RANGE CHKING OFF.
JUMPE C,CGREX
LOAD E,F,0 ;DEST
ADD E,STRPNT ;PAGE.
HRLI E,(POINT 7,0) ;MAKE IT A BYTE POINTER
MOVE D,LENFLD ;&LENGTH
TDO PRM,G ;SET RANGE INDICATOR
MOVE B,[POINT 7,INTBUF]
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;NUMERIC ?
JRST CGCMAL ;NO
PUSH P,E ;SAVE THE POINTER TO THE RANGE
EXTEND A,[MOVSRJ
ZERO] ;ZERO FILL
JFCL
POP P,E ;RESTORE THE POINTER.
MOVEI Z,ZERO ;INDICATE NON-BLANK SCANNING.
PUSH P,VALFLD ;SAVE CURRENT VALUE POINTER
MOVEM E,VALFLD ;AND POINT TO RANGE FIELD.
CALL REPZER ;PUT IN STANDARD FORM.
POP P,VALFLD ;RESTORE VALUE FIELD.
JRST CGREX ;EXIT.
CGCMAL:
EXTEND A,[MOVSLJ
SPACE] ;SPACE FILL A/N
JFCL
CGREX:
POP P,E
POP P,D
POP P,C
RET ;RETURN AND UPDATE PRM.
CGRGMV: ;MOVE TO INTBUF D-6 OR D-7
SETZM INTBUF ;INIT TO LOW VALUES
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;SKIP IF NUMERIC
JRST [MOVE Z,SIX27 ;MODIFY TABLE
TLZ 100000
MOVEM Z,SIX27
JRST .+1]
PUSH P,A ;SAVE OLD LENGTH
MOVE D,A
MOVE E,[POINT 7,INTBUF] ;DESTINATION
CALL MOV6OR7 ;MOVE CONVERTING TO ASCII.
POP P,B ;OLD LENGTH
HRLI A,0
SUBM B,A ;LENGTH MOVED
TXNN PRM,%ALPHA
TXNN PRM,%NUMER ;RESTORE TABLE IF NOT NUMER
PJRST [MOVE Z,SIX27
TLO 100000
MOVEM Z,SIX27
RET]
RET
CGWRTF: ;WRITE THE FIELD
MOVE A,TRMATR ;GET ITS ATTRIBUTES
AND A,PRM ;KEEP THE RIGHT ONES
HLRZM A,FLDATR ;SAVE THEM FOR THE WRITE
PJRST WRITE ;AND WRITE THE FIELD
;START OF NEW CALL FOR RESETING TERMINAL CHARACTERISTICS
SUBTTL TFRSET -- SET THE ATTRIBUTES OF THE TERMINAL
; TFRSET allows the terminal state to be set ready for using
; the screen handling routines. It is required for programs
; running in a sub-fork.
;
; CALL TFRSET no arguments
ENTER SET
CALL $TTCHK ;RESET THE TERMINAL CHARACTERISTICS
SETZ Z, ;NO ERRORS
RET ;RETURN TO CALLER.
SUBTTL TFRRST -- RESET TERMINAL CHARACTERISTICS FOR THE USER
; TFRRST reverses the effect of TFRSET and returns the terminal
; to user mode.
;
; CALL TFRRST no arguments
ENTER RST
CALL $TTSET ;FIRST SET THE TERMINAL
CALL $SEND ;AND FORCE OUT AND ANYTHING
CALL $TTRST ;RESET THE TERMINAL CHARACTERISTICS
SETZ Z, ;NO ERRORS
RET
SUBTTL TFRRWT -- RE-WRITE THE SCREEN
; TFRRWT causes the screen to be refreshed. It is used after
; any events which may have caused the screen to change without
; invoking TRAFFIC-20 routines.
;
; CALL TFRRWT no arguments
ENTER RWT
SKIPE OLDTT ;IF WE NEED TO SET CHARACTERISTICS
CALL $TTCHK ;THEN DO IT.
CALL $SBEGIN ;INSURE TERMINAL BUFFER FLUSHED.
SETZB INT.A,CURFLD
SKIPN .TMOPT ;IF NO OPTIMISER
CALL $SCLEAR ; THEN CLEAR ALL OF SCREEN
CALL .OINIT ;CLEAR EVERYTHING ANYWAY
CALL .OMSET ;RESET SCROLL FLAGS
RWT.RF: ;RWT.R LOOP
CALL FIND
JRST RWT.RG ;NOT-FOUND.
JRST RWT.RG ; RESTORE REGISTERS.
TXNE PRM,%MULT ;IF WE FIND A MULTIPLE FIELD
JRST RWT.RM ;THEN DO IT ALL IN ONE GO
TXZN PRM,%DSPLY ;DO THOSE PREVIOUSLY ON SCREEN
JRST RWT.RF
CALL GETFLD ;GET FIELD ATTRIBUTES
CALL TWRITE ;REWRITE TEXT
TXO PRM,%DSPLY
CALL WRITE
CALL FILL
CALL $SCHKPNT ;OUTPUT BUFFER IF GETTING FULL
JRST RWT.RF
RWT.RG:
SETZM CURFLD
CALL $HOME1
CALL $SEND ;MAKE SURE BUFFER IS OUTPUT
SETZ Z, ;NO ERRORS
RET
RWT.RM:
CALL MRWRIT ;REWRITE THE MULTIPLE SECTION
JRST RWT.RF ;ROUND AGAIN
;CALL TO RETURN THE FIELD NUMBER BASED ON FIELD NAME.
;
; TFRFNO is called to convert a SIXBIT or ASCII field name into
; a field number which may then be used more efficiently in
; calls to TFRCOB.
;
; CALL TFRFNO (Field-name,
; Field-number,
; Error-code)
;
ENTER FNO,3
GETITM 0 ;GET FIELD IDENT
JUMPE INT.A,FNO.1 ;IF FORM,
HLRE A,INT.A ; OR
JUMPE A,FNO.1 ; FIELD-NUMBER
AOJE A,FNO.1 ; OR SECTION NUMBER THEN ERROR.
;OTHERWISE ITS A STRING POINTER.
CALL FIND ;FIND THIS FIELD
JRST FNO.2 ;FIELD NOT FOUND.
JRST FNO.2 ;NO MORE FIELDS
JFCL ;GOT THE FIELD
MOVE A,CURFLD ;GET THIS FIELD NUMBER
MOVEM A,@1(ARG) ;RETURN IT FOR USER
SETZB Z,@2(ARG) ;INDICATE NO ERROR
SETZM CURFLD ;CLEAR FIRST FIELD INDICATOR
RET ;RETURN TO CALLER.
FNO.1:
MOVEI Z,ERR.BA ;BAD ARGUMENT IN CALL
JRST FNO.3 ;EXIT.
FNO.2:
MOVEI Z,ERR.NF ;FIELD ID NOT FOUND
SETZM CURFLD ;CLEAR FIELD INDICATOR
FNO.3:
MOVEM Z,@2(ARG) ;RETURN AN ERROR
SETZM @1(ARG) ;CLEAR RETURNED VALUE
RET ;RETURN TO CALLER.
SUBTTL TFRBLK - BLANK THE SCREEN
; TFRBLK simply clears the screen so that it can be used for
; displaying other information (eg, using the DISPLAY verb).
;
; CALL TFRBLK no arguments
ENTER BLK
CALL $SCLEAR ;CLEAR THE SCREEN
CALL $SEND ;AND SEND IT
SETZ Z, ;NO ERRORS
RET
SUBTTL TFRADD - ADD MORE FIELDS TO THE DATA AREA
; TFRADD informs the rest of TFRCOB that the number of fields
; in the form has been increased. It does not display the new
; fields, but simply updates the section and field tables and
; adjusts HIFLD. This routine is only useful when the form
; data is memory resident. The new fields must be contiguous
; with the existing data base.
;
; CALL TFRADD ([number-of-new-fields])
;
ENTER ADD,0,1
SKIPE A,ARG ;ARG = 0 MEANS ONLY ONE
MOVE A,@(ARG) ; ELSE GET COUNT
PUSH P,A
ADD.1:
AOS INT.A,HIFLD ;COUNT THE NEW FIELD
MOVEM INT.A,CURFLD
CALL GNX.1 ;SET UP THE POINTERS TO IT
JFCL
CALL SETTAB ;AND SET UP THE TABLES
CALL CKF.3 ;SET UP WORKING STORAGE ETC
JFCL
SOSLE (P) ;MORE?
JRST ADD.1 ; YES
ADJSP P,-1
RET
SUBTTL TFRGET - COPY DATA FROM A FIELD TO USER STORAGE
; TFRGET copies non-word aligned data from the main screen
; data area to a users local storage which must always
; be word aligned. This is useful in FORTRAN programs to
; simplify the field access algorithms.
;
; CALL TFRGET (field,
; [element-number],
; destination,
; error)
ENTER GET,4
CALL GETPUT ;FIND THE FIELD AND SET POINTERS
JUMPN Z,[RET] ;FAILED - ERROR ALREADY SET UP
MOVEI D,1(A) ;COPY LENGTH AND ALLOW FOR NULL
MOVE E,INT.A ;ADDRESS OF USER DATA AREA
EXTEND A,[MOVSLJ ;COPY THE STRING
0] ;NULL TERMINATED
JFCL ;ALWAYS WORKS (WE HOPE)
RET
SUBTTL TFRPUT - COPY USER DATA TO SCREEN AREA
; TFRPUT copies word aligned user data into the screen data
; area. This is useful for FORTRAN programs in that it allows
; the field access algorithms to be simpler.
;
; CALL TFRPUT (field,
; [element-number],
; source-address,
; error-code)
ENTER PUT,4
CALL GETPUT ;FIND THE FIELD AND SET UP POINTERS
JUMPN Z,[RET] ;FAILED - ERROR ALREADY SET
MOVE A,INT.B ;SOURCE STRING LENGTH
MOVE E,B ;POINTER TO FIELD
MOVE B,INT.A ;POINTER TO USER DATA
EXTEND A,[MOVSLJ ;COPY THE DATA
SPACE]
JFCL
RET
GETPUT: ;COMMON ROUTINE FOR TFRGET AND TFRPUT
SETOM NOSECT ;ONLY FIELDS ALLOWED
GETITM 0,ANY ;GET FIELD ID
CALL FIND ;FIND THE FIELD
JRST GTP.2 ; NOT FOUND
JRST GTP.2 ; NO MORE
LOAD B,.OFFST ;POINT TO FIELD DATA
IBP B,RECPTR ; AND GET IT RIGHT
TXNN PRM,%MULT ;IF MULTIPLE
JRST GTP.1
MOVE A,@1(ARG) ;GET ELEMENT NUMBER
SOJ A, ;BACK OFF ONE
IMUL A,MLTSIZ ;TIMES LENGTH OF AN ELEMENT
ADJBP A,B ;POINT TO THE RELEVANT ONE
MOVE B,A ;AND COPY THE POINTER BACK
GTP.1:
GETITM 2 ;AND ALSO THE USER DATA ADDRESS
LOAD D,.LENG ;GET LENGTH OF FIELD
MOVE A,D ;COPY THE LENGTH
TDZA Z,Z ;NO ERROR
GTP.2:
MOVEI Z,ERR.NF ; NO SUCH FIELD
MOVEM Z,@3(ARG)
SETZM NOSECT ;RE-ENABLE SECTION SEARCHES
RET
SUBTTL TFRMSG - WRITE A STRING TO THE LOGICAL TERMINAL
; TFRMSG allows the user program or VET routine to write a
; message to the logical terminal without having to open
; the terminal itself.
;
; CALL TFRMSG (message,
; flags)
;
ENTER MSG,1,2
PUSH P,.TMOPT ;SWITCH OFF THE OPTIMISER
SETZM .TMOPT
PUSH P,B ;SAVE THE ARGUMENT COUNT
GETITM ;GET THE MESSAGE POINTER
MOVE B,INT.A
MOVE C,INT.B ;COPY THE LENGTH AND ADDRESS
CALL $SSTRING ;SEND IT TO THE TERMINAL
POP P,B ;RESTORE THE ARG COUNT
CAIN B,1 ;IF ONLY ONE ARG
JRST TMG.1 ; THEN NO <CR><LF>
SKIPN @1(ARG) ;IF ZERO
JRST TMG.1 ; THEN NO <CR><LF>
HRROI A,[ASCIZ /
/]
CALL $SASCIZ ;SEND <CR><LF>
TMG.1:
CALL $SEND ;FORCE IT OUT
POP P,.TMOPT ;RE-ENABLE IT
SETZ Z, ;NO ERRORS
RET
SUBTTL TFRWTL - WRITE TO TFRLPT:
; TFRWTL allows the current screen to be written to the device
; TFRLPT:. The output may be preceeded be a form feed if the
; first argument is negative (integer).
;
; CALL TFRWTL (page-flag,
; error-code)
ENTER WTL,2
SETZM @1(ARG) ;CLEAR ERROR CODE
SKIPN .TMOPT ;IF THE OPTIMIZER IS OFF
JRST [MOVEI Z,ERR.NO ; THEN ERROR
MOVEM Z,@1(ARG)
RET]
MOVE A,@(ARG) ;GET PAGE FLAG
MOVEM A,PAGFLG
CALL $OPLST ;WRITE IT TO TFRLPT:
JRST [MOVEI Z,ERR.NL ;NO DEVICE AVAILABLE
MOVEM Z,@1(ARG)
RET]
SETZ Z, ;NO ERROR
RET
SUBTTL TFRRSL - RETURN A LINE FROM THE OPTIMIZER
; TFRRSL returns the specified line from the optimizer data base.
; The line is specified by starting line and column and the data
; is returned to a buffer offset by a given number of characters.
;
; CALL TFRRSL (line-number,
; column-number,
; buffer-pointer,
; offset-in-buffer,
; error-code)
ENTER RSL,5
SETZM @4(ARG)
SKIPN .TMOPT ;IF OPTIMIZER IS OFF
JRST [MOVEI A,ERR.NO ; THEN ERROR
MOVEM A,@4(ARG)
RET]
SKIPG A,@0(ARG) ;LINE NUMBER MUST BE >0
JRST RSL.1
SKIPG B,@1(ARG) ;COLUMN NUMBER MUST BE >0
JRST RSL.1
CAMG A,TRMLIN ;AND BOTH MUST BE IN RANGE
CAMLE B,TRMCOL
JRST RSL.1 ;ELSE ALSO AN ERROR
SKIPG C,@3(ARG) ;OFFSET MUST BE >0
JRST RSL.1
GETITM 2 ;GET ADDRESS OF BUFFER
;NOTE: THE LENGTH MAY NOT BE VALID IF
;THE CALL WAS FROM A NON-COBOL PROGRAM
;WE MUST THEREFORE ASSUME ITS OK
TLNN INT.A,100 ;THE POINTER MUST BE ASCII
JRST RSL.1
SOJ C, ;CONVERT COLUMN TO OFFSET
ADJBP C,INT.A ;POINT TO PLACE IN BUFFER
SOJ B,
MOVE D,TRMCOL ;GET NUMBER OF CHARACTERS TO SEND
SUB D,B ;MINUS OFFSET
MOVE A,.OLPTR(A) ;GET POINTER TO LINE
ADJBP B,A ;AND OFFSET IT
PJRST $OPLIN ;OUTPUT THE LINE
RSL.1:
MOVEI Z,ERR.IV ;ILLEGAL VALUE IN CALL
MOVEM Z,@4(ARG)
RET
SUBTTL OUTPUT ROUTINES FOR TFRRSL AND TFRWTL
$OPLIN: ;OUTPUT A LINE OF THE SCREEN
SOSGE D ;CONTINUE WHILE POSITIVE
RET
ILDB A,B ;GET A BYTE OF DATA
TXNE A,%OBLNK ;WAS IT BLANK?
MOVEI A,SPACE ; YES - USE A SPACE
ANDI A,177 ;MAKE SURE ONLY THE RIGHT BIT IS KEPT
IDPB A,C ;OUT IT GOES
JRST $OPLIN
$OPLST: ;OUTPUT A PAGE TO TFRLPT:
SKIPN .TMOPT ;IF OPTIMIZER IS OFF
RET ; THEN DONE
CALL $SEND ;FORCE AN UPDATE
SKIPN A,LPTJFN ;IF WE DON'T HAVE A JFN
JRST [MOVE A,[GJ%SHT+GJ%FOU] ;THEN GET ONE
HRROI B,[ASCIZ /TFRLPT:/]
GTJFN
ERJMP [RET]
MOVEM A,LPTJFN ;GOT ONE NOW
JRST .+1]
MOVE B,[7B5+OF%APP] ;APPEND TO THE FILE
OPENF
ERJMP [RET]
MOVEI B,14 ;GET A FORM FEED
SKIPGE PAGFLG ;SEND IT ?
BOUT ;YES
MOVEI E,1 ;START AT FIRST LINE
AOS (P) ;GOOD RETURN FROM NOW ON
OPL.1:
CAMLE E,TRMLIN ;IF PAST LAST LINE
JRST [MOVE A,LPTJFN
TXO A,CO%NRJ ;DON'T RELEASE THE JFN
CLOSF
JFCL
RET]
MOVE C,[POINT 7,STRBUF] ;USE THIS AS TEMPORARY
MOVE B,.OLPTR(E) ;GET THE LINE POINTER
SKIPE D,.OLKNS(E) ;IS THERE ANYTHING ON THIS LINE?
CALL $OPLIN ; YES - OUTPUT A LINE
MOVEI B,CR ;APPEND <CR><LF>
IDPB B,C
MOVEI B,LF
IDPB B,C
SETZ B,
IDPB B,C
MOVE A,LPTJFN ;NOW OUTPUT THE BUFFER
MOVE B,[POINT 7,STRBUF]
SETZ C,
SOUT
ERJMP [RET]
AOJA E,OPL.1 ;LOOP FOR MORE
SUBTTL TFRSYS
; TFRSYS changes various system control variables.
;
; CALL TFRSYS (variable-number,
; new-setting,
; old-setting,
; error-code)
;
; VARIABLE# --- 1 THRU 'N' FROM SYSTAB BELOW (OR NEGATIVE FOR
; FOR USER DEFINED VALUES)
; NEW-VALUE --- 0 OR -1 (TO SET OR RESET SYSTEM FLAG)
; OLD-VALUE --- VALUE (0 OR -1) OF VARIABLE AT TIME OF CALL
; ERROR --- 0 IF VALUE CHANGED, ERR.IV IF ILLEGAL VARIABLE#,
; ERR.NV IF NEW VALUE NOT 0 OR 1.
;
; THE DEFINITION OF EACH ARGUMENT IN THE SYSTAB TABLE IS:
; 0,,VARIABLE OR
; ROUTINE,,VARIABLE
;
; WHERE THE ROUTINE IS CALLED AFTER THE VARIABLE IS SET TO 0 OR -1.
;
SYSUSR=SYSTAB-. ;NUMBER OF USER ARGUMENTS
;IF AN INSTALLATION WANTS TO DEFINE ITS
; OWN SYSTEM VARIABLE, THEN IT SHOULD
; PUT THE VARIABLE TO BE REDEFINED BETWEEN
; THE DEFINITION OF SYSUSR AND SYSTAB IN
; ARE DEFINED AFTERWARDS.
SYSTAB: 0
OLDTT ;(1) ;IF -1, THEN RESET TERMINAL CHARACTERISTICS
; ON EACH TRAFFIC CALL.
;IF 0, THEN ONLY RESET THEM ON DEMAND (TFRSET).
OLDRN ;(2) ;IF 0, THEN REWRITE NUMERIC VALUES RIGHT JUSTIFIED.
;IF -1, THEN DO NOT REWRITE THESE VALUES.
OLDLC ;(3) ;IF 0, THEN NO LOWERCASE, IF -1 THEN LC.
SYS100,,OLDCC ;(4) ;IF 0, THEN NO CONTROL/C TRAPPING, IF
;-1 THEN CONTROL/C TRAPPING.
0 ;(5) ;OBSOLETE
0 ;(6) ;OBSOLETE
NEWRND ;(7) ;IF 0, THEN RENDITION SETUP IS DONE
;IF -1, THEN NO RENDITION SETUP
NEWMMS ;(8) ;IF 0, THEN MESSAGE OUTPUT DURING MULT SEC WRITE
;IF -1, THEN NO MESSAGE OUTPUT
NEWMNY ;(9) ;IF 0, THEN V4 MONEY SPEC
;IF -1, THEN V2A MONEY SPEC
NEWCHM ;(10) ;IF 0 THEN CURSOR GOES HOME AFTER ALL CALLS
;IF -1 THEN CURSOR DOES NOT GO HOME
BRK128 ;(11) ;IF 0 THEN 3A WAY
;IF -1 THEN 128 CHAR BREAK SET FOR V4
RSCANM ;(12) ;IF 0 THEN RE-READOF MULTIPLE SECTION STARTS AT
; THE END OF THE SECTION
;IF -1 THEN RE-READ STARTS AT THE FIRST ELEMENT
NEWAUT ;(13) ;IF 0 THEN MESSAGE WILL BE SENT IF NO-AUTO-TAB
; FIELD IS FILLED.
;IF -1 THEN THE MESSAGE WILL NOT BE SENT
SCNUPD ;(14) ;IF 0 THEN UPDATE SCREEN ON EACH CALL WHICH MAY
; HAVE CHANGED THE SCREEN
;IF -1 THEN UPDATE THE SCREEN ONLY ON A READ
SYSMAX=.-SYSTAB
ENTER SYS,4
SETZM @3(ARG) ;INITIALIZE ERROR RETURN
MOVE A,@(ARG) ;GET THE VARIABLE#
JUMPL A,SYS80 ;MAY BE USER VARIABLE
JUMPE A,SYS90 ;ILLEGAL VALUE.
CAIL A,SYSMAX ;IF NOT LEGAL NUMBER
JRST SYS90 ; THEN INFORM USER.
SYS50:
HRRZ C,SYSTAB(A) ;GET ADDRESS OF VARIABLE
MOVE B,(C) ;GET CURRENT VALUE OF VARIABLE.
MOVEM B,@2(ARG) ; AND STORE FOR CALLER.
MOVE B,@1(ARG) ;GET NEW VALUE..
CAME B,[-1] ;IF VALUE IS -1 OR
SKIPN B ; 0, THEN IT IS LEGAL
SKIPA ; ELSE
JRST SYS95 ; IT IS AN ERROR.
MOVEM B,(C) ;STORE NEW VALUE.
HLRZ C,SYSTAB(A) ;GET THE ROUTINE TO CALL IF ANY
SKIPE C ;IF EMPTY THEN NO ROUTINE.
CALL (C) ;ELSE CALL THE ROUTINE.
SETZ Z, ;NO ERROR
SKIPE NEWMNY ;IF NOW USING OLD MONEY SPEC
SETZM NEWNSJ ;THEN DON'T TRY TO JUSTIFY MIXED SF'S
RET ; AND RETURN TO CALLER.
SYS80: ;CHECK FOR LEGAL USER VARIABLE
MOVN B,A ;GET MAGNITUDE OF VALUE
CAIG B,SYSUSR ;IF WITHIN USER VARIABLE RANGE
JRST SYS50 ; THEN TREAT NORMALLY.
SYS90:
SKIPA Z,[ERR.IV] ;INVALID VARIABLE NUMBER
SYS95:
MOVEI Z,ERR.NV ;ARGUMENT NOT 0 OR -1.
MOVEM Z,@3(ARG) ;STORE THE ERROR.
RET
SYS100:
PJRST $CTRLC ;CHANGE THE HANDLING OF CONTROL-C
SUBTTL INPDAT AND OUPDAT ROUTINES
;
; IODATE CONVERTS DATES IN STANDARD FORMS TO AN INTERNAL FORMAT AND BACK
; AGAIN. THE ROUTINES ARE CALLEABLE FROM COBOL BY THE FOLLOWING COMMANDS:
;
; CALL INPDAT (source-string,
; destination-string,
; format)
;
; WHERE,
; SOURCE-STRING IS THE DATE SOURCE AND MUST BE DISPLAY-7,
; DESTINATION-STRING IS THE OUTPUT POINTER AND MUST BE
; DISPLAY-7 PICTURE 9(5)
; FORMAT IS THE FORMAT EFFECTOR AND MUST BE COMP PICTURE 9(1)
; VALUES FOR FORMAT ARE -
; 0 - USE TODAYS DATE
; 1 - DATE IS MMDDYY
; 2 - DATE IS DDMMMYY
; 3 - DATE IS DDMMYY
; 4 - DATE IS YYMMDD
;
; THE OUTPUT OF INPDAT IS A COMP VALUE IN THE RANGE 0 TO 99999 WHERE 0
; REFERS TO 1-JAN-1900.
;
;
; IN ORDER TO CONVERT BACK TO STANDARD FORM, THE ROUTINE OUTDAT MUST BE USED:
;
; CALL OUTDAT (source-string,
; destination-string,
; format)
;
; WHERE,
; SOURCE-STRING IS THE INTERNAL VALUE FROM INPDAT AND MUST BE
; DISPLAY-7 PICTURE 9(5)
; DESTINATION-STRING IS THE OUTPUT POINTER AND MUST BE DISPLAY-7
; FORMAT IS THE DATE FORMAT EFFECTOR AND MUST BE COMP PICTURE 9(1)
; VALUES FOR FORMAT ARE -
; 1 - DATE IS MMDDYY
; 2 - DATE IS DDMMMYY
; 3 - DATE IS DDMMYY
; 4 - DATE IS YYMMDD
;
;
;TABLE OF BYTE POINTERS TO TEMP
IPTR1: POINT 7,TEMP
POINT 7,TEMP
POINT 7,TEMP,20
POINT 7,TEMP+1,6
IPTR2: POINT 7,TEMP,20
POINT 7,TEMP,20
POINT 7,TEMP
POINT 7,TEMP
IPTR3: POINT 7,TEMP+1,6
POINT 7,TEMP+1,13
POINT 7,TEMP+1,6
POINT 7,TEMP,20
ENTRY INPDAT
INPDAT:: ;CONVERT DATE TO INTERNAL FORMAT
ENTER ,3
SETOM INT.A ;SET A FLAG IN CASE OF ERROR
SKIPN F,@2(ARG) ;GET FORMAT
JRST INPD1 ;ZERO IS SPECIAL
CAIL F,5
JRST IPERR ;>5 IS BAD
GETITM ;GET SOURCE POINTER
MOVE B,INT.A
INPD0: ;INTERNAL CALL
MOVE C,IPTR1-1(F) ;GET BYTE POINTER FOR FIRST TWO
CALL CMOV2
CAIN F,4 ;IF 'COBOL'
MOVE C,[POINT 7,TEMP+1] ;BACKUP A FEW
MOVEI A,"-" ;PUT IN SEP CHAR
IDPB A,C
MOVE C,IPTR2-1(F) ;POINTER FOR NEXT TWO
CALL CMOV2
CAIN F,2 ;FORMAT 2 HAS 'MMM'
CALL CMOV1
MOVEI A,"-"
IDPB A,C
MOVE C,IPTR3-1(F) ;LAST TWO CHARS
CALL CMOV2
SETZ A,
CAIN F,4 ;IF 'COBOL'
MOVE C,[POINT 7,TEMP+1,20] ;THEN NULL NOT AFTER YEAR
IDPB A,C ;END WITH NULL BYTE
MOVE A,[POINT 7,TEMP]
MOVSI B,(IT%NTI)
IDTNC ;CONVERT TO NUMBERS
ERJMP IPERR
MOVEI D,124300 ;SET TO MIDDAY SO DAYLIGHT SAVINGS
;WON'T MESS IT UP AT MIDNIGHT
IDCNV ;CONVERT TO BINARY
ERJMP IPERR
JRST INPD2
INPD1: ;TODAYS DATE
GTAD
MOVE B,A
INPD2:
MOVE A,[POINT 7,TEMPX] ;PUT IN TEMP (BECAUSE OF TRAILING NULL)
HLRZS B
SUBI B,^D15020
SKIPN INT.A ;IF STILL ZERO
JRST SKPRET ; THEN IT WAS AN INTERNAL CALL
MOVE C,[NO%MAG+NO%LFL+NO%ZRO+5B17+^D10]
NOUT
ERJMP IPERR
GETITM 1 ;GET DESTINATION POINTER
MOVE C,INT.A
MOVE B,[POINT 7,TEMPX]
JRST IPRET ;COPY RESULT
IPERR:
SKIPN INT.A ;IF STILL ZERO
RET ; THEN INTERNAL - AND ERROR
GETITM 1 ;DESTINATION
MOVE C,INT.A
MOVE B,[POINT 7,ZEROS]
IPRET: ;COPY RESULT TO USER
CALL CMOV2
CALL CMOV2
PJRST CMOV1
ENTRY OUTDAT
OUTDAT::
ENTER ,3
SKIPN F,@2(ARG) ;GET FORMAT
JRST OPERR ;0=BAD
CAIL F,5
JRST OPERR ;>4=BAD
GETITM ;POINT TO SOURCE
MOVE B,INT.A
MOVE C,[POINT 7,TEMP]
CALL CMOV2
CALL CMOV2
CALL CMOV1
SETZ A,
IDPB A,C
MOVE A,[POINT 7,TEMP]
MOVEI C,^D10
NIN
ERJMP OPERR
ADDI B,^D15020
HRLZS B
SETZ D,
ODCNV
ERJMP OPERR
SETZ D,
MOVE A,[POINT 7,TEMP]
MOVE E,FLAGS-1(F)
ODTNC
ERJMP OPERR
GETITM 1 ;POINT TO DESTINATION
MOVE C,INT.A
CAIN F,4 ;IF COBOL DATE
JRST OPCDAT ;THEN SPECIAL
MOVE B,[POINT 7,TEMP]
CALL CMOV2
IBP B
CALL CMOV2
CAIN F,2
CALL CMOV1
IBP B
PJRST CMOV2
;SPECIAL COPY FOR COBOL DATE FORMAT
OPCDAT:
MOVE B,[POINT 7,TEMP+1,6] ;YEAR
CALL CMOV2
MOVE B,[POINT 7,TEMP] ;MONTH, DAY
CALL CMOV2
IBP B ;SKIP "-"
PJRST CMOV2
OPERR:
GETITM 1 ;POINT TO DESTINATION
MOVE C,INT.A
MOVE B,[POINT 7,ZEROS]
CALL CMOV2
CALL CMOV2
CALL CMOV1
CAIN F,2
CALL CMOV1
RET
;CHARACTER MOVE SUBROUTINES FOR INPDAT AND OUTDAT
CMOV2:
CALL CMOV1
CMOV1:
ILDB A,B
CAIL A,140
SUBI A,SPACE
CAIN A,SPACE
MOVEI A,ZERO
IDPB A,C
RET
SUBTTL MISCELLANEOUS ROUTINES
;
; HELP MESSAGE PRINTER
;
$HELP:
PUSH P,FLDATR ;SAVE FIELD ATTRIBUTES
SETZM FLDATR ;AND CLEAR FOR HELP MESSAGE
SKIPE ERRDSP
CALL CLRERR ;CLEAR ERROR LINE
MOVE A,ERRLIN
MOVEI B,1
CALL $POSIT ;POSITION TO ERROR LINE
LOAD C,.LNHLP ;GET LENGTH OF MESSAGE
JUMPE C,HLP.1
LOAD B,.HELP ;ADRS OF MESSAGE
ADD B,STRPNT
HRLI B,(POINT 7,0) ;MAKE IT A BYTE POINTER
CALL $SSTRING ;PUT STRING OUT
JRST HLP.4
HLP.1: ;DEFAULT HELP MESSAGE
LDB A,[POINT 2,PRM,32] ;GET TYPE OF FIELD
HRRO A,[MSG.NN ; NUMERIC
MSG.AO ; ALPHABETIC
MSG.NA]-1(A) ; ALPHANUMERIC
TXNE PRM,%PUNCT ;USE DIFFERENT MESSAGE FOR PUNCT
HRROI A,MSG.AP
TXNE PRM,%YN ; OR YES/NO
HRROI A,MSG.YN
CALL $SASCIZ ;SEND THIS PART
TXNN PRM,%RANGL!%RANGU ;IF UPPER OR LOWER RANGE AVAILABLE
JRST HLP.4
MOVE A,[POINT 7,[ASCIZ /; "/]]
CALL $SASCIZ ;THEN TYPE THE RANGES
LOAD A,.LRANG,A
JUMPE A,HLP.2
ADD A,STRPNT
HRLI A,(POINT 7,0)
CALL $SASCIZ ;DO LOWER RANGE
HLP.2:
HRROI A,MSG.TO ;" TO "
CALL $SASCIZ
LOAD A,.URANG,A
JUMPE A,HLP.3
ADD A,STRPNT
HRLI A,(POINT 7,0)
CALL $SASCIZ ;DO UPPER RANGE
HLP.3:
MOVEI A,""""
CALL $SCHAR ;AND END WITH "
HLP.4:
POP P,FLDATR
MOVEI B,4 ;FORCE REREAD OF FIELD
SETOM ERRDSP ;MESSAGE ON SCREEN
RET
;ROUTINES FOR 128 CHARACTER BREAK SET
SETTYP: ;TELL MONITOR THE TYPE OF FIELD
SKIPN BRK128 ;IF NOT USING THE BREAK SET
RET ;THE RETURN
PUSH P,A ;PRESERVE TYPE MASK
MOVE A,TTJFN ;USING CONNECTED TTY
MOVX B,.MOSBM ;SET THE BREAK SET
MTOPR ;SET IT
ERJMP [SETZM BRK128 ;NOT A RELEASE 4 SYSTEM
POP P,A
RET]
POP P,A
RET
SETLEN: ;TELL MONITOR THE LENGTH OF FIELD
SKIPN BRK128 ;IF NOT USING THE BREAK SET
RET ;THEN RETURN
MOVE A,TTJFN ;USE CONNECTED TTY
MOVX B,.MOSFW ;SET FIELD WIDTH
MTOPR ;SET IT
ERJMP [SETZM BRK128 ;NOT A RELEASE 4 SYSTEM
RET]
RET
CHKLWR: ;SEE IF FIELD ALLOWS LOWER CASE
TXNE PRM,%LOWER ;WELL?
JRST CKL.1 ; YES - TRY TO SET IT
SKIPN LWRCAS ;NO - DID THE PREVIOUS ONE?
RET ; NO - DONE
SETZM LWRCAS ;YES - BUT NOT NOW
MOVE B,NEWMOD ;AND FORCE UPPER CASE
PJRST $TTCAS ;GO AND DO IT
CKL.1: ;SET LOWER CASE IF WE CAN
SKIPN LWRCAS ;WAS THE LAST FIELD UPPERCASE, OR,
SKIPN OLDLC ; IS LOWER CASE ALLOWED?
RET ; NO
SETOM LWRCAS ;NOW IN LOWER CASE
MOVE B,NLCMOD ;SET LOWER CASE
PJRST $TTCAS
SUBTTL GENERIC TERMINAL DEVICE ROUTINES
IFN FT%V05,<
$DOCC: ;HANDLE SPECIAL CONTROL CHARACTER SEQUENCES.
MOVE A,OPTTTY ;GET PHYSICAL TERMINAL TYPE.
JRST @.+1(A) ;DISPATCH
[RET] ;OPTIMIZE
$10DCC ;VT05
[RET] ;VT50H
[RET] ;VT52
[RET] ;VT100
[RET] ;VT132
>
$BELL: ;RING THE BELL (DO NOT WAIT--DO IT NOW!!)
PUSH P,A ;SAVE SOME THINGS
PUSH P,.TMOPT
SETZM .TMOPT ;MAKE IT LOOK UNOPTIMIZED
MOVEI A,7 ;THATS THE BELL
CALL $SCHAR ;PUT IT IN BUFFER
POP P,.TMOPT ;RESTORE
POP P,A ; AND
RET ; EXIT.
$GTESC: ;GET DISTINGUISHING CHARACTER AFTER THE ESCAPE
DISPATCH ESC
$ERASE: ;ERASE TO END OF LINE
DISPATCH ERS
$SCLEAR: ;CLEAR WHOLE SCREEN
CALL $HOME ;POSITION TO TOP OF SCREEN
SKIPN .TMOPT ;IF OPTIMISER IS OFF
CALL .ORESET ; THEN CLEAR THE LINE FLAGS
$CLEAR: ;CLEAR FROM CURRENT POSITION
DISPATCH CLR
$HOME1: ;HOME IF REQUIRED TO
SKIPE NEWCHM ;ONLY DO IT IF -1
RET
$HOME: ;MOVE CURSOR TO HOME POSITION
DISPATCH HOM
$BACKCU: ;BACKUP CURSOR.
DISPATCH BCU
$POSIT: ;POSITION TO SPECIFIED POSITION
CALL $POS ;POSITION TO CORRECT SPOT
PJRST $SETATR ;SET THE ATTRIBUTES
$POS: ;DO THE POSITIONING HERE
CAMLE A,TRMLIN ;IF LINE IS BEYOND THE BOTTOM
MOVE A,TRMLIN ; THEN PUT IT ON THE BOTTOM.
DISPATCH POS
$SETATR:
DISPATCH ATR ;WE NEED TO SET THEM EVERY TIME
$SCRLU: ;SCROLL UP
SKIPL NOSCRL ;DO IT IF ENABLED
RET
PUSH P,OPTTTY ;ALWAYS GO TO REAL HANDLER
MOVE A,TTYPE ;PRETEND WE'RE NOT OPTIMISING
MOVEM A,OPTTTY
PUSH P,[$SCRUD] ;RETURN TO HERE
DISPATCH SCU
$SCRLD: ;SCROLL DOWN
PUSH P,OPTTTY ;ALWAYS GO TO REAL HANDLER
MOVE A,TTYPE ;PRETEND WE'RE NOT OPTIMISING
MOVEM A,OPTTTY
PUSH P,[$SCRUD] ;RETURN TO HERE
DISPATCH SCD
$SCRUD:
POP P,OPTTTY ;RESTORE STATE
RET
$CRSRT: ;MOVE CURSOR RIGHT ONE PLACE
DISPATCH CRT
$DISPATCH: ;DISPATCH ROUTINE FOR ALL THESE CALLS
HRRZS ARG ;REMOVE FLAGS
ADD ARG,OPTTTY ;OFFSET BY THE TERMINAL TYPE
PUSH P,A ;SAVE SOME THINGS FOR THE CALLER
PUSH P,B
PUSH P,C
CALL @(ARG) ;CALL THE RIGHT ROUTINE
POP P,C ;RESTORE THE AC'S
POP P,B
POP P,A
POP P,ARG ;RESTORE ARG
RET
SUBTTL SCREEN OUTPUT OPTIMIZATION ROUTINES
; SCREEN OUTPUT OPTIMIZATION ROUTINES $00XXX
$00ESC: ;OPTIMIZE
MOVE A,TTYPE ;MAKE THE ROUTINE
MOVEM A,OPTTTY ; DISPATCH TO THE
CALL $GTESC ; REAL TERMINAL
SETZM OPTTTY ;INDICATE OPTIMIZE
RET
$00CLR: ; CHANGES OPTIMIZE
PUSH P,.ONBP ; SAVE THINGS THAT WILL CHANGE
PUSH P,.ONLINE
PUSH P,.ONCOL
MOVE A,.ONLINE ;CURRENT LINE NUMBER
MOVE B,.ONCOL ; AND CURRENT COLUMN
$01CLR: ; FOR EACH LINE TO BOTTOM OF SCREEN
CAML A,TRMLIN ;IF AT THE BOTTOM OF SCREEN
JRST [SETOM .OCHNG ; THEN INDICATE A CHANGE
POP P,.ONCOL ; AND RESTORE REAL VALUES.
POP P,.ONLINE
POP P,.ONBP
RET]
;ELSE PROCESS EACH LINE.
MOVEM B,.ONCOL ;INDICATE COLUMN
ADJBP B,.OLPTR(A)
MOVEM B,.ONBP ; TO THE LINE
CALL $00ERS ; AND ERASE IT
AOS A,.ONLINE ; ADVANCE TO NEXT LINE
MOVEI B,1 ;NEXT ALWAYS STARTS ON COL 1.
JRST $01CLR ;BEFORE GOING TO NEXT LINE.
$00ERS: ;OPTIMIZE
PUSH P,.ONBP
PUSH P,.OATTR
PUSH P,.ONCOL
SETZM .OATTR
MOVE B,.ONLINE
SKIPE NEWFRM ;IF THIS IS A NEW FORM
SETZM .OFLAG(B) ; THEN CLEAR THE LINE FLAG
MOVE C,.OLKNS(B) ;GET LAST USED COLUMN.
SUB C,.ONCOL
AOS C ;IF SAME, CLEAR THIS ONE.
MOVEI A,SPACE
SKIPLE C
CALL $00SMC
POP P,.ONCOL
POP P,.OATTR
POP P,.ONBP
RET
$00HOM: ;OPTIMIZE
MOVEI A,1
MOVEI B,1
PJRST $00POS
$00BCU: ;OPTIMIZE
MOVE A,.ONCOL ;IF AT THE
CAIG A,1 ; BEGINNING
RET ; THEN WE ARE BACK AS FAR AS WE CAN GO.
SETO A,
ADJBP A,.ONBP
MOVEM A,.ONBP
LDB C,.ONBP ;GET THIS CHARACTERS
TXZ C,777 ; ATTRIBUTES
MOVEM C,FLDATR
MOVEM C,.OATTR ; POSITION AND SAVE.
SOS .ONCOL ; BACKUP ONE COLUMN
RET
$00POS: ;OPTIMIZE
SKIPG B ;IF COL IS LESS THAN 1
MOVEI B,1 ; THEN MAKE IT 1.
CAMLE B,TRMCOL ;IF COL GREATER THAN LAST
MOVE B,TRMCOL ; THEN POINT AT LAST COLUMN
MOVEM B,.ONCOL
SKIPG A ;IF LINE LESS THAN 1
MOVEI A,1 ; THEN MAKE IT 1.
MOVEM A,.ONLINE
ADJBP B,.OLPTR(A) ; GET POINTER TO CHAR.
MOVEM B,.ONBP ;UPDATE POINTER
RET
$00ATR: ;SET UP THE ATTRIBUTES
MOVE A,FLDATR ;GET THIS FIELDS ATTRIBUTES
MOVEM A,.OATTR ; AND SAVE IT
MOVE B,.ONLINE ;IF THE TALL/WIDE BITS ARE SET
SKIPE C,.OFLAG(B)
TXNE C,%OLCLR ; OR IF CLEARING THE LINE STATE
SKIPA ; THEN DO IT
RET ; ELSE DONE
CALL $00STW ;SEE IF TALL/WIDE NEED SETTING
SKIPE C
MOVEM C,.OFLAG(B) ;AND SAVE THE RESULT IF NOT ZERO
RET
$00SMC: ;SEND CHARACTER MULTIPLE TIMES
PUSH P,C ;RETAIN VALUE AFTER OUTPUT
CALL $00SCH ;SEND THE CHAR IN AC-A.
SOJG C,.-1 ;SPIN UNTIL DONE
POP P,C
RET
$00SCH: ;OUTPUT A CHARACTER
SKIPN A ;IF CHARACTER IS A NULL
RET ; THEN FORGET IT.
CAIGE A,SPACE ;IF CONTROL CHARACTERS GOING OUT
JRST [TMSG <
TFRCOB (SCHAR) Fatal internal consistency check>
HALTF] ; THEN DIE
PUSH P,A
PUSH P,B ;SAVE ALSO
OR A,.OATTR ;APPEND CURRENT ATTRIBUTES
LDB B,.ONBP ;GET CURRENT CHARACTER
CAIN A,SPACE ;IF THIS IS A PURE SPACE
JRST [CAIE B,SPACE ; AND IF WE ARE AT A SPACE
TXNE B,%OBLNK ; OR THIS WAS ALREADY BLANKED
JRST [MOVE B,.ONCOL ; THEN NOTHING TO DO.
JRST $02SCH] ; EXPECT COLUMN MARKERS.
TXO B,%OBLNK ; ELSE MARK AS BLANKED AND
DPB B,.ONBP ; PUT BACK SAME
JRST $01SCH] ; CHARACTER.
;NEW CHARACTER IS NOT A SPACE
TXZ B,%OBLNK+%OCHNG ;ISOLATE OLD CHAR AND VIDEO
SKIPN MWTALL ;IF WRITING ALL AS CHANGED, OR
CAME A,B ; IF THIS IS NOT THE SAME CHARACTER
JRST [TXO A,%OCHNG ; THEN MARK NEW CHARACTER AS
DPB A,.ONBP ; CHANGED.
JRST $01SCH]
;SAME NON-BLANK CHARACTER
LDB B,.ONBP ;SAME CHARACTER. IF WE
TXZE B,%OBLNK ; ARE CHANGING FROM BLANK
DPB B,.ONBP ; THEN WRITE-BACK WITHOUT FLAG.
MOVE B,.ONCOL ;SAME CHARACTER AS BEFORE.
JRST $02SCH ; NO NEED TO UPDATE.
$01SCH:
MOVE A,.ONLINE ;FOR THIS LINE......
MOVE B,.ONCOL ;GET THE COLUMN BEING CHANGED.
SKIPN .ORGHT(A) ; IF FIRST CHANGE ON LINE
JRST [MOVE Z,TRMCOL ;THEN INITIALIZE LEFTMOST
MOVEM Z,.OLEFT(A) ; POSITION TO LAST ON LINE
SETOM .OCHNG ; INDICATE A CHANGE, AND
JRST .+1] ; CONTINUE.
CAMLE B,.ORGHT(A) ;IF THIS CHANGE FURTHER OUT ON
MOVEM B,.ORGHT(A) ; LINE, MARK ITS POSITION.
CAMLE B,.OLKNS(A) ;IF THIS CHANGE FURTHER OUT THAN
MOVEM B,.OLKNS(A) ; LAST KNOWN NON-SPACE, MARK IT.
CAMGE B,.OLEFT(A) ;AND IF FURTHER TO LEFT
MOVEM B,.OLEFT(A) ; MARK THAT POSITION.
$02SCH:
SKIPE VERT ;IF VERTICAL
JRST [MOVE A,.ONLINE ; THEN POINT TO NEW LINE
MOVE B,.ONCOL
AOS A
CALL $00POS ; AND SET UP POINTERS
JRST $03SCH]
CAMGE B,TRMCOL ;IF NOT AT THE RIGHT MARGIN OF LINE,
JRST [AOS .ONCOL ; UPDATE COUNTERS
IBP .ONBP
JRST .+1]
$03SCH:
POP P,B
POP P,A
RET
$00RCH: ;READ A CHARACTER (ITS IN REG-A)
CAIL A,SPACE ;IF A CONTROL CHARACTER
SKIPE .OECHO ; OR IF ECHO IS OFF
RET ; THEN DO NOT PROCESS.
CAIN A,RUBOUT ; IF RUBOUT
RET ; THEN DONOT DEPOSIT IT
PUSH P,B
LDB B,.ONBP ; CURRENT CHAR
ANDI B,777600 ;RETAIN ONLY THE ATTRIBUTES
OR B,A ;INSERT THE CHARACTER
DPB B,.ONBP
MOVE B,.ONCOL ;GET THE COLUMN NUMBER
PUSH P,A ;SAVE THE CHARACTER
MOVE A,.ONLINE ;POINT TO THE CURRENT LINE
CAMLE B,.OLKNS(A) ;SEE IF THIS IS THE LAST CHARACTER
MOVEM B,.OLKNS(A) ; AND SAVE THE COLUMN NUMBER IF SO
POP P,A
CAMGE B,TRMCOL ;IF COLUMN NOT TO RIGHT SIDE
JRST [AOS .ONCOL ;UPDATING ALL INDICATORS
IBP .ONBP
JRST .+1]
POP P,B
RET
$00STW: ;SET TALL/WIDE LINE MODE FLAGS
SETZ C, ;ASSUME NOTHING TO DO
TXNE A,(%WIDE) ;WIDE FIELD?
MOVX C,%OWIDE ; YES
TXNN A,(%TALL) ;TALL FIELD?
RET ; NO
MOVX C,%OTAL1 ;ASSUME TOP HALF
SKIPE TOPBOT ;UNLESS TOPBOT=-1
MOVX C,%OTAL2 ; THEN IT IS BOTTOM HALF
RET
$00SCD: ;MOVE THE LINES DOWN ONE
SKIPN .TMOPT ;IF OPTIMISING - CONTINUE
RET
MOVE A,MLTHIR ;START AT THE TOP
$01SCD:
HRL B,.OLPTR-1(A) ;BUILD A BLT POINTER
HRR B,.OLPTR(A)
HRRZ C,.OLPTR(A)
ADD C,WPLINE ;LAST ADDRESS +1
BLT B,-1(C) ;COPY THIS LINE
SOS A
CAME A,MLTLOR ;LOOP TILL WE REACH THE TOP
JRST $01SCD
RET
$00SCU:
SKIPN .TMOPT ;IF OPTIMISING - CONTINUE
RET
MOVE A,MLTLOR ;BUILD A BLT POINTER - WE CAN OVERLAP
HRL B,.OLPTR+1(A) ;ON THIS MOVE SINCE ITS BACKWARDS
HRR B,.OLPTR(A)
MOVE A,MLTHIR
HRRZ A,.OLPTR(A) ;LAST ADRS +1
BLT B,-1(A)
RET
$00CRT: ;CURSOR RIGHT
MOVEI A,1
ADDM A,.ONCOL
IBP .ONBP
RET
.OINIT: ;INITIALIZE THE SCREEN INITIALLY
SKIPN .TMOPT ;IF THE OPTIMISER IS OFF
PJRST .ORESET ; THEN JUST RESET THE FLAGS ETC
MOVE A,TRMCOL ;IF TERMINAL TYPE HAS MORE COLS
CAILE A,MAXCOL ; THAN SCREEN BUFFERS WERE
JRST [SETZM .TMOPT ; BUILT FOR, THEN
RET] ; TURN OFF OPTIMIZER
MOVE A,TRMLIN ;ALSO IF TOO MANY LINES
CAILE A,MAXLIN ; THEN TURN OFF
JRST [SETZM .TMOPT ; THE OPTIMIZER.
RET]
CALL .ORESET ;CLEAR THE TABLES AND FLAGS
;CLEAR THE SCREEN AND SCREEN BUFFER
MOVE A,[BYTE (18)SPACE,SPACE]
MOVEM A,@.OSCRN ;SET SCREEN TO ALL BLANKS
MOVE A,.OSCRN ;BUILD A BLT POINTER
HRLS A
AOS A
MOVE B,.OSCRN ;BUILD 'TO' POINTER
ADD B,SCWORD
BLT A,-1(B)
SETZM .OCHNG ;INDICATE NO CHANGES TO SCREEN
;END OF CHANGE
MOVE A,TTYPE ;THEN SET THE REAL CURSOR
MOVEM A,OPTTTY ; AND CLEAR
CALL $SCLEAR ; THE REAL SCREEN
CALL $SEND
SETZM OPTTTY
CALL $HOME ;MOVE CURSOR TO TOP
MOVEI A,1 ;
MOVEM A,.ONCOL ;INDICATE CURSOR POSITION.
MOVEM A,.ONLINE
ADJBP A,.OLPTR(A) ; AND SET UP POINTER
MOVEM A,.ONBP ; TO FIRST BYTE.
RET
.ORESET: ;BUILD TABLES FOR EACH LINE
MOVE A,.OSCRN ;GET ADDRESS OF SCREEN BUFFER
TLO A,(POINT 18,0) ; AND MAKE A BYTE POINTER
MOVEI B,1 ;START ON LINE ONE.
.ORST1:
MOVEM A,.OLPTR(B) ;BUILD THE LINE POINTER
SETZM .OLEFT(B) ;INITIALIZE CHANGED POSITION
SETZM .ORGHT(B) ; BOUNDRIES AND POSITION OF
SETZM .OLKNS(B) ; LAST KNOWN NON-SPACE.
SETZM .OFLAG(B) ;CLEAR LINE MODE FLAGS
ADD A,WPLINE ;UPDATE LINE POINTER
AOS B
CAMG B,TRMLIN ;IF MORE LINES TO DO
JRST .ORST1 ; THEN LOOP.
RET
.OMSET: ;SET SCROLL AREA FLAGS
MOVE A,MLTLOR
MOVEI A,.OFLAG(A) ;POINT TO FIRST FLAG WORD
MOVN B,MLTDCT
HRL A,B ;MAKE AOBJN POINTER
MOVX B,%OMULT
ORM B,(A) ;SET THE FLAG
AOBJN A,.-1 ;LOOP TILL DONE
RET
.OUPDATE: ;UPDATE THE VISUAL-SCREEN AND REAL SCREEN
SKIPE OPTTTY ;IF NOT THE OPTIMIZER,
RET ; THEN NO OPTIMIZATION
PUSH P,A
PUSH P,B
MOVE A,TTYPE
MOVEM A,OPTTTY ;UPDATE THE TERMINAL TYPE
SKIPE .OCHNG ;IF THERE IS AN UPDATE TO DO,
JRST .OUP02 ; THEN GO TO IT
MOVE A,.ONLINE ; THEN MERELY
MOVE B,.ONCOL ; POSITION TO THE POINT
CALL $POSIT ; ON THE SCREEN.
SETZM OPTTTY ; RESTORE THE
POP P,B ; WORLD
POP P,A ; AND
RET ; RETURN TO CALLER.
.OUP02:
PUSH P,C
PUSH P,D
PUSH P,E
SETZM .OLBL ;LAST BLANK LINE
SETZM .OCC ;CURRENT COLUMN
SETZM .OSC ;SPACE COLUMN
SETZM .OCSC ;CHANGED SPACE COLUMN
MOVX A,%OFRCE ;FORCE NEW ATTRIBUTES OUT
IORM A,CATTR
SETZM FLDATR ;STOP DESTINATION INTERFERING
MOVE A,TRMLIN ;FIRST POSITION SHOULD START
AOS A ; WITH DIRECT CURSOR MOVEMENT
MOVEM A,.OVLINE ;(PROBLEMS WITH VT52 & VT100 SOMETIMES)
MOVEI A,1 ;STARTING WITH LINE 1
MOVEM A,.OCL ;CURRENT LINE
.OUP05:
CALL .OUP60 ;DEAL WITH UNCHANGED LINED
CALL .OUP10 ;UPDATE THIS LINE
AOS A,.OCL ; ADVANCING TO NEXT LINE
SETZM .ORGHT-1(A) ; INDICATING CHANGES ARE DONE
SETZM .OLEFT-1(A)
CAMG A,TRMLIN ; UNTIL ALL LINES SCANNED.
JRST .OUP05
SKIPLE A,.OLBL ;IF BLANK LINES AT BOTTOM
CALL .OUP07 ; DETERMINE FIRST LINE FOR CLEARING.
LDB A,.ONBP ;GET BYTE TO POSITION TO.
TRZ A,777 ; AND LEAVE ONLY ATTRIBUTES
MOVEM A,FLDATR ;SAVE HERE.
MOVEM A,.OATTR ;SAVE IN CURRENT SCREEN ATTRIBUTES
MOVE A,.ONLINE
MOVE B,.ONCOL
CALL .OUP90 ;POSITION TO CORRECT SPOT ON SCREEN
SETZM OPTTTY ;SET 'OPTIMIZE'
SETZM .OCHNG
POP P,E
POP P,D
POP P,C
POP P,B
POP P,A
RET
.OUP07: ;DETERMINE FIRST LINE FOR SCREEN BLANKING
;STARTING A .OLBL
SETZM CATTR ;NO NEED TO SET ATTRIBUTES NOW
SETZM FLDATR
CAIN A,1 ;IF AT LINE 1 THEN WHOLE SCREEN
JRST .OUP08
SOS A ;BACK UP ONE LINE
SKIPN .OLKNS(A) ;IF THIS IS A BLANK LINE
JRST .OUP07 ; THEN BACK UP AGAIN
AOS A ;PLACE A FIRST LINE TO BLANK
.OUP08:
MOVEI B,1 ;STARTING A COLUMN 1
CALL .OUP90 ; PLACE CURSOR
PJRST $CLEAR ; AND CLEAR SCREEN
.OUP10: ;FOR EACH LINE DO THE FOLLOWING. (LINE IN A)
MOVEM B,.ORC ;COLUMN TO STOP AT.
MOVE B,.OLEFT(A) ;GET COLUMN TO START AT.
MOVEM B,.OCC
SOS B ; BUT BE WARY OF ILDB
ADJBP B,.OLPTR(A) ;COMPUTE STARTING POINTER
MOVEM B,.OBP
SETOM .OLC ;LAST COLUMN OUTPUT.
SETZM .OSC ;NO SPACES SEEN YET.
SETZM .OCSC ;AND THUS NO CHANGED SPACES EITHER.
.OUP15: ;FOR EACH COLUMN
ILDB A,.OBP ;GET THE CHARACTER
CALL .OUP20 ; AND WORK ON IT
AOS B,.OCC ;UPDATE COLUMN COUNTER
CAMG B,.ORC ; AND IF NOT PAST LAST COLUMN
JRST .OUP15 ; THEN KEEP LOOPING.
MOVE A,.OCL ;GET THE
MOVE Z,.OLKNS(A) ; LAST KNOWN NON-SPACE FOR THE LINE
CAML Z,.OCC ;AND IF WE DID NOT LOOK THAT FAR
JRST [SKIPLE B,.OCSC ; AND IF WE HAVE SPACES TO
CALL .OUP30 ; OUTPUT, THEN DO IT
RET] ; AND FINISH.
SKIPG B,.OSC ;IF NO SPACES PASSED OVER AT END OF LINE
RET ; THEN WE ARE DONE.
SOS B ;SET TO LAST NON-SPACE
CALL .OUP17 ;SET B TO 0 IF BLANK LINE
MOVEM B,.OLKNS(A) ;SET POSITION OF LAST NON-SPACE.
CAMGE B,Z ;IF WE ARE BLANKING NON-SPACES
CALL [AOS B ; THEN
CAIN B,1 ; IF THIS IS A NEWLY BLANKED LINE
RET ; HOLD OFF UNTIL LATER
CALL .OUP90 ; ELSE
CALL $ERASE ; CLEAR TO END OF LINE
RET]
SOSG B ;IF THIS IS A BLANK LINE
SKIPE .OLBL ; AND IF THIS IS FIRST BLANK
SKIPA
MOVEM A,.OLBL ; LINE, THEN MARK IT.
RET
.OUP17: ;SET B TO 0 IF COMPLETELY BLANK LINE
PUSH P,Z
PUSH P,A
SETZ Z,
MOVE C,.OLPTR(A) ;GET THE POINTER TO FIRST CHARACTER
.OUP18:
ILDB A,C ;GET NEXT CHARACTER
CAIE A,SPACE ;IF NOT SPACE
JRST .OUP19 ; THEN WE ARE DONE
ADDI Z,1 ;COUNT CHARACTER POSITION
CAIE Z,(B) ;IF WE HAVE NOT REACHED THE END
JRST .OUP18 ; THEN LOOP UNTIL DONE
SETZ B, ;WE GOT THERE WITH ALL SPACES
.OUP19:
POP P,A
POP P,Z
RET
.OUP20: ;PROCESS EACH CHARACTER OF LINE
TXZE A,%OBLNK ;IF THIS IS A BLANKED CHARACTER
JRST [MOVEI A,SPACE+%OCHNG ; THEN TRANSFORM IT INTO
DPB A,.OBP ; A SPACE
JRST .+1]
MOVE B,A ;SAVE CHARACTER
TXZ B,%OCHNG ;REMOVE CHANGE FLAG IF SET.
CAIN B,SPACE ;IF THIS IS A PURE BLANK
JRST [MOVE B,.OCC ; THEN GET CURRENT COLUMN
SKIPN .OSC ;IF NO PREVIOUS SPACE PASSED OVER
MOVEM B,.OSC ; THEN THIS IS FIRST SPACE COLUMN
SKIPN .OCSC ;IF NO PREVIOUS CHANGED TO SPACE
TXNN A,%OCHNG ; OR THIS NOT A CHANGED TO SPACE
SKIPA ; THEN NOTHING TO DO
MOVEM B,.OCSC ; ELSE MARK AS FIRST CHANGED TO SPACE
RET]
;NOT A SPACE WITH NORMAL VIDEO
SKIPE .OLBL ;IF BLANK LINES PRECEEDED US,
CALL .OUP50 ; THEN CLEAR PRECEDING LINES
SKIPE B,.OCSC ;IF PASSED OVER CHANGED TO BLANKS
CALL .OUP30 ; THEN UPDATE THEM
TXZE A,%OCHNG ;IF CHARACTER HAS CHANGED
CALL .OUP40 ; THEN UPDATE IT.
SETZM .OCSC ;RESET SPACE INDICATORS
SETZM .OSC ;
RET ;ALL FOR THIS CHARACTER
.OUP30: ;OUTPUT PASSED OVER SPACES
PUSH P,A
PUSH P,.OBP ; SAVE THIS POINTER
PUSH P,.OCC ; AND CURRENT COLUMN.
MOVEM B,.OCC ;NEW CURRENT POSITION.
SOS B ; BACK UP FOR ILDB.
MOVE A,.OCL ;CURRENT LINE
ADJBP B,.OLPTR(A) ;POINTER TO THIS POSITION
MOVEM B,.OBP ; AND SET NEW TEMPORARY
.OUP35: ;FOR EACH SPACE TO BE PROCESSED
ILDB A,.OBP ;GET THE CHARACTER
TXZE A,%OCHNG ;IF WAS CHANGED TO SPACE
CALL .OUP40 ; OUTPUT IT.
AOS A,.OCC ;UPDATE COLUMN
CAMGE A,(P) ; AND IF NOT UP TO CURRENT NON-SPACE
JRST .OUP35 ; THEN KEEP LOOPING
POP P,.OCC ; ELSE RETORE CURRENT COLUMN
POP P,.OBP ; AND BYTE POINTER
POP P,A
RET ;AND RETURN.
.OUP40: ;OUTPUT EACH CHANGED CHARACTER
DPB A,.OBP ;DEPOSIT CHAR MINUS CHANGE BIT.
PUSH P,A ; AND SAVE CHARACTER.
ANDI A,(%REND) ;EXTRACT THE ATTRIBUTES
MOVEM A,FLDATR ;AND SAVE THEM FOR $POSIT
MOVE A,.OCL ;CURRENT LINE
MOVE B,.OCC ;CURRENT COLUMN
AOS .OLC ;LAST COLUMN OUTPUT FROM
CAME B,.OLC ;IF THIS IS NOT SEQUENTIAL
CALL .OUP90 ; THEN WE MUST POSITION
MOVEM B,.OLC ;NEW LAST CHARACTER.
MOVE B,FLDATR ;CHECK THE ATTRIBUTES
MOVE C,.OVLINE ;SEE IF THE LINE FLAGS ARE THE SAME
MOVE A,.OFLAG(C) ; AS THEY WERE LAST TIME
CAMN A,.OFG
CAME B,.OATTR ;IF IT IS DIFFERENT VIDEO
JRST [MOVEM B,.OATTR ; THEN UPDATE NEW ATTRIBUTES
MOVEM C,CURLIN ;USE THIS AS CURRENT LINE
CALL $SETATR ; THEN SET THESE ATTRIBUTES.
JRST .+1]
POP P,A ;RESTORE THE CHARACTER
ANDI A,177 ;ISOLATE JUST CHARACTER
CALL $SCHAR ;AND OUTPUT THE CHARACTER.
AOS .OVCOL ;OUTPUT COLUMN
RET
.OUP50: ;ERASE WHOLE PASSED OVER LINE
PUSH P,FLDATR ;DEFAULT TO NO ATTRIBUTES
SETZM FLDATR ; DURING CLEAR OPERATION
PUSH P,A ;SAVE A REGISTER
MOVE A,.OLBL ;GET LINE TO START AT
MOVEI B,1
.OUP51: ;FOR EACH LINE
CALL .OUP90 ;POSITION
CALL $ERASE ;ERASE
AOS A,.OLBL ;GET NEXT LINE
CAMGE A,.OCL ; AND NOT UP TO CURRENT LINE
JRST .OUP51 ; THEN DO NEXT TOO.
SETZM .OLBL
POP P,A ;RESTORE THE REGISTER
POP P,FLDATR
RET
.OUP60: ;SEE IF LINE IS UNCHANGED
SKIPE B,.ORGHT(A) ;IF ANY CHANGES ON THIS LINE
RET ; THEN RETURN TO DO UPDATE
AOS (P)
SKIPN .OLKNS(A) ;IF THIS IS A BLANK LINE
RET ; THEN PASS OVER IT,
SKIPE .OLBL ; ELSE IF NOT BLANK AND
CALL .OUP50 ; THERE ARE SAVED BLANK
RET ; LINES, CLEAR THEM.
.OUP90: ;POSITION TO NEW POINT ON THE LINE
PUSH P,A
PUSH P,B
MOVE C,.OVLINE ;GET OLD POSITION
MOVE D,.OVCOL
MOVEM A,.OVLINE ;UPDATE TO NEXT POSITION
MOVEM B,.OVCOL ;
MOVE E,D ;BUILD A BYTE POINTER
SOS E ; BACKED UP 1 FOR ILDB
ADJBP E,.OLPTR(C)
MOVEM E,.OOBP ; AND SAVE IT.
MOVE Z,[POINT 7,TMPBUF] ;INITIALIZE POINTER TO
MOVEM Z,TXTPTR ; TEMPORARY BUFFER.
MOVE E,OPTTTY
MOVE E,TRMDCA(E) ;COST OF CURSOR POSITIONING
CAME A,C ;IF NOT ON SAME LINE
JRST .OUP93 ; THEN HANDLE HERE
SUB D,B ;GET DIFFERENCE IN POSITION
JUMPG D,.OUP95 ;IF NEW TO LEFT OF OLD
MOVNS D ;MAKE POSITIVE
CAML D,E ;USE CURSOR POSITIONING
JRST .OUP95 ; IF CHEAPER OR SAME
.OUP92:
SKIPG D ;IF NOT GREATER (EQUAL)
JRST .OUP94 ; THEN OUTPUT ASCII STRING IF IT EXISTS
ILDB Z,.OOBP ;GET NEXT BYTE
CALL $TCHAR ;SEND CHARACTER TO STRING.
JRST .OUP95 ;MIXED ATTRIBUTES
SOJG D,.-3 ; ALREADY THERE
JRST .OUP94 ;WE ARE DONE.
.OUP93: ;NOT ON SAME LINE
MOVE Z,OPTTTY ;IF VT100 FAMILY
CAIL Z,%VT100
JRST [MOVE Z,.OFLAG(A) ; THEN SEE IF WE CAN USE LF'S
TXNE Z,%OMULT ;OK TO USE LF'S GOING INTO MULT SECT
JRST .+1
MOVE Z,.OFLAG(C) ;BUT NOT WHEN LEAVING A MULT SECT
TXNE Z,%OMULT
JRST .OUP95
JRST .+1]
SUB C,A ;FIND DIFFERENCE
JUMPG C,.OUP95 ;IF GREATER, THEN BACKWARDS
MOVNS C ;MAKE POSITIVE
SETZM .OCR ;CARRIAGE RETURN FLAG
CAMGE B,D ;IF OLD TO THE RIGHT
JRST [MOVEI D,1 ; THEN SET
MOVEM D,.OCR ; CARRIAGE RETURN FLAG
JRST .+1] ; AND POSITION TO 1.
MOVE F,D ; SAVE CURRENT POSITION
SUB D,B
MOVNS D ;MAKE POSITIVE
MOVE Z,D ;#POSITIONS TO MOVE
ADD Z,C ;# LINES TO GO DOWN
ADD Z,.OCR ;# CR TO USE (0,1)
CAML Z,E ;IF NOT LESS THAN POSITIONING
JRST .OUP95 ; THEN USE POSITIONING
MOVEI Z,CR ; ELSE
SKIPE .OCR ; IF CR
IDPB Z,TXTPTR ; THEN SEND ONE
MOVEI Z,LF ; AND SEND ALL
IDPB Z,TXTPTR ; THE LINE FEEDS
SOJG C,.-1 ; THAT ARE NECESSARY
MOVEI B,-1(F) ;GENERATE A BYTE POINTER
ADJBP B,.OLPTR(A)
MOVEM B,.OOBP ; THIS LOCATION.
MOVE B,.OVCOL ; AND INSURE SET UP CORRECTLY
JRST .OUP92 ; AND THEN POSITION BY HAND.
.OUP94: ;SEND BUILT UP STRING
SETZ A,
IDPB A,TXTPTR
MOVE A,[POINT 7,TMPBUF]
CALL $SASCIZ ; SEND THE STRING
JRST .OUP99
.OUP95:
MOVE C,FLDATR
MOVE D,.OFLAG(A) ;IF THIS IS A TALL OR WIDE LINE
TXNE D,%OTAL1!%OTAL2 ; THEN MAKE SURE THAT THE FIELD
TXO C,(%TALL) ; ATTRIBUTES INDICATE SOMETHING.
TXNE D,%OWIDE
TXO C,(%WIDE)
MOVEM C,FLDATR ; JUST IN CASE IT WAS LEFT OUT.
CALL $POSIT
.OUP99: ;COMMON RETURN FROM OPTIMIZER POSITIONING.
POP P,B
POP P,A
RET
$TCHAR: ;PUT CHARACTER INTO TMPBUF
PUSH P,Z ;SAVE THE CHARACTER
ANDI Z,777600 ;LEAVE ONLY THE ATTRIBUTES
CAME Z,.OATTR ;IF ATTRIBUTES NOT THE SAME
JRST [POP P,Z ; THEN RESTORE CHARACTER
RET] ; AND INFORM CALLER.
POP P,Z ;RESTORE THE CHARACTER
IDPB Z,TXTPTR ;DEPOSIT CHARACTER
JRST SKPRET ;AND GIVE SKIP RETURN
;;;;;;;;;;;;;;;;;
XLIST
IFN FT%V05,<
LIST
SUBTTL VT05 ROUTINES
; V T 0 5 SPECIFIC CODE $10XXX
$10DCC: ;HANDLE THE UP,DOWN,LEFT,RIGHT ARROWS
CAIG E,12 ;IF IT IS NOT ONE OF THESE
RET ; THEN SAVE TIME AND RETURN.
SETZ A, ; ELSE SET VT52 ESCAPE UP.
CAIN E,32 ;IF UP ARROW
MOVEI A,"A" ; THEN INDICATE IT.
CAIN E,13 ;IF DOWN ARROW
MOVEI A,"B" ; THEN....
CAIN E,30 ;IF RIGHT ARROW
MOVEI A,"C" ; THEN....
CAIN E,10 ;IF LEFT ARROW
MOVEI A,"D" ; THEN....
SKIPN A ;IF NOT ANY OF THESE
RET ; THEN FINISHED
MOVEM A,ECHAR ; ELSE SET UP THE ESCAPE
MOVEI E,ESC ; AND TELL CALLER IT WAS AN ESCAPE.
RET
$10ESC: ;VT05
SKIPE A,ECHAR ;IF CHARACTR ALREADY SET
RET ; LEAVE IT ALONE
CALL $RDCHAR ;GET NEXT CHARACTER
MOVEM A,ECHAR ;SAVE THE CHARACTER
RET
$10ERS: ;VT05 (CTRL-^)
MOVEI A,36
PJRST $SCHAR
$10CLR: ;VT05 (CTRL-_)
MOVEI A,37
PJRST $SCHAR
$10HOM: ;VT05 (CTRL-])
MOVEI A,35
PJRST $SCHAR
$10BCU: ;VT05 (CTRL-H)
MOVEI A,BACKSP
PJRST $SCHAR
$10POS: ;VT05 (C-N LINE+37 COL+37)
ADDI A," "-1 ;CREATE LINE NUMBER
ADDI B," "-1 ;CREATE COL NUMBER
PUSH P,A ;SAVE LINE
MOVEI A,16 ;DIRECT CURSOR PLACEMENT
CALL $SCHAR
POP P,A ;RESTORE LINE
CALL $SCHAR
MOVE A,B ;COL
PJRST $SCHAR
$10ATR: ;VT05 HAS NO SCREEN ATTRIBUTES
SETZM FLDATR
SETZM CATTR
RET
$10SCU:
RET
$10SCD:
RET
$10CRT:
RET
XLIST
>
IFN FT%V50+FT%V52,<
LIST
SUBTTL VT52 ROUTINES
; V T 5 2 ROUTINES $20XXX
%LASTCOL=^D80 ; LAST COLUMN DIRECTLY ADDRESSABLE.
$20ESC: ;VT52
CALL $RDCHAR ;GET NEXT CHARACTER
MOVEM A,ECHAR ;SAVE THE CHARACTER
RET
$20ERS: ;VT52 (ESC K)
HRROI A,[BYTE(7) ESC,"K",0,0,0]
PJRST $SASCIZ
$20CLR: ;VT52 (ESC J)
HRROI A,[BYTE (7)ESC,"J",0,0,0]
PJRST $SASCIZ
$20HOM: ;VT52 (ESC H)
HRROI A,[BYTE (7)ESC,"H",0,0,0]
PJRST $SASCIZ
$20BCU: ;VT52 (ESC D)
HRROI A,[BYTE (7)ESC,"D",0,0,0]
PJRST $SASCIZ
$20POS: ;VT52 (ESC Y LINE+37 COL+37)
ADDI A," "-1 ;CREATE LINE NUMBER.
PUSH P,B ; SAVE COLUMN NUMBER
CAILE B,%LASTCOL ; IF THIS CANNOT BE ADDRESSEED
MOVEI B,%LASTCOL ; THEN MAKE IT SO.
ADDI B," "-1 ;CREATE COLUMN NUMBER.
PUSH P,A ;SAVE LINE NUMBER
MOVEI A,ESC ;SEND OUT THE ESCAPE
CALL $SCHAR ; AND SEND OUT THE ESCAPE.
MOVEI A,"Y" ;DIRECT ADDRESSING COMMAND
CALL $SCHAR ;
POP P,A ;RESTORE THE LINE NUMBER
CALL $SCHAR ; AND SEND IT OUT
MOVEI A,(B) ;RESTORE THE COLUMN NUMBER
CALL $SCHAR ; AND SEND IT OUT.
POP P,B ; RESTORE COLUMN+37
CAIG B,%LASTCOL ; IF COL WAS ADDRESSABLE
RET
SUBI B,%LASTCOL ; ELSE PREPARE TO MOVE
$21POS: ; CURSOR BY HAND.
MOVEI A,ESC ; USE [ESCAPE C] FOR RIGHT SHIFT
CALL $SCHAR
MOVEI A,"C"
CALL $SCHAR
SOJG B,$21POS ; LOOP UNTIL MOVED
RET
$20ATR: ;VT50 AND VT52 HAVE NO SCREEN ATTRIBUTES
SETZM FLDATR
SETZM CATTR
RET
$20SCU:
RET
$20SCD:
RET
$20CRT: ;CURSOR RIGHT
HRROI A,[BYTE (7)ESC,"C",0,0,0]
PJRST $SASCIZ
XLIST
>
IFN FT%V10,<
LIST
SUBTTL VT100 ROUTINES
; V T 1 0 0 ROUTINES $30XXX
$30ESC: ;VT100
CALL $RDCHAR ;GET NEXT CHARACTER
CAIE A,"[" ;IF IT IS A BRACKET
CAIN A,"O" ; OR AN "O"
CALL $RDCHAR ; THEN JUST READ THE NEXT CHARACTER
MOVEM A,ECHAR
RET ;ELSE LET INVALID MSG GO OUT.
$30ERS: ;VT100 (ESC [ K)
HRROI A,[BYTE(7)ESC,"[","K",0,0]
CALL $SASCIZ
PJRST $30RAT ;RESET ATTRIBUTES
$30CLR: ;VT100 (ESC [ J)
HRROI A,[BYTE(7)ESC,"[","J",0,0]
CALL $SASCIZ
PJRST $30RAT ;RESET ATTRIBUTES
$30HOM: ;VT100 (ESC [ H)
HRROI A,[BYTE(7)ESC,"[","H",0,0]
PJRST $SASCIZ
$30BCU: ;VT100 (ESC [ 1 D)
HRROI A,[BYTE (7)ESC,"[","D",0,0]
PJRST $SASCIZ
$30POS: ;VT100 (ESC [ LINE ; COL H)
PUSH P,B ;SAVE COL
MOVEM A,CURLIN ; LINE NUMBER
;
;The next piece of code is here to avoid a VT100 microcode bug.
;If the cursor is currently in a TALL or WIDE field and is being
;moved to a field which is not TALL or WIDE and has a column
;number greater than 40, then the cursor will be left at column
;40. This is not apparent when the VT100 is in Local mode.
;
CAIGE B,^D40 ;MOVING TO A PROBLEM COLUMN
JRST $31POS ; NO - CONTINUE
MOVEI A,(%TALL!%WIDE) ;SEE IF LINE WAS TALL OR WIDE
TDNE A,CATTR
TDNE A,FLDATR ;AND NEW ONE IS NEITHER
JRST $31POS ; NO - OK
HRROI A,[BYTE (7)ESC,"[",0,0,0]
CALL $SASCIZ ;FIRST POSITION TO START OF NEXT LINE
MOVE A,CURLIN
CALL $SCNUM
HRROI A,[BYTE (7)";","1","H",0,0]
CALL $SASCIZ
$31POS:
;
;End of special code.
;
HRROI A,[BYTE (7)ESC,"[",0,0,0]
CALL $SASCIZ
MOVE A,CURLIN ;GET LINE NUMBER
CALL $SCNUM ;CONVERT TO ASCII AND OUTPUT
CALL $SCSC ;OUTPUT THE ";"
POP P,A ;GET COLUMN NUMBER
CALL $SCNUM ;CONVERT TO ASCII AND OUTPUT
MOVEI A,"H"
PJRST $SCHAR ;OUTPUT THE "H"
$30ATR: ;CHARACTER ATTRIBUTE ROUTINES
MOVE B,CATTR ;GET THE CURRENT STUFF
TXZ B,(%TALL!%WIDE!%GRAPH) ;DON'T TEST BIG ATTRIBUTES YET
MOVE C,FLDATR
TXZ C,(%TALL!%WIDE!%GRAPH) ;SAME FOR ACTUAL ATTRIBUTES
CAMN B,C ;IF THE SAME AS NEW STUFF
JRST $33ATR ; THEN WHY BOTHER
AND B,C ;WE KNOW NOT THE SAME, THUS
MOVE C,[POINT 7,TMPBUF,13] ;PREPARE STRING TO SEND TO
MOVEM C,TXTPTR ; TERMINAL.
MOVE C,[BYTE(7)ESC,"[",0,0,0]
MOVEM C,TMPBUF
PUSH P,D ; SAVE A REGISTER
MOVE C,CATTR ;SEE IF ANY ATTRIBUTES
TXZ C,(%TALL!%WIDE!%GRAPH) ; HAVE BEEN TURNED OFF
CAMN B,C ; SINCE LAST TIME
JRST [MOVEI C,(%REND) ; THEN DETERMINE WHICH NEW
XOR C,CATTR ; HAVE BEEN ADDED.
AND C,FLDATR ; WITH COMPLEMENT AND.
JRST $31ATR] ;
MOVEI D,";" ;CAUSE ATTRIBUTES TO BE RESET
IDPB D,TXTPTR ;(ALLOW VT100 TO DEFAULT)
SKIPN C,FLDATR ;IF ATTRIBUTES WERE CLEARED
JRST $32ATR ; THEN FINISH UP.
$31ATR:
MOVEI D,"7" ;REVERSE VIDEO COMMAND
TXNE C,(%RVRS) ;IF REVERSE VIDEO
CALL $30SAT ; PUT IN STRING
MOVEI D,"5" ; BLINK COMMAND
TXNE C,(%BLNK)
CALL $30SAT ; PUT IN STRING
MOVEI D,"4" ;UNDERLINE COMMAND
TXNE C,(%UNDR) ;IF UNDERLINED VIDEO
CALL $30SAT ; PUT IN STRING
MOVEI D,"1" ;BOLD COMMAND
TXNE C,(%BOLD)
CALL $30SAT ; PUT IN STRING
$32ATR:
MOVEI C,"m" ; LOWERCASE "M" AS TERMINATOR
DPB C,TXTPTR ; IS PUT IN STRING
SETZ C, ; FOLLOWED BY A NULL
IDPB C,TXTPTR
MOVE A,[POINT 7,TMPBUF]
CALL $SASCIZ ;OUTPUT THE STRING
POP P,D
$33ATR:
MOVE A,FLDATR ;SAVE THE NEW ATTRIBUTES AND
MOVE B,CATTR ;SHOULD WE SWITCH TO OR FROM GRAPHICS ?
TXNN A,(%GRAPH)
JRST [TXNN B,(%GRAPH) ;SWITCH OFF - WAS IT ON?
JRST $34ATR ; NO
MOVEI A,"O"-"@"
CALL $SCHAR ;DO IT
JRST $34ATR]
TXNE B,(%GRAPH) ;SWITCH ON - WAS IT OFF?
JRST $34ATR ; NO
MOVEI A,"N"-"@"
CALL $SCHAR ;DO IT
$34ATR:
MOVE A,FLDATR ;GET FIELD ATTRIBUTES
MOVEM A,CATTR ; SEE IF THIS IS A TALL
TXNN A,(%TALL!%WIDE) ; OR WIDE FIELD
JRST $36ATR ; DONE IF NOT
MOVE C,CURLIN ;YES - GET THE LINE NUMBER
SKIPN C,.OFLAG(C) ; AND THE LINE MODE FLAGS
CALL $00STW ; GO AND SET THEM IF STILL CLEAR
TXZE C,%OLCLR ;IF THE LINE IS BEING CLEARED
JRST [MOVE B,C ;COPY THE FLAGS
CALL $00STW ;GET THE NEW ONES
TXZ B,%OLSET
CAIN B,(C) ;IF THEY ARE THE SAME
JRST $35ATR ; THEN DONE
JRST .+1] ;CLEAR IT BY RESETTING IT
TXNE C,%OLSET ;IF THE LINE IS ALREADY SET
JRST [MOVEM C,.OFG ;SAVE NEW FLAGS
RET]
HRROI A,[BYTE (7)ESC,"#",0,0,0]
CALL $SASCIZ ;SEND THE STRING
TXNE C,%OTAL1 ;TOP HALF OF TALL?
MOVEI A,"3" ; YES
TXNE C,%OTAL2 ;BOTTOM HALF OF TALL?
MOVEI A,"4"
TXNE C,%OWIDE ;OR WIDE?
MOVEI A,"6"
CALL $SCHAR
$35ATR:
MOVE B,CURLIN ;NOW RESET THE FLAGS
TXO C,%OLSET
MOVEM C,.OFLAG(B)
MOVEM C,.OFG ;SAVE NEW LINE FLAGS
RET
$36ATR:
MOVE A,CURLIN
MOVE B,.OFLAG(A) ;SEE IF TALL/WIDE BEING CLEARED
TXNN B,%OLCLR
RET ; NO
SETZM .OFLAG(A) ;CLEAR THE FLAGS NOW
HRROI A,[BYTE (7)ESC,"#","5",0,0]
PJRST $SASCIZ ;YES - CLEAR THE LINE
$30RAT: ;RESET THE TERMINAL ATTRIBUTES
SKIPN CATTR ;IS ALREADY RESET
RET ; DONE
HRROI A,[BYTE (7)ESC,"[","m",0,0]
SETZM CATTR
PJRST $SASCIZ ;THEN RESET THEM
$30SAT: ;OUTPUT CHAR FOLLOWED BY SMI-COLON
IDPB D,TXTPTR
MOVEI D,";"
IDPB D,TXTPTR ;ADD A SEMI-COLON
RET
$30SCU:
SETOM MWTALL ;WRITE ALL CHARACTERS CHANGED
CALL $SCESC ;ESCAPE
MOVEI A,"D"
CALL $SCHAR ;SCROLL UP
PJRST $00SCU ;UPDATE THE OPTIMISER
$30SCD:
SETOM MWTALL ;WRITE ALL CHARACTERS CHANGED
MOVE A,MLTLOR ;POINT TO TOP OF AREA
MOVEI B,1
CALL $POSIT ;TO MAKE SCROLL DOWN WORK
CALL $SCESC ;ESCAPE
MOVEI A,"M"
CALL $SCHAR ;SCROLL DOWN
PJRST $00SCD ;UPDATE THE OPTIMISER
$30CRT: ;CURSOR RIGHT
HRROI A,[BYTE (7)ESC,"[","C",0,0]
PJRST $SASCIZ
XLIST
>
LIST
SUBTTL TERMINAL CONTROL ROUTINES
$RDCHAR:
MOVE A,TTJFN
SETZ B, ;IN CASE OF CONTROL-C
BIN
JUMPE B,.-1 ;IGNORE NULLS
MOVEI A,(B) ;COPY THE CHARACTER
CAIN A,RUBOUT ;IF THIS IS A RUBOUT
MOVEI A,BACKSP ;THEN MAKE IT A BACKSPACE.
CAIE A,CR ;CR COMES IN AS CR-LF
JRST $RDC.1 ; SKIP IF OK
CALL $RDCHAR ;ELSE GET THE LF
MOVEI A,CR ;AND FORCE CR
$RDC.1:
SKIPE .TMOPT ;IF OPTIMISER IS ON
CALL $00RCH ; THEN SAVE THE CHARACTER
RET ;RETURN WITH CHAR IN 'A'.
$CLIBF:
MOVE A,TTJFN ;CLEAR THE TERMINAL INPUT
CFIBF ; BUFFER.
RET
ECOON:
PUSH P,A
PUSH P,B
MOVE A,TTJFN
RFMOD
TXO B,TT%ECO
SFMOD
POP P,B
POP P,A
SETZM .OECHO ;CLEAR ECHO FLAG
RET
ECOOFF:
PUSH P,A
PUSH P,B
MOVE A,TTJFN
RFMOD
TXZ B,TT%ECO
SFMOD
POP P,B
POP P,A
SETOM .OECHO ;SET NO-ECHO FLAG
RET
$TTCHK: ;CHECK THE STATUS OF THE TERMINAL ON EACH CALL
SKIPN TTOPN ;IF TERMINAL IS NOT OPEN DO IT.
CALL $TTOPN
PJRST $TTSET ;AT ANY RATE, RESET THEM.
$TTOPN:
SKIPE TTOPN ;IF TTY IS OPEN
RET ; THEN FORGET IT.
SKIPN INIFLG ;IF THIS IS FIRST TIME INIT
CALL $ONCE ; THEN DO IT
CALL $SBEGIN ;ENSURE THAT BUFFER IS SET UP
CALL $TTSET ;SETUP THE TERMINAL CHARACTERISTICS.
MOVE A,TTYPE ;COPY THE TERMINAL TYPE
MOVEM A,OPTTTY
SKIPN INIFLG
CALL $ONCE2 ;SEE IF VT100 WITH AVO (132 ALLOWED)
SETOM TTOPN ;INDICATE TERMINAL NOT OPEN.
SETOM FLDTYP ;FORCE NEW ATTRIBUTES OUT FIRST TIME
PJRST .OINIT ;THEN CLEAR OPTIMISER AS WELL
$TTSTR: ;SET IT UP
SKIPN TTOPN ;IF TERMINAL OPEN THEN DONE THIS
RET
MOVE A,TTYPE
CAIGE A,%VT100
RET
CALL $SEND ;DO OPTIMISED UPDATE IF REQUIRED
MOVE A,TTYPE
PUSH P,OPTTTY ;SAVE OPTIMISER STATE FOR NOW
MOVEM A,OPTTTY ;AND FAKE IT TO REAL TYPE
SKIPN MLTHIR ;OK IF NO MULT-SECTION
JRST [HRROI A,[BYTE (7)ESC,"[","1",";","2","4","r",0,0,0]
CALL $SASCIZ ;SET TO NORMAL SCROLL JUST IN CASE
JRST $TTST1]
CALL $SCESC ;ESCAPE
MOVEI A,"["
CALL $SCHAR ;SEND THIS
MOVE A,MLTLOR ;FIRST ROW NUMBER
CALL $SCNUM ;CONVERT OUT
CALL $SCSC ;SEND ";"
MOVE A,MLTHIR ;LAST ROW
CALL $SCNUM ;CONVERT OUT
MOVEI A,"r" ;THIS SAYS IT ALL
CALL $SCHAR
$TTST1:
;
;The following message is sent because of a VT100 microcode bug. If the
;cursor is positioned to the last column on the screen and the field
;attributes are then set, the next character typed by the operator will
;appear on the next line if the terminal is in AUTOWRAP mode. The fix is
;to switch off AUTOWRAP.
;
HRROI A,[BYTE (7)ESC,"[","?","7","l",0,0,0,0,0]
CALL $SASCIZ ;SWITCH OFF AUTOWRAP
SKIPE NEWRND ;DO CHAR. SET ONLY IF WANTED
JRST $TTST2 ;FORCE EVERYTHING SO FAR
CALL $SCESC ;ESCAPE
MOVEI A,"("
CALL $SCHAR ;SEND IT
MOVE A,CHARST ;GET CHAR SET
MOVE A,["B" ;US
"A" ;UK
"0" ;GRAPHIC
"1"](A) ;ALTERNATE
CALL $SCHAR ;SEND IT
HRROI A,[BYTE (7)ESC,")","0",0,0]
CALL $SASCIZ ;G1 CHARACTER SET IS GRAPHICS
$TTST2:
CALL $SEND ;MAKE SURE IT GOES
POP P,OPTTTY ;RESTORE OPTIMISER STATE
RET
$TTSET: ;SET THE TERMINAL MODES
SKIPE DORESET ;IF FORCED RESET, DO IT.
CALL $TTRST ;BUT IF IT HAS, MAKE SURE TO RESET.
CALL DOATI ;TURN ON THE INTERRUPT SYSTEM
SETZM LWRCAS ;ALWAYS ASSUME UPPERCASE WANTED
MOVE B,NEWMOD
CALL $TTCAS ;SET UPPER CASE
DMOVE B,$.BYTE ;ALSO INSURE CONTROL CHARS ARE NOT
SFCOC ;ECHOED.
RET
$TTCAS: ;SET CASE FOR TERMINAL
MOVE A,TTJFN ;USE PRIMARY JFN
STPAR ;TO SET THE PROPER CONTROLS
SKIPE BRK128 ;IF THE 128 BREAK IS IN USE
TXO B,TT%IGN ;THEN USE MASK ONLY FOR WAKE-UP
SFMOD
RET
DOATI:
SKIPE INTSET ;ARE INTERRUPTS SETUP ?
RET ;YES
SETOM INTSET ;SET UP
SETZM DORESET ;DON'T FORCE RESET
MOVE A,TTJFN
SKIPE OLDCC ;DON'T TRAP CONTROL-C UNLESS WE HAVE TO
CAIE A,.PRIOU ;IF THIS IS THE COMMAND TERMINAL
RET
MOVSI B,(1B<.TICCC>) ;THEN SET STIW WORD
;AND FALL INTO DOSTIW
DOSTIW: ;SET STIW WORD
PUSH P,OLDCC ;SAVE THE OLD ^C STATUS
PUSH P,B ;SAVE THE MASK
SETOM OLDCC ;SET TO ENABLE
CALL $CTRLC ;AND DO IT
MOVEI A,.FHSLF
POP P,B
STIW
POP P,OLDCC ;NOW DO IT PROPERLY
;AND FALL INTO $CTRLC
$CTRLC: ;SET CONTROL-C ENABLE
MOVEI A,.FHSLF
RPCAP ;GET PROCESS CAPABILITIES
TXZ C,SC%CTC ;ASSUME WE DON'T WANT IT
SKIPE OLDCC
TXO C,SC%CTC ;AND SET IT IF WE DO
EPCAP
RET
$TTRST: ;RESET THE TERMINAL MODES
SKIPN TTOPN ;IF THE TERMINAL IS NOT OPEN
RET ; THEN NO NEED TO RESET.
MOVE A,TTJFN
MOVE B,OLDMOD ;RESTORE OLD MODE WORD
STPAR
SFMOD
DMOVE B,COC ;RESTORE THE OLD CHARACTERISTICS
SFCOC
SETZM INTSET ;CLEAR INTERRUPT SET FLAG.
CAIE A,.PRIOU ;IF COMMAND TERMINAL
RET
MOVE B,STWORD ;RESET STATUS
PJRST DOSTIW ;AND RETURN
$ONCE: ;ONCE-ONLY CODE FOR INITIALISATION
CALL $GETLN ;GET TERMINAL LINE
CALL $GETLC ;AND CHARACTERISTICS
CALL OPTMEM ;GET OPTIMIZER MEMORY
JFCL ; ASSUME IT WAS OK
MOVE A,TTJFN ;SAVE MODE WORD FOR TERMINAL
RFMOD
MOVEM B,OLDMOD
RFCOC ;SAVE COC FLAGS
DMOVEM B,COC
CAIE A,.PRIOU ;IF COMMAND TERMINAL
RET
MOVEI A,.FHSLF ;THEN GET THE STATUS WORD FOR THE JOB
RTIW
MOVEM B,STWORD ;AND SAVE IT
RET
$ONCE2: ;SECOND PART OF INIT CODE
SETOM INIFLG ;ALMOST DONE
MOVE A,TTYPE
CAIE A,%VT100 ;IF IT IS A VT100
RET
SETZM V132FG ;NOT IN 132 COLUMN MODE YET THOUGH
CALL ECOOFF ;DON'T ECHO THE TERMINAL RESPONSE
MOVE A,TTJFN ;THEN SEE IF IT HAS AVO
MOVE B,[POINT 7,[BYTE (7)ESC,"<",ESC,"[","c",0,0,0,0,0]]
SETZ C,
SOUT
ERJMP .+1
MOVE B,[POINT 7,STRBUF] ;GET THE RESPONSE
MOVEI C,7
MOVEI D,"C" ;TERMINATE ON 7 CHARACTERS OR 'C'
SIN
ERJMP .+1
CALL ECOON ;SWITCH ECHOS ON AGAIN
LDB A,[POINT 7,STRBUF+1,6] ;GET THE MODE CHARACTER
CAIN A,ZERO ;'0' = BASIC VT100
JRST ONC.1
CAILE A,"1" ;'2','3','5','6','7' = AVO
CAIN A,"4"
JRST ONC.1
SETOM AVOFLG ;VT100 HAS AVO INSTALLED
RET
ONC.1:
MOVE A,TRMATR ;NO AVO AVAILABLE
TXZ A,%BOLD+%BLNK ;THEREFORE NO BOLD OR BLINKING
MOVEM A,TRMATR
RET
$GETLN: ;SEARCH FOR A LOGICAL NAME
MOVEI A,.PRIOU ;DEFAULT TO CONTROLING TERMINAL
MOVEM A,TTJFN
MOVE E,[-NUMTRM,,TRMLOG] ;POINT TO THE TABLE OF NAMES
SKIPN A,LOGNAM ;IF NAME GIVEN IN TFRSTA - USE IT
GLN.1:
HRRO A,(E) ;POINT TO NEXT TERMINAL NAME
STDEV ;AND SEE IF ITS THERE
JRST GLN.2 ;NO - LOOP
HLRZ C,B ;COPY THE DEVICE TYPE
CAIE C,.DVDES+.DVTTY ;IF NOT A TERMINAL
JRST GLN.2 ; THEN TRY NEXT ONE
MOVEM B,TRMDES ;SAVE THE DESIGNATOR
HRROI A,TRMNAM ;OK - POINT TO NAME AREA
DEVST
ERJMP GLN.2 ;NOT AVAILABLE - TRY ANOTHER
MOVEI C,":" ;APPEND A COLON
IDPB C,A
MOVE A,B ;COPY THE JFN
ASND ;AND ASSIGN THE DEVICE
ERJMP GLN.2 ;CAN'T - TRY ANOTHER
MOVE A,[GJ%OLD+GJ%PHY] ;GET A JFN FOR THE DEVICE
HRROI B,TRMNAM
GTJFN
ERJMP GLN.2 ;NO GOOD - TRY ANOTHER
MOVEM A,TTJFN ;GOT IT AT LAST
MOVE B,[OF%RD+OF%WR+7B5] ;OPEN FOR I/O
OPENF
ERJMP [MOVEI A,.PRIOU ;FAILED - RESET TO DEFAULT
MOVEM A,TTJFN
JRST GLN.2] ;AND TRY AGAIN
RET
GLN.2:
AOBJN E,GLN.1 ;LOOP FOR MORE
RET
$GETLC: ;GET TERMINAL CHARACTERISTICS
MOVE A,TTJFN
GTTYP ;GET THE TERMINAL TYPE
SETZ A,
CAIN B,.TTV05
MOVEI A,%VT05 ;TERMINAL IS A VT05
CAIN B,.TTV50
MOVEI A,%VT50H ;TERMINAL IS A VT50H
CAIN B,.TTV52
MOVEI A,%VT52 ;TERMINAL IS A VT52
CAIN B,.TT100
MOVEI A,%VT100 ;TERMINAL IS A VT100
CAIN B,.TT125
MOVEI A,%VT100 ;VT125 IS THE SAME AS VT100 HERE
SKIPN A ;IF STILL NOT SET
MOVE A,TTYPE ; USE CURRENT TYPE
MOVE B,TRMLC(A) ;GET LINE AND COLUMNS ALLOWED
HRRZM B,TRMCOL
HLRZM B,TRMLIN
MOVE B,[0 ;VT05
0 ;VT50H
0 ;VT52
%REND]-1(A) ;VT100 ATTRIBUTES
MOVEM B,TRMATR ;SAVE FOR LATER USE
MOVEM A,TTYPE ;SAVE THE TYPE
RET
$CLRLN: ;CLEAR A LINE OFF THE SCREEN
MOVEI B,1 ;COLUMN 1
CALL $POSIT ;GO TO IT
PJRST $ERASE ;NOW DO IT
$TTCLS:
MOVE A,TTYPE
MOVEM A,OPTTTY ;USE THE REAL TERMINAL
CALL $SCLEAR ;CLEAR TERMINAL FIRST
CALL RSTCOL ;RESET TO 80 COLUMN MODE (IF VT132)
MOVE A,TTYPE
CAIGE A,%VT100 ;IF THIS IS A VT100, THEN...
JRST TCL.1
HRROI A,[BYTE (7)ESC,"[","1",";","2","4","r",0,0,0]
SKIPE MLTNMF ;IF THERE WAS A MULTIPLE SECTION
CALL $SASCIZ ; THEN RESET THE SCROLL AREA
HRROI A,[BYTE (7)ESC,"(","B",ESC,")","B",ESC,"[","m",0]
CALL $SASCIZ ;RESET CHAR SET AND ATTRIBUTES
TCL.1:
CALL $SEND ;MAKE SURE BUFFER IS OUT
CALL $TTRST ;RESET THE TERMINAL
SETZM TTOPN ;CLEAR OPEN FLAG
RET
$.BYTE:
BYTE(2)0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
BYTE(2)0,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0
NEWMOD: TT%LCA+TT%WKF+TT%WKN+TT%WKP+3B29+TT%WKA+TT%ECO+TT%PGM+TT%LIC
NLCMOD: TT%LCA+TT%WKF+TT%WKN+TT%WKP+3B29+TT%WKA+TT%ECO+TT%PGM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; TERMINAL OUTPUT ROUTINES
;
; $SBEGIN -- INITIALIZE OUTPUT BUFFER (NO AC'S)
; $SEND -- SEND OUTPUT BUFFER AND INITIALIZE (NO AC'S)
; $SCHKPNT-- SEND OUT BUFFER IF NEARING FULL STATUS
; $SCHAR -- PUT ONE CHARACTER IN OUTPUT BUFFER
; $SMCHAR -- PUT CHAR IN 'A' INTO OUTPUT BUFFER 'C' TIMES
; $SSTRING-- POINTER IN 'B', LENGTH IN 'C'.
; $SASCIZ -- SEND ASCIZ STRING WITH TERMINATING 0.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
$SBEGIN: ;INITIALIZE OUTPUT BUFFER
SETZM $SNUM ;NOTHING IN BUFFER.
MOVE A,$SBUFPT ;INITIALIZED BUFFER POINTER
MOVEM A,$SBPTR ;AND SET UP DYNAMIC ONE.
RET
$SEND: ;SEND OUT THE BUFFER
SKIPE .TMOPT ;IF OPTIMISER IS ON
CALL .OUPDATE ; THEN UPDATE THE SCREEN
SKIPG A,$SNUM ;IF NOTHING TO SEND THEN
RET ; THEN DO NOT SEND IT.
PUSH P,B
PUSH P,C
CAMLE A,MAXOUT ;IF THIS IS LONGEST OUTPUT STRING YET
MOVEM A,MAXOUT ; THEN SAVE IT FOR STATISTICS.
ADDM A,TOTOUT ;UPDATE OUTPUT TOTAL.
AOS NUMOUT ;COUNT NUMBER OF OUTPUTS
SETZ A, ;INDICATE END OF STRING
IDPB A,$SBPTR ; WITH NULL BYTE
MOVE A,TTJFN
MOVE B,$SBUFPNT ;GET POINTER TO BUFFER.
SETZ C, ;ASSUME ASCIZ
SOUT
ERJMP .+1
POP P,C
POP P,B
PJRST $SBEGIN ;RE-INITIALIZE
$SCHKPNT: ;SEND OUT BUFFER IF GETTING TOWARD END.
PUSH P,A ;SAVE REGISTER
MOVE A,$SNUM ;GET CHARACTERS IN BUFFER COUNT.
CAIL A,$SBUFSND ;IF MORE THAN SPECIFIED AMOUNT
CALL $SEND ; THEN CALL SEND NOW.
POP P,A ;RESTORE A.
RET
$SCESC:
MOVEI A,ESC ;COMMON ROUTINE FOR ESCAPE
SKIPA
$SCSC:
MOVEI A,";" ;SEND A ";"
$SCHAR: ;SEND THE CHARACTER IN 'A'
SKIPG A ;IF NULL CHARACTER THEN
RET ; FORGET IT.
SKIPE .TMOPT ;IF OPTIMISING
SKIPE OPTTTY ; AND ITS ON
SKIPA
JRST $00SCH ; THEN DO IT THAT WAY
IDPB A,$SBPTR ;DEPOSIT CHARACTER
PUSH P,A ;BE VERY CONSERVATIVE ABOUT HAVING
AOS A,$SNUM ;TOO MANY CHARACTERS IN BUFFER
CAIL A,$SBUFMAX ; AND IF THERE ARE
JRST [AOS OVRFLOW ; THEN COUNT OVERFLOWS
CALL $SEND ; SEND OUT THE BUFFER
JRST .+1] ; AND CONTINUE.
POP P,A
RET
$SSTRING: ;SEND STRING IN 'B' WHICH IS C CHARACTERS LONG
SKIPG C ;IF NO CHARACTERS IN STRING
RET ; THEN PUT NONE IN BUFFER
ILDB A,B ;GET NEXT CHARACTER
CALL $SCHAR ;SEND ONE CHARACTER
SOJG C,.-2 ;SPIN UNTIL DONE.
RET ; AND RETURN.
$SASCIZ: ;SEND OUT THE STRING IN 'A'
PUSH P,B ;SAVE B
MOVE B,A ; AND PUT THE POINTER THERE
HLR A,A ;IF THE LEFT SIDE IS A -1
CAMN A,[-1] ; THEN
HRLI B,(POINT 7,) ;BUILD GOOD BYTE POINTER
$SAS10:
ILDB A,B ;GET THE NEXT BYTE
JUMPE A,$SAS40 ; AND JUMP IF NULL
CALL $SCHAR ;DUMP IN THE CHARACTER
JRST $SAS10 ;SPIN UNTIL DONE
$SAS40: POP P,B ;RESTORE AND
RET ;EXIT
$SMCHAR: ;SEND CHARACTER IN 'A' 'C' TIMES
SKIPG C ;IF THERE ARE NO CHARACTERS
RET ; THEN QUIT
SKIPE .TMOPT ;IF OPTIMISING
SKIPE OPTTTY ; AND ITS ON
SKIPA
JRST $00SMC ; THEN DO IT THAT WAY
CALL $SCHAR ;SEND OUT THE CHARACTER IN 'A'
SOJG C,.-1 ; SPIN UNTIL ALL DONE.
RET ;RETURN
$SCNUM: ;CONVERT NUMBER IN B TO DECIMAL
IDIVI A,^D10 ;REMOVE UNITS
PUSH P,B ; AND SAVE THEM
SKIPE A ;IF MORE TO GO
CALL $SCNUM ; THEN CONTINUE RECURSIVELY
POP P,A ;GET THE NEXT DIGIT
ADDI A,ZERO ;CONVERT TO ASCII
PJRST $SCHAR ; AND SEND IT
SUBTTL GETFIL - GET AND OPEN INPUT DATA FILE
GETFIL:
HRRZ A,INT.B
MOVE B,[POINT 7,INTBUF] ;NO - CONVERTED IN INTBUF
DMOVE D,[130 ;LENGTH OF INT.BUF.
POINT 7,FRMFIL]
EXTEND A,[MOVSLJ
SPACE] ;FILL WITH SPACES
JRST GTF.1 ;FILE NAME TOO LONG
SKIPN A,DATJFN ;SKIP IF FILE OPEN
JRST GTF.0 ;SKIP CLOSF IF NOT
MOVE B,DATHDR ;THE DATA PAGES
MOVE C,NUMWDS ;BY SPECIFYING LOCATION
CALL FREMEM ;AND SIZE.
GTF.0:
MOVE A,[POINT 7,[ASCIZ /DAT/]]
MOVEM A,GTFBLK+.GJEXT ;DEFAULT TO .DAT
MOVEI A,GTFBLK ;POINT TO GTJFN BLOCK
HRROI B,FRMFIL ;NAME IN FRMFIL
GTJFN
JRST [CAIE A,GJFX19 ;IF BAD EXTENSION ...
RET
MOVEI A,[POINT 7,[ASCIZ /FORM-DATA/]]
MOVEM A,GTFBLK+.GJEXT
MOVEI A,GTFBLK
HRROI B,FRMFIL ;TRY DIFFERENT DEFAULT
GTJFN
RET ;STILL NO GOOD
JRST .+1]
MOVEM A,DATJFN ;SAVE JFN
MOVE B,[^D36B5+OF%RD]
OPENF
ERJMP [RLJFN
JFCL
RET]
SIZEF ;FIND THE FILE SIZE
ERJMP GTF.3
MOVEM B,NUMWDS ;NUMBER OF 36-BIT WORDS
AOS (P)
RET
GTF.1: TMSG <
TFRCOB (GETFIL) filename too long>
RET ;ERROR
GTF.2: ;INDICATE CLOSF FAILURE
TMSG <
TFRCOB (GETFIL) CLOSF failed>
RET
GTF.3: ;PMAP FAILURE
TMSG <
TFRCOB (GETFIL) SIZEF failed>
RET
SUBTTL MAPIN - MAP THE DATA FILE INTO MEMORY
MAPIN:
SETZM GOTFIL ;NO FILE MAPPED YET
MOVE A,NUMWDS ;GET THE FILE SIZE
CALL GETMEM ;AND ALLOCATE THE MEMORY
RET
MOVEM B,DATHDR ;BASE ADDRESS OF DATA
MOVE C,NUMWDS
CALL RD.DAT ;READ THE WHOLE FILE
RET
MOVE A,DATJFN
CLOSF ;FREE THE FILE
CALL GTF.2
CALL GETFRM ;GET THE FORM VARIABLES
RET
SETOM GOTFIL ;FILE NOW MAPPED INTO MEMORY
JRST SKPRET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
RD.DAT: ;READ DATA INTO MEMORY
MOVE A,DATJFN
HRLI B,(POINT 36,) ;MAKE ADDRESS INTO BYTE POINTER
MOVNS C ;NEGATE THE WORD COUNT
SIN ;READ IT
ERJMP [MOVEI A,ERR.DP
RET]
JRST SKPRET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
GETMEM: ;ALLOCATE MEMORY FROM LIBOL OR FOROTS
MOVEM A,IMP%SZ ;SET UP THE ARGUMENT BLOCK
SETZM IMP%ST
PUSH P,ARG ;SAVE THE ARGUMENT POINTER
MOVEI ARG,ARG%GM
CALL FUNCT.## ;ALLOCATE MEMORY
POP P,ARG
SKIPE IMP%ST ;OK?
JRST [MOVEI A,ERR.NC ;NO - NO CORE
RET]
MOVE B,IMP%PT ;GET THE POINTER TO THE ALLOCATED AREA
JRST SKPRET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
FREMEM: ;FREE ALLOCATED MEMORY
SKIPLE B ;IF NO MEMORY ADDRESS
SKIPG A ;OR NO SIZE ...
RET ;THEN NOTHING TO DO
MOVEM B,IMP%PT ;SET UP THE ARGUMENT BLOCK
MOVEM A,IMP%SZ
PUSH P,ARG
MOVEI ARG,ARG%FM
CALL FUNCT.## ;TRY TO FREE THE CORE
POP P,ARG
RET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
OPTMEM: ;GET OR FREE OPTIMISER MEMORY
SKIPE .OSCRN ;IF WE ALREADY HAVE MEMORY
JRST SKPRET ;THEN OK
MOVEI A,MAXCOL ;GET NUMBER OF WORDS PER SCREEN
ADDI A,1 ;ROUND UP
IDIVI A,2
MOVEM A,WPLINE ;SAVE THIS
IMULI A,MAXLIN ;TIMES # LINES = WORDS PER SCREEN
MOVEM A,SCWORD ;SAVE IT
ADDI A,MX%SEC+^D402 ;ALSO ALLOCATE ROOM FOR SECTION
;TABLE (MX%SEC+2) AND MULTAB (400)
CALL GETMEM ;ALLOCATE IT
JRST OPM.2 ;CAN'T - TRY TO RECOVER
SETOM .TMOPT ;SWITCH OPTIMISER ON NOW
OPM.1:
MOVEM B,.OSCRN ;SAVE THE BASE ADDRESS
ADD B,SCWORD ;OFFSET TO MULTAB BASE
HRLI B,(POINT 9,) ;MAKE A BYTE POINTER
MOVEM B,MULTAB ;AND SAVE IT FOR LATER
ADDI B,^D400 ;POINT TO SECTAB BASE
HRLI B,(Z 0(A)) ;PUT IN AN INDEX REGISTER
MOVEM B,SECTAB
JRST SKPRET
OPM.2:
SETZM SCWORD ;NO SPACE FOR OPTIMIZER
SETZM .TMOPT ;SO IT CAN'T RUN
SETZM SCNUPD ;AND WE MUST UPDATE EVERY TIME
MOVEI A,MX%SEC+^D402 ;FAILED TO GET ALL THE CORE
CALL GETMEM ;SO JUST TRY FOR TABLE SPACE
SKIPA ; STILL NO GOOD - FAIL
JRST OPM.1 ;OK - SET UP POINTERS
SETOM NOCORE
RET
OPTFRE: ;FREE THE OPTIMISER MEMORY
SKIPN B,.OSCRN ;HAVE WE GOT ANY MEMORY?
JRST SKPRET ;NO
MOVE A,SCWORD ;YES - GET THE SIZE OF IT
CALL FREMEM ;AND DEALLOCATE IT
SETZM .OSCRN ;FLAG IT
JRST SKPRET
XLIST
LIT
LIST
SUBTTL DATA AREA FOR TRAFFIC-20
;PURE DATA AREA (SMALL) BUT ALIVE.
$SBUFPTR: POINT 7,STRBUF ;INITIALIZED POINTER TO BUFFER.
$SBUFMAX=^D300 ;300 CHARACTERS IN BUFFER
$SBUFSND=$SBUFMAX-^D80 ;SEND LESS THAN 80 CHARS IN BUFFER.
%FILES: XWD -1,0 ;ALWAYS A 0.
TFRPAT: BLOCK ^D64 ;64 WORD PATCH AREA.
; ARGUMENT BLOCK TO THE FUNCT. CALL IN LIBOL
; FORMAT IS
;
; -CNT,,0
; LST: TYPE,,FUNCTION
; TYPE,,[ERROR]
; TYPE,,[STATUS]
; TYPE,,[ADDRESS OF CORE]
; TYPE,,[SIZE]
-5,,0
ARG%GM: 100,,GP.MEM ;GET MEMORY
100,,IMP%ER ;ERROR CODE
100,,IMP%ST ;STATUS CODE
100,,IMP%PT ;POINTER TO AREA
100,,IMP%SZ ;SIZE TO BE GOTTEN
GP.MEM: 6 ;CODE FOR GETTING MEMORY
-5,,0
ARG%FM: 100,,FP.MEM ;GET MEMORY
100,,IMP%ER ;ERROR CODE
100,,IMP%ST ;STATUS CODE
100,,IMP%PT ;POINTER TO AREA
100,,IMP%SZ ;SIZE TO BE GOTTEN
FP.MEM: 7 ;CODE FOR FREEING MEMORY
;IMPURE DATA AREA
RELOC 0
TFRDAT:: ;START OF TFRCOB IMPURE DATA
DVTAB:
XWD VET000##,VET001##
XWD VET002##,VET003##
XWD VET004##,VET005##
XWD VET006##,VET007##
XWD VET008##,VET009##
XWD VET010##,VET011##
XWD VET012##,VET013##
XWD VET014##,VET015##
XWD VET016##,VET017##
XWD VET018##,VET019##
XWD VET020##,VET021##
XWD VET022##,VET023##
XWD VET024##,VET025##
XWD VET026##,VET027##
XWD VET028##,VET029##
XWD VET030##,VET031##
XWD VET032##,VET033##
XWD VET034##,VET035##
XWD VET036##,VET037##
XWD VET038##,VET039##
XWD VET040##,VET041##
XWD VET042##,VET043##
XWD VET044##,VET045##
XWD VET046##,VET047##
XWD VET048##,VET049##
XWD VET050##,VET051##
XWD VET052##,VET053##
XWD VET054##,VET055##
XWD VET056##,VET057##
XWD VET058##,VET059##
XWD VET060##,VET061##
XWD VET062##,VET063##
XWD VET064##,VET065##
XWD VET066##,VET067##
XWD VET068##,VET069##
XWD VET070##,VET071##
XWD VET072##,VET073##
XWD VET074##,VET075##
XWD VET076##,VET077##
XWD VET078##,VET079##
XWD VET080##,VET081##
XWD VET082##,VET083##
XWD VET084##,VET085##
XWD VET086##,VET087##
XWD VET088##,VET089##
XWD VET090##,VET091##
XWD VET092##,VET093##
XWD VET094##,VET095##
XWD VET096##,VET097##
XWD VET098##,VET099##
XWD VET100##,VET101##
XWD VET102##,VET103##
XWD VET104##,VET105##
XWD VET106##,VET107##
XWD VET108##,VET109##
XWD VET110##,VET111##
XWD VET112##,VET113##
XWD VET114##,VET115##
XWD VET116##,VET117##
XWD VET118##,VET119##
XWD VET120##,VET121##
XWD VET122##,VET123##
XWD VET124##,VET125##
XWD VET126##,VET127##
XWD VET128##,VET129##
XWD VET130##,VET131##
XWD VET132##,VET133##
XWD VET134##,VET135##
XWD VET136##,VET137##
XWD VET138##,VET139##
XWD VET140##,VET141##
XWD VET142##,VET143##
XWD VET144##,VET145##
XWD VET146##,VET147##
XWD VET148##,VET149##
XWD VET150##,VET151##
XWD VET152##,VET153##
XWD VET154##,VET155##
XWD VET156##,VET157##
XWD VET158##,VET159##
XWD VET160##,VET161##
XWD VET162##,VET163##
XWD VET164##,VET165##
XWD VET166##,VET167##
XWD VET168##,VET169##
XWD VET170##,VET171##
XWD VET172##,VET173##
XWD VET174##,VET175##
XWD VET176##,VET177##
XWD VET178##,VET179##
XWD VET180##,VET181##
XWD VET182##,VET183##
XWD VET184##,VET185##
XWD VET186##,VET187##
XWD VET188##,VET189##
XWD VET190##,VET191##
XWD VET192##,VET193##
XWD VET194##,VET195##
XWD VET196##,VET197##
XWD VET198##,VET199##
XWD VET200##,VET201##
XWD VET202##,VET203##
XWD VET204##,VET205##
XWD VET206##,VET207##
XWD VET208##,VET209##
XWD VET210##,VET211##
XWD VET212##,VET213##
XWD VET214##,VET215##
XWD VET216##,VET217##
XWD VET218##,VET219##
XWD VET220##,VET221##
XWD VET222##,VET223##
XWD VET224##,VET225##
XWD VET226##,VET227##
XWD VET228##,VET229##
XWD VET230##,VET231##
XWD VET232##,VET233##
XWD VET234##,VET235##
XWD VET236##,VET237##
XWD VET238##,VET239##
XWD VET240##,VET241##
XWD VET242##,VET243##
XWD VET244##,VET245##
XWD VET246##,VET247##
XWD VET248##,VET249##
XWD VET250##,VET251##
XWD VET252##,VET253##
XWD VET254##,VET255##
XWD VET256##,VET257##
XWD VET258##,VET259##
XWD VET260##,VET261##
XWD VET262##,VET263##
XWD VET264##,VET265##
XWD VET266##,VET267##
XWD VET268##,VET269##
XWD VET270##,VET271##
XWD VET272##,VET273##
XWD VET274##,VET275##
XWD VET276##,VET277##
XWD VET278##,VET279##
XWD VET280##,VET281##
XWD VET282##,VET283##
XWD VET284##,VET285##
XWD VET286##,VET287##
XWD VET288##,VET289##
XWD VET290##,VET291##
XWD VET292##,VET293##
XWD VET294##,VET295##
XWD VET296##,VET297##
XWD VET298##,VET299##
XWD VET300##,VET301##
XWD VET302##,VET303##
XWD VET304##,VET305##
XWD VET306##,VET307##
XWD VET308##,VET309##
XWD VET310##,VET311##
XWD VET312##,VET313##
XWD VET314##,VET315##
XWD VET316##,VET317##
XWD VET318##,VET319##
XWD VET320##,VET321##
XWD VET322##,VET323##
XWD VET324##,VET325##
XWD VET326##,VET327##
XWD VET328##,VET329##
XWD VET330##,VET331##
XWD VET332##,VET333##
XWD VET334##,VET335##
XWD VET336##,VET337##
XWD VET338##,VET339##
XWD VET340##,VET341##
XWD VET342##,VET343##
XWD VET344##,VET345##
XWD VET346##,VET347##
XWD VET348##,VET349##
XWD VET350##,VET351##
XWD VET352##,VET353##
XWD VET354##,VET355##
XWD VET356##,VET357##
XWD VET358##,VET359##
XWD VET360##,VET361##
XWD VET362##,VET363##
XWD VET364##,VET365##
XWD VET366##,VET367##
XWD VET368##,VET369##
XWD VET370##,VET371##
XWD VET372##,VET373##
XWD VET374##,VET375##
XWD VET376##,VET377##
XWD VET378##,VET379##
XWD VET380##,VET381##
XWD VET382##,VET383##
XWD VET384##,VET385##
XWD VET386##,VET387##
XWD VET388##,VET389##
XWD VET390##,VET391##
XWD VET392##,VET393##
XWD VET394##,VET395##
XWD VET396##,VET397##
XWD VET398##,VET399##
XWD VET400##,VET401##
XWD VET402##,VET403##
XWD VET404##,VET405##
XWD VET406##,VET407##
XWD VET408##,VET409##
XWD VET410##,VET411##
XWD VET412##,VET413##
XWD VET414##,VET415##
XWD VET416##,VET417##
XWD VET418##,VET419##
XWD VET420##,VET421##
XWD VET422##,VET423##
XWD VET424##,VET425##
XWD VET426##,VET427##
XWD VET428##,VET429##
XWD VET430##,VET431##
XWD VET432##,VET433##
XWD VET434##,VET435##
XWD VET436##,VET437##
XWD VET438##,VET439##
XWD VET440##,VET441##
XWD VET442##,VET443##
XWD VET444##,VET445##
XWD VET446##,VET447##
XWD VET448##,VET449##
XWD VET450##,VET451##
XWD VET452##,VET453##
XWD VET454##,VET455##
XWD VET456##,VET457##
XWD VET458##,VET459##
XWD VET460##,VET461##
XWD VET462##,VET463##
XWD VET464##,VET465##
XWD VET466##,VET467##
XWD VET468##,VET469##
XWD VET470##,VET471##
XWD VET472##,VET473##
XWD VET474##,VET475##
XWD VET476##,VET477##
XWD VET478##,VET479##
XWD VET480##,VET481##
XWD VET482##,VET483##
XWD VET484##,VET485##
XWD VET486##,VET487##
XWD VET488##,VET489##
XWD VET490##,VET491##
XWD VET492##,VET493##
XWD VET494##,VET495##
XWD VET496##,VET497##
XWD VET498##,VET499##
XWD VET500##,VET501##
XWD VET502##,VET503##
XWD VET504##,VET505##
XWD VET506##,VET507##
XWD VET508##,VET509##
XWD VET510##,VET511##
CHRTAB: ;CHARACTER TABLE
CONCHR=1
FCCCHR=2
PNCCHR=4
SPCCHR=10
NUMCHR=20
ALPCHR=140 ;THIS ALLOWS ALPHABETICS
YNFCHR=40 ;THIS ALLOWS ONLY Y OR N
REPEAT ^D8,<CONCHR> ;0-7 ^A TO ^G
REPEAT ^D3,<FCCCHR> ;10-12 BACKSPACE,TAB,LF
REPEAT ^D1,<CONCHR> ;13 VT
REPEAT ^D2,<FCCCHR> ;14-15 FF,CR
REPEAT ^D13,<CONCHR> ;16-32 OTHERS
REPEAT ^D1,<FCCCHR> ;33 ESC
REPEAT ^D4,<CONCHR> ;34-37 OTHERS
REPEAT ^D1,<SPCCHR> ;40 SPACE
REPEAT ^D15,<PNCCHR> ;40-57
REPEAT ^D10,<NUMCHR> ;60-71 0-9
REPEAT ^D7,<PNCCHR> ;72-100
REPEAT ^D13,<ALPCHR> ;101-115 A-M
REPEAT ^D1,<YNFCHR> ;116 N
REPEAT ^D10,<ALPCHR> ;117-130 O-X
REPEAT ^D1,<YNFCHR> ;131 Y
REPEAT ^D1,<ALPCHR> ;132 Z
REPEAT ^D6,<PNCCHR> ;133-137
REPEAT ^D13,<ALPCHR> ;140-155 SMALL(A-M)
REPEAT ^D1,<YNFCHR> ;156 SMALL N
REPEAT ^D10,<ALPCHR> ;157-170 SMALL O-X
REPEAT ^D1,<YNFCHR> ;171 SMALL Y
REPEAT ^D1,<ALPCHR> ;172 SMALL Z
REPEAT ^D5,<PNCCHR> ;173-177
REMARK TRANSLATION TABLES FOR SIX & SEVEN BIT TO SEVEN BIT TRANSLATION.
SVN27: ;ASCII TO ASCII MOVE
XWD 100000,1
.CHAR=2
REPEAT <36/2>,< XWD .CHAR,.CHAR+1
.CHAR=.CHAR+2 >
SIX27:
REPEAT 1,< XWD 100040,.CHAR+1
.CHAR=.CHAR+2 >
REPEAT <<200-42>/2>,< XWD .CHAR,.CHAR+1
.CHAR=.CHAR+2>
SVN2U: ;CONVERT ASCII TO UPPER CASE
XWD 100000,1
.CHAR=2
REPEAT <<140-2>/2>,<XWD .CHAR,.CHAR+1
.CHAR=.CHAR+2>
XWD 140,101
.CHAR=.CHAR+2
REPEAT <^D24/2>,<XWD <.CHAR-40>,<.CHAR-37>
.CHAR=.CHAR+2>
XWD 132,173
XWD 174,175
XWD 176,177
GTFBLK: ;GETFIL GTJFN BLOCK
GJ%OLD
.NULIO,,.NULIO
BLOCK 7
LINKBF: ;FORTRAN AND MACRO LINKAGE FOR VET ROUTINES
-4,,0
17B12 ;USER DATA
2B12+DSTAT ;ERROR STATUS
17B12+ERRBUF ;ERROR MESSAGE
17B12 ;FIELD NAME
LINKBK: ;COBOL LINKAGE BLOCK FOR VET ROUTINES
-4,,0
15B12+LINKBS ;USER DATA
2B12+DSTAT ;ERROR STATUS
15B12+.+2 ;ERROR MESSAGE
15B12+LINKBS+2 ;FIELD NAME
POINT 7,ERRBUF
3B4+^D80
DSTAT: 0 ;ERROR STATUS
LINKBS: 0 ;USER DATA
0
0 ;FIELD NAME
0
ERRBUF: BLOCK 16 ;ERROR MESSAGE
0
;DATA AREA FOR INPDAT AND OUTDAT ROUTINES
TMPBUF: ;ALSO USED BY THE OPTIMISER
TEMPX: BLOCK 2 ;TEMP FOR NOUT JSYS
TEMP: BLOCK 3 ;TEMP STRING AREA
ZEROS: ASCII /000000/ ;A ZERO STRING
FLAGS: OT%NTM+OT%NMN+OT%DAM ;ODCNV FLAGS WORDS
OT%NTM
OT%NTM+OT%NMN
OT%NTM+OT%NMN+OT%DAM
NOCORE: 0 ;-1 IF CORE CANNOT BE OBTAINED
MAXFLD: 0 ;HIGHEST FIELD REACHED BEFORE BACKUP
MAXELM: 0 ;HIGHEST ELEMENT NUMBER DURING BACKUP
LASTFLD: 0 ;SAVE PREVIOUS FIELD NUMBER.
SECFLG: 0 ;CURRENT SECTION FLAGS (WAS SECTAB(0))
SECTAB: 0 ;POINTER TO SECTION TABLE
FLDTLN=^D31 ;LENGTH (PRIME #) OF ENTRIES IN FIELD TABLE
FLDTAB: BLOCK FLDTLN+2 ;FIELD TABLE
MOVFILL: MOVSLJ ;MOVE LEFT JUSTIFIED
0 ;KEEP WITH MOVFILL.
FILCHR: 0 ;FILLER CHARACTER FOR CURRENT FIELD.
CVTUC: 0 ;-1 TO CONVERT TO U/C IN MOV.7
TOTOUT: 0 ;TOTAL NUMBER OF CHARACTERS OUT
NUMOUT: 0 ;AND NUMBER OF CALLS TO $SEND
MAXOUT: 0 ;LONGEST STRING SENT OUT
OVRFLOW: 0 ;COUNT OF NEAR BUFFER OVERFLOWS.
$SBPTR: 0 ;OUTPUT BUFFER BYTE POINTER
$SNUM: 0 ;NUMBER CHARS LEFT IN BUFFER
STRBUF: BLOCK $SBUFMAX/5+^D10 ;SIZE OF TERMINAL OUTPUT BUFFER WITH PADDING.
OLDMOD: 0 ;MOVE TO IMPURE STORAGE
COC: BLOCK 2
GOTFIL: 0 ;=0 IF NO FILE MAPPED, -1 OTHERWISE.
DOCHK: 0 ;NEED TO CHECK TERMINAL FLAG
FTARGS: FT%ARG ;ARGUMENT CHECKING FLAG
BRK128: BRK%128 ;0: 3A WAY, -1: USE 128 CHAR BREAK SET
OLDTT: OLD%TT ;=0 IF NOT SETTING CHARACTERISTICS
;ON EACH CALL.
OLDCR: OLD%CR ;=0, CR=5, -1, CR=3
OLDAR: OLD%AR ;=0, LEFT/RIGHT ARROWS ARE BACKSP/TAB
; IF -1, THEN END-INDICATOR OF 5.
OLDMD: OLD%MD
OLDPR: OLD%PR
OLDRN: OLD%RN ;=0, THEN REWRITE NUMERIC FIELDS
OLDLC: OLD%LC ;=0, NO LOWERCASE, =-1, LOWERCASE
LWRCAS: 0 ;-1 IF CURRENT FIELD ALLOWS LOWER CASE
OLDCC: OLD%CC ;=0, NO CNTRL/C TRAP,=-1 THEN DOIT.
DORESET: 0 ;FORCE TERMINAL RESET FLAG.
OLDUD: OLD%UD ;=0,UP/DOWN ARROWS = CARRIAGE RET.
NEWRND: NEW%RND ;DO RENDITION IF 0, DON'T IF -1
SCNUPD: NEW%SUD ;0 TO UPDATE EVERY CALL, -1 WHEN NECESSARY
PAGINI: 0 ;FLAG IF STORAGE GOTTEN ONCE.
STRPNT: 0
HOUR24: 0 ;-1 IF 24:00:00 BEING ENTERED
DAY: 0 ;DAY NUMBER
MONTH: 0 ;MONTH NUMBER
YEAR: 0 ;YEAR NUMBER
NEWFRM: 0 ;-1 IF FIRST TIME THROUGH NEW FORM
MAXSEC: 0 ;MAXIMUM NUMBER OF SECTIONS ALLOWED
ALIGN: 0 ;-1 IF DATA IS WORD ALIGNED
LPTJFN: 0 ;TFRLPT: JFN
PAGFLG: 0 ;FLAG FOR FORM-FEED TO TFRLPT:
TTJFN: 0 ;PRIMARY TERMINAL JFN
TRMDES: 0 ;TERMINAL DESIGNATOR
STWORD: 0 ;ORRIGINAL TERMINAL STATUS WORD
TRMNAM: BLOCK ^D10 ;TERMINAL NAME
LOGNAM: 0 ;POINTER TO USER SUPPLIED TERMINAL NAME
V132FG: 0 ;-1 TO INDICATE TERMINAL IN 132 COLUMN MODE
TRMATR: 0 ;MAXIMUM TERMINAL ATTRIBUTES
AVOFLG: 0 ;TERMINAL HAS AVO (IE, VT100)
REVSCR: 0 ;-1 MEANS SCREEN IS REVERSE NOW, 0 = NOT
FSECTN: 0 ;POINTER TO FIELD SECTION MASKS
CATTR: 0 ;PREVIOUS RENDITION
FLDATR: 0 ;COPY OF FIELD ATTRIBUTES
EPARAM: 0 ;ERROR LINE PARAMETERS
FPARAM: 0 ;FORM PARAMETERS
FTPOS: BLOCK 2 ;TEXT POSITION
FTEXT: 0 ;TEXT BYTE POINTER
FTLEN: 0 ;TEXT LENGTH
VRSION: 0 ;TFR VERSION NUMBER
FLDLEN: 0 ;LENGTH OF FIELD DATA
HDRLEN: 0 ;LENGTH OF HEADER DATA
FLDTYP: 0 ;BREAK SET STORAGE CELL.
ISNEG: 0 ;CELL USED FOR INDICATING NEGATIVE NUMBERS.
ISTAB: 0 ;SET IF PREVIOUS DUPE TABBED OVER.
PREDUP: 0 ;IF -1, THEN STARTING PREVIOUS DUP FIELD.
DATTYP: 0 ;DATE TYPE
LONGDT: 0 ;-1 IF LONG FORMAT DATE
TTOPN: 0 ;TT JFN IS SET
ACSAV: BLOCK ^D16 ;AC SAVE AREA
TTYPE: %VTDEF ;TERM TYPE FOR VT100 STUFF
OPTTTY: 0 ;OPTIMISED TERMINAL TYPE NUMBER
TRMLGL: 0 ;LEGAL TERMINAL MASK
CHARST: 0 ;CHAR SET
IDXRND: 0 ;INDEX FIELD RENDITION BITS
MLTIDX: 0 ;INDEX FIELD NUMBER
MLTNMF: 0 ;NUMBER OF FIELDS
MLTSEC: 0 ;SECTION NUMBER
MLTCNT: 0 ;COUNT
MLTHIR: 0 ;HIGHEST ROW NUMBER
MLTLOR: 0 ;LOWEST ROW NUMBER
MLTFLT: 0 ;ANOTHER FLAG
MWTALL: 0 ;-1 = WRITE ALL CHARACTERS AS CHANGED
FSTELM: 0 ;FIRST ELEMENT NUMBER ON SCREEN
LSTELM: 0 ;LAST ELEMENT NUMBER ON SCREEN
ML1UNP: 0 ;FIRST UNPROTECTED FIELD IN M.S.
MLTDCT: 0 ;NUMBER OF LINES ON DISPLAY
WRTFLG: 0 ;-1 SAYS USE FWRITE IN WRTELM
;THE NEXT BLOCK MUST STAY TOGETHER - IT GETS SAVED THAT WAY
MLTTMP: 0 ;TEMP COUNTER
MLTELM: 0 ;CURRENT ELEMENT NUMBER
MLTBAS: 0 ;BASIS FIELD POINTER
MLTFLG: 0 ;FIRST FIELD IN ELEM. FLAG
MLTCT1: 0 ;A COUNTER
IDXSET: 0 ;INDEX DONE FLAG
NEWMMS: NEW%MMS ;MULT SEC WRITE MSG IF 0, NONE IF -1
MLTDSP: 0 ;LINES OF DISPLAY
MLTIDC: 0 ;INDEX COLUMN NUMBER *** KEEP WITH MLTDSP
MULTPT: 0 ;POINT TO CURRENT ENTRY IN MULTAB
%MSAVE=.-MLTTMP
MSINIT: 0 ;-1 INDICATES INITING UNPROT MS FIELDS
MSNEW: 0 ;-1 INDICATES A MS IS ON THE SCREEN
MTXTFG: 0 ;-1 TO ALLOW TEXT TO BE WRITTEN BY WRTELM
NOSCRL: 0 ;=0 TO STOP SCROLLING, -1 TO ENABLE
MLTIVP: 0 ;POINTER TO VALUE FOR INDEX
MLTSIZ: 0 ;TOTAL SIZE OF SECTION
;
;MULTAB IS A POINTER TO A TABLE USED TO CONTAIN THE NUMBER
;OF CHARACTERS READ INTO A FIELD (OR THE LENGTH IF IT IS
;PROTECTED). EACH FIELD HAS A 9-BIT BYTE ENTRY, 4 PER WORD.
;A FULL MULTIPLE SECTION THUS REQUIRES 400 WORDS OF MEMORY.
;
MULTAB: 0 ;POINT TO TABLE
MLTSAV: BLOCK %MSAVE ;CONTEXT SAVE AREA FOR TFRRWT
MLTSVA: BLOCK 3 ;PARTIAL CONTEXT SAVE AREA FOR SETOFF
RSCANM: 0 ;SYSTEM VARIABLE ASSOCIATED WITH RESCAN
;OPTIMIZER DATA AREA
VERT: 0 ;VERTICAL FIELD
TOPBOT: 0 ;0= TOP HALF, -1= BOTTOM HALF
TXTPTR: 0 ;POINTER TO TMPBUF (ABOVE)
.OSCRN: 0 ;OPTIMIZER MEMORY STATUS FLAG
.TMOPT: 0 ;OPTIMIZER STATUS FLAG
.OFG: 0 ;PREVIOUS LINE MODE FLAGS
.OCL: 0 ;CURRENT LINE
.OCC: 0 ;CURRENT COLUMN
.OSC: 0 ;SPACE COLUMN
.OCSC: 0 ;CHANGED SPACE COLUMN
.OBP: 0 ;BYTE POINTER
.OCHNG: 0 ;CHANGED CHARACTER FLAG
.OLC: 0 ;LAST COLUMN SENT
.OLEFT: BLOCK MAXLIN+2 ;FIRST CHARACTER CHANGED ON LINE
.ORGHT: BLOCK MAXLIN+2 ;LAST CHARACTER CHANGED ON LINE
.OLKNS: BLOCK MAXLIN+2 ;LAST KNOWN NON-SPACE CHARACTER
.OLPTR: BLOCK MAXLIN+2 ;POINTER TO LINE DATA
.OFLAG: BLOCK MAXLIN+2 ;LINE MODE FLAGS
.ORC: 0 ;LAST RIGHT-HAND CHARACTER
.OATTR: 0 ;ATTRIBUTES
.ONBP: 0
.ONCOL: 0
.OVCOL: 0
.ONLIN: 0
.OVLIN: 0
.OECHO: 0
.OLBL: 0 ;LAST BLANKED LINE
.OOBP: 0 ;OUTPUT BYTE POINTER
.OCR: 0
ECHAR: 0 ;LAST ESCAPE CHARACTER RECEIVED
SCWORD: 0 ;NUMBER OF WORDS FOR SCREEN DATA
NUMWDS: 0 ;NUMBER OF WORDS IN FILE
WPLINE: 0 ;
TRMLIN: 0 ;MAXIMUM NUMBER OF LINES ON SCREEN
TRMCOL: 0 ;MAXIMUM NUMBER OF COLUMNS ON SCREEN
INTSET: 0 ;TERMINAL INTERRUPTS NOT SET
INIFLG: 0 ;ONCE-ONLY INIT FLAG
ERRDSP: 0 ;ERROR IS ON SCREEN
ALLCLR: 0 ;CLEAR ALL ON SCREEN DATA IN PROGRESS
ERRRNG: 0 ;ERROR LINE POINTER FOR RANGE STUFF
INTCOL: 0 ;INTERUPT COLUMN
TRMCHR: 0 ;TERMINAL CHARACTER ON A READ (FLDRD)
RECLEN: 0 ;RECORD LENGTH IF KNOWN
DATJFN: 0 ;JFN OF FORM DATA FILE
DATHDR: 0 ;POINTER TO FORM DATA
RECPTR: 0 ;POINTER TO USERS RECORD DESCRIPTION.
HIFLD: 0 ;HIGHEST # FIELD THIS FORM.
CURERR: 0 ;CURRENT ERROR CODE.
LENERR: 0 ;LENGTH ERROR DETECTED.
FRSTFD: 0 ;FIELD # BEFORE FIND
CURLIN: 0 ;CURRENT LINE FOR TALL/WIDE SETUP
SAVFLD: BLOCK ^D8 ;A TEMP SAVE AREA FOR TFRRD
SAVCTX: BLOCK ^D12 ;SPECIAL SAVE FOR VET
ERRLIN: 0 ;THE ERROR LINE FOR THIS FORM
FRMFIL: BLOCK 130/5+1 ;STRING FOR FORM NAME
INTBUF: BLOCK 255/5 ;INTERNAL TYPE CONVERSION BUFFER
;SUBFIELD POINTERS AND FLAGS
SFCERR: 0 ;-1 IF SUBFIELD CHECK ERROR OCCURED
SFPNTR: 0 ;CURRENT POINTER TO FIELD BUFFER
SFDPTR: 0 ;SUBFIELD DESCRIPTOR POINTER
SUBPTR: 0 ;POINTER TO FIELD DATA (COPY OF VALFLD)
SFDES: 0 ;DUMMY DESCRIPTOR FOR NON-SUBFIELDS
SUBTMP: 0 ;TEMPORARY STORAGE AREA
SUBCNT: 0 ;CURRENT SUBFIELD NUMBER
SUBLEN: 0 ;LENGTH OF SUBFIELD
SFTYPE: 0 ;SUBFIELD TYPE
FLDPOS: 0 ;OFFSET INTO CURRENT FIELD (INCL. SEPARATORS)
LSTSEP: 0 ;LAST SEPARATOR SEEN
BACKSF: 0 ;FLAG WHEN BACKING UP OVER SUBFIELDS
SGNLGL: 0 ;SIGN IS LEGAL IN THIS FIELD IF ZERO
ENUMRD: 0 ;NUMBER OF EXTENSION CHARACTERS TO BLANK
SUMRED: 0 ;CHARACTERS READ IN MS ELEMENT
SUBTOT: 0 ;BACKUP COUNTER
;************ THIS BLOCK MUST STAY TOGETHER
FLDPTR: 0 ;FIELD PASSED TO FIND.
TOTNRD: 0 ;TOTAL # RD IN A SUB-FIELD TYPE FIELD
YET2WT: 0 ;TOTAL YET 2 WRITE IN (WRITE)
FULLEN: 0 ;FULL LENGTH OF CURRENT FIELD
FNUMRD: 0 ;NUMBER OF CHARACTERS IN FIELD (CF .NUMRD)
LINFLD: 0 ;CURRENT LINE
COLFLD: 0 ;CURRENT COLM
LENFLD: 0 ;CURRENT LENGTH
VALFLD: 0 ;CURRENT VALUE PTR
OFFFLD: 0 ;CURRENT OFFSET IN W.S.
COBCAL: 0 ;CALL FROM COBOL
CURFLD: 0 ;THE CURRENT DATA FIELD
;************
COBAPP: 0 ;-1 IF COBOL APPLICATION, 0 OTHERWISE
DEFALT: 0 ;SPECIAL DEFALT FROM TFRRD
NEWDAT: 0 ;NEW DATA INDICATOR
WHFLAG: 0 ;PREVENT WRITING HIDDEN SEC TWICE
SEPFND: 0 ;-1 IF SEPARATOR FOUND IN SUB-FIELD
NOSECT: 0 ;-1 IF ONLY SINGLE FIELD-ID ALLOWED IN FIND
NEWAUT: 0 ;-1 = PREVENT MESSAGE IN NO-AUTO-TAB FIELDS
NEWMNY: NEW%MNY ;-1 TO ACT LIKE V2A IN MONEY FIELDS
NEWNSJ: NEW%NSJ ;-1 = ALWAYS JUSTIFY NUMERIC SUBFIELDS
NEWCHM: NEW%CHM ;-1 TO PREVENT CURSOR HOME
HDNSEC: 0 ;HIDDEN SECTION BITS
HXFLAG: 0 ;-1 SAYS HIDDEN FIELD CAN BE INITED
CURHSC: 0 ;CURRENT HIDDEN SECTION
VETCAL: 0 ;NON ZERO WHEN IN VET ROUTINE
CURDAT: BLOCK 3 ;TEMP AREA FOR DATE
; MODIFIED TEXTI TABLES FOLLOW FOR USE IN FLDRD ROUTINE.
BYPASS: 0 ;-1 WHEN IN BYPASS MODE
TXTTAB:
0 ;POINTER TO INPUT DESTINATION
0 ;NUMBER OF BYTES AVAIL IN DESTINATION
0 ;BUFFER START; SAME VALUE AS IN DEST.
; DATA AREA FOR ARGUMENTS TO FUNCT. CALLS TO LIBOL
IMP%ER: BLOCK 1 ;ERROR CODE FOR FUNCT.
IMP%ST: BLOCK 1 ;STATUS CODE FOR FUNCT.
IMP%PT: BLOCK 1 ;ADDRESS OF MEMORY
IMP%SZ: BLOCK 1 ;SIZE OF MEMORY
END