Trailing-Edge
-
PDP-10 Archives
-
BB-5372C-BM
-
sources/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) 1976,1977,1978 DIGITAL EQUIPMENT CORP., MAYNARD MASS.***
IF1 <PRINTX TFRCOB-20 VERSION 2(111)>
COMMENT ^ EDIT HISTORY
EDIT DESCRIPTION
-------------------
2 CHARACTERS SOMETIMES ARE LOST WHEN AN ERROR MSG IS
DISPLAYED AND AN IGNORABLE CHARACTER IS TYPED.
(SEE EDIT 2 IN TFRTRM)
3 CORRECT SPELLING IN ERROR MESSAGE (ENTERRED => ENTERED).
4 CORRECT PREVIOUS DUPE FIELDS FROM MESSING UP MONEY, DATE,
AND SOC-SEC-NUMBER FIELDS.
5 MAKE OPTIONAL DATE FIELDS REALLY OPTIONAL; I.E.,
TABBING PAST FIELD AND NOT TYPING ANYTHING IS
ALLOWED AND DOES NOT GIVE 'INVALID DATE' MESSAGE.
6 RELEASE OLD JFN WHEN CHANGING DATA FILES; OTHERWISE,
PROGRAM CAN RUN OUT OF JFN'S.
7 ALLOW CHECKING OF NUMBER OF ARGUMENTS USED IN
COBOL CALL TO TFR ROUTIES;
HALT IF ERROR OCCURS.
THIS FEATURE IS INCLUDED IF FTARGS IS SET TO 1.
10 MAKE THE FORM DEFINED VALUES IN NUMERIC PROTECTED VARIABLES
DISPLAY RIGHT JUSTIFIED.
11 WHEN UNPROTECTED VARIABLES WITH VALUE CLAUSES IN FORM FILE ARE
INITIALIZED, ONLY PART OF THE FIELD IS FILLED WITH FILLERS.
FIX THIS PROBLEM.
12 CHANGING RANGE VALUES DOES NOT ALWAYS WORK.
SETTING MONEY FIELDS FROM NUMERIC VARIABLES WITH IMPLIED
DECIMAL PLACES (99V99) DOES NOT WORK.
13 CHANGING CLASS FROM NUMERIC OR ALPHA ONLY TO ALPHANUMERIC
DOES NOT WORK. FIX IT.
14 WHEN PROGRAM IS READING BY SECTIONS OR FORMS AND USER TYPES
AN 'ABORT NOW CHARACTER (LIKE LINE FEED)', TRAFFIC TYPES OUT
0'S FOR NUMERIC FIELDS IN THE REMAINDER OF THE SECTION. THIS
IS MOST OFTEN FOLLOWED BY RESETTING THEM BACK TO FILLERS WITH
THE NEXT INIT. --A VERY COSTLY THING TO DO ON MANY FORMS.
FIX--DO NOT DO THIS.
15 TRAFFIC HAS HIGH OVERHEAD -- MAKE CHANGES SO THAT READING OF
CHARACTERS FROM THE TERMINAL USES LESS CPU TIME.
A. ELIMINATES THE NEED FOR THE TYPE-IN INTERRUPT
B. USES LOCAL CODE IN PLACE OF THE TEXTI JSYS
C. ALSO MAKES CHANGES IN TFRTRM.MAC (EDIT [??])
16 CHECK FORMAT AND RANGE OF DATES CORRECTLY.
17 TFRCLR WILL STOP ON FIRST NONE DISPLAY FIELD IN A SECTION AND
RETURN AN ERROR CODE. THE FIX IS TO STILL RETURN THE ERROR
CODE IF ANY FIELD IN THE SECTION IS NOT CURRENTLY DISPLAY, BUT
TO CLEAR ALL THAT ARE DISPLAYED. ALSO MAKE OTHER OPERATIONS
WHICH ENCOUNTER CLEARED FIELDS CONTINUE TO WORK.
20 VALIDITY CHECKS ON PREVIOUS DUPE DATE FIELDS AND Y/N FIELDS
DOES NOT WORK BECAUSE THE <TAB> IS STORED IN THE FIELD.
21 FIX PROBLEMS WITH MINUS SIGNS AND SURPRESS LEADING ZEROS
ON DISPLAYS OF NUMERIC FIELDS.
22 CHANGED ATTRIBUTES BECOME PERMINENT AND DO NOT GO AWAY AS THEY
ARE SUPPOSED TO AT INITIALIZATION TIME. ..PROBLEM IS THAT THERE
ARE NOT ENOUGH BITS --- FIX THIS.
23 IF A SECTION (OR FORM) IS INITIALIZED AND THEN A FIELD (OR MORE)
IS CLEARED, READING BY SECTION WILL FAIL WHEN THE FIRST CLEARED
FIELD IS ENCOUNTERED -- SHOULD MERELY BE BYPASSED.
24 FIX THE ESCAPE SEQUENCES WHICH REINIT THE FIELD, THE READ
AND REWRITE THE SCREEN SO THAT THEY WORK WITH PREVIOUS DUPE.
25 MAKE LF, AND OTHER TERMINATOR FUNCTION THE SAME AS TAB
ON PREVIOUS DUPE FIELDS.
26 FIELDS WITH THE FULL ATTRIBUTE IMPROPERLY PLACE THE CURSOR
AFTER A LINE FEED TO TERMINATE.
27 THE FULL ATTRIBUTE COMBINED WITH OTHERS PRODUCES WRONG RESULTS.
IT SHOULD:
1. ALLOW PREVIOUS DUPE TO WORK.
2. BYPASS IF FIELD OPTIONAL AND NO CHARS TYPED.
30 EX. IN A NUMERIC FIELD, TYPE AN 'A'. THIS WILL GENERATE
AND ERROR MESSAGE AND WILL MOVE THE CURSOR TO THE POSITION
OF THE 'A' AND OVERWRITE IT WITH THE FILLER. A SUBSEQUENT
BACKSPACE WILL BACKUP THE LOGICAL INFORMATION BUT NOT
THE CURSOR. SUBSEQUENT BACKSPACES WILL WORK. THIS APPEARS
TO BE A PROBLEM WITH THE TERMINAL. THE SOLUTION IS TO
SEND AN EXTRA BACKSPACE AFTER ERASING THE ERROR MESSAGE.
31 CHANGING RANGES DOES NOT WORK. MAKE IT WORK.
LOW VALUES WILL TURN OF RANGE BUT NOT DESTROY VALUE.
INIT WILL TURN ON RANGE. USER NEEDS TO SPECIFIY LOW
VALUES FOR THE RANGE TO TURN OFF (UPPER OR LOWER).
32 RANGE CHECKING, ESPECIALLY WITH NEGATIVE NUMBERS DOES
NOT WORK, MAKE IT.
33 AFTER A GROUP READ WHICH ENDS WITH A NUMERIC FIELD IS
TERMINATED WITH A LF OR SOMETHING OTHER THAN A TAB OR
FULL FIELD, THIS LAST FIELD IS NOT JUSTIFIED--DO IT.
34 IF NO CHARACTERS ARE TYPED IN A FIELD, AND IT IS OPTIONAL,
THEN DO NOT DO RANGE CHECKING.
35 ADD CODE TO MAKE THIS WORK WITH VERSION 12 OF COBOL
WHICH REDEFINES THE FREE AREA.
36 INTEGRATE WITH TFRTRM.V52 SINCE THIS VERSION WILL NEVER
SUPPORT TERMINALS OTHER THAN VT52'S.
37 THE REWORKING OF THE CODE HAS FIXED MANY BUGS WHICH MAY
ACTUALLY BEING USED AS FEATURES. THE PREDOMINENT ONE IS
THAT MANY ATTRIBUTES MAKE A FIELD REQUIRED (YES/NO, RANGES,
ETC.) IF USER IS UTILIZING THIS FEATURE, THEN ALLOW IT
TO WORK.
40 THE CODE IS DIFFICULT TO WORK ON AND READ, REMOVE SOME OF
THE MORE OBSCURE HIPO CONSTRUCTS AND REPLACE WITH A
MORE STRUCTURED LOOKING CODE.
41 OPTIMIZE THE SCREEN INITIALIZATION CODE.
42 DURING INITIALIZATION OF A FIELD, SET ALPHAS AND ALPHANUMERICS
TO SPACES (AS DONE CURRENTLY) AND NUMERICS TO ZEROS (CURRENTLY
SPACES) AND THEN OPTIMIZE FIELD READING CODE.
43 ADD 2 NEW CALLS TO RESTORE TERMINAL TO KNOWN STATE AFTER
MAKING CALLS TO LOWER FORK OR AFTER USING THE COBOL
'DISPLAY' STATEMENT. THE CALLS DO NOT HAVE ANY ARGUMENT
AND ARE:
TFRSET -- TO SET TERMINAL CHARACTERISTICS FOR TRAFFIC
TFRRST -- TO SET TERMINAL CHARACTERISTICS FOR USER MODE
TFRRWT -- TO REWRITE THE SCREEN (LIKE THE BLACK BUTTON).
AFTER USING A LOWER FORK, BOTH ROUTINES SHOULD BE CALLED.
AFTER USING THE DISPLAY VERB, AT LEAST TFRSET SHOULD BE CALLED.
ALSO MAKE RESETTING OF THE TERMINAL TO A KNOWN STATE AUTOMATIC
ON EACH CALL WITH PARAMETER OLD%TT=1. IF USER UTILIZES THE
NEW ROUTINES, THEN SETTING THIS TO OLD%TT=0 WILL INCREASE THE
EFFICIENCY OF TRAFFIC.
44 ADD NEW ROUTINE 'TFRFNO' USING THE CALL SEQUENCE:
ENTER MACRO TFRFNO USING FIELD-NAME, FIELD-NUMBER,ERROR.
THE FUNCTION OF THIS ROUTINE IS TO RETURN TO THE USER A
FIELD NUMBER BASED ON THE ASCII OR SIXBIT FIELD NAME SUPPLIED.
IF THE FIELD NAME IS NOT IN THE CURRENTLY INITIALIZED FORM, THEN
AN ERROR WILL BE RETURNED. SINCE SEARCHING FOR FIELD NAMES
IS EXPENSIVE, GENERATING FIELD NUMBERS IN THIS MANNER CAN GAIN
EFFICIENCY.
45 WHEN A MASTER DUPE FIELD IS WRITTEN (TFRWRT) OR WHEN IT
IS CREATED WITH TFRCHG, TURN ON THE 'MASTER DUP SET' FLAG
IF IT REALLY HAS DATA IN IT.
46 MONEY FIELDS WITH NO DOLLAR DIGITS DO NOT GET BLANK FILLED
CORRECTLY AND OVERWRITE DECIMAL POINT ON READ IF PREV-DUPE.
47 HAVING INSUFFICIENT NUMBER OF DATA PAGES RETURNS BAD ERROR
INDICATOR. FIX THIS.
50 ADD NEW ATTRIBUTE TO FIELD DESCRIPTION TO ALLOW FOR ZERO FILLED
NUMERICS (ACCOUNT NUMBERS, ETC.) USER MAY INCLUDE
LEADING-ZEROS
OR
NO-LEADING-ZEROS
TO A NUMERIC FIELD DESCRIPTION.
51 ON LOW BAUD RATE SYSTEMS, REWRITING NUMERICS RIGHT JUSTIFIED
IS NOT ALWAYS WANTED. INCLUDE A SWITCH TO DISABLE THIS FEATURE.
52 MAKE THE MEMORY GETTING/FREEING DYNAMIC AND VOID THE NECESSITY
OF SETTING DAT%SZ AND SYM%SZ.
53 MAKE IT POSSIBLE TO CHANGE SPECIFIC SYSTEM VARIABLES FROM THE
USER PROGRAM TO AVOID REASSEMBLY OF TFRCOB, SPECIFICALLY:
VAR# 1,OLDTT -- -1 IF SETTING TERMINAL CHARACTERISTICS ON
EACH CALL,
-- 0 IF SETTING ON DEMAND (FOR EFFICIENCY).
VAR# 2,OLDRN -- 0 REWRITE NUMERIC VALUES RIGHT JUSTIFIED.
-- -1 DO NOT REWRITE NUMERIC VALUES.
54 COMPENSATE FOR PROBLEM WITH V12 MEMORY MANAGEMENT WHICH MAY
GET FIXED. WHEN IT DOES, STATEMENTS WITH ;[54] MAY BE
REMOVED (EXCEPT THE ONE SO MARKED).
ALSO DEFINE NEW SWITCH COB%VR=0 FOR V12,=-1 FOR V11, =1
FOR UNDECIDED.
55 FIX PROBLEM WITH USING COBOL ACCEPTS (THEY DO NOT ECHO).
56 TFRERR ASSUMES MESSAGE (FIRST ARG) IS WORD ALIGNED. DUMB.
ALSO PRINT THE MESSAGE EVEN IF THE FIELD CANNOT BE RESET.
57 ADD ATTRIBUTE TO ALPHABETIC FIELD WHICH MAKES SPACES LEGAL.
OLD DOCUMENTATION INDICATED SHOULD BE SO, BUT WAS NOT.
60 ALLOW USER TO WRITE TO FIELDS WHICH ARE NOT INITIALIZED USING
TFRWRT. THIS ALLOWS A USER TO BACKUP ON A MULTIPART FORM
IN ORDER TO CHANGE INFORMATION. IT WILL STILL RETURN AN
ERROR INDICATOR (4) IF AN UNINITIALIZED FIELD IS FOUND, BUT IT
SHOULD BE TAKEN AS A WARNING. PUT THIS UNDER ASSEMBLY SWITCH
OLD%WR.
61 ALLOW LIMITED LOWER CASE. ALLOW TFRCOB TO BE ASSEMBLED WITH
LOWERCASE ALLOWED. THE LIMITATION IS THAT YES-NO FIELDS WILL
REQUIRE UPPER CASE, DATE FIELDS WILL REQUIRE UPPER CASE MONTHS,
AND RANGE CHECKING WILL BE IN COLLATING SEQUENCE ORDER. THIS
IMPLIES THAT WITH AN UPPER RANGE OF "ddddddd" (THAT WAS lowercase
FOR LISTINGS THAT ARE UPPER CASE ONLY) WILL PERMIT AN ENTRY
OF "ZZZZZZZ" (UPPER CASE) SINCE LOWER CASE IS A HIGHER
COLLATING SEQUENCE THAN UPPER CASE. THE USER WILL BE ABLE
TO DISABLE/ENABLE THIS VIA CALLS TO TFRSYS.
62 MAKE IT POSSIBLE TO TURN OFF THE INTERRUPT SYSTEM DURING
COBOL ACCEPT STATEMENTS SO THAT RUBOUT, AND CONTROL CHARACTERS
WORK. ADD CALL TFRRST (TFR-RESET)
63 ALL 'CALL TFRXXX USING' TO WORK AS WELL AS 'ENTER MACRO TFRXXX'.
64 STRUCTURE TERMINAL OUTPUT FOR BETTER EFFICIENCY LATER.
65 ERRORS WHEN SIXBIT FORM-NAMES ARE USED OF VARYING LENGTHS
AND IN CONJUNCTION WITH TFRERR MESSAGES. PROBLEM IS THAT
'INTBUF' GETS USED FOR BOTH AND IS NOT CLEARED.
66 TFR ALLUDES TO FACT THAT VALUE MAY CONTAIN MORE CHARACTERS
THAN ARE IN FIELD. THIS CAN LEAD TO COMPLICATIONS LATTER.
TFR SHOULD BE FIXED, BUT FIELD SHOULD ALSO BE CHECKED.
67 PUT IN SECTION AND FIELD TABLES WHICH BOUND THE SEARCH
OF THE FIELD TABLE TO A SUBSET OF IT AND THUSLY BOOST PERFORMANCE
ESPECIALLY WITH FORM WITH A LARGE NUMBER OF FIELDS.
70 CAUSE THE TFRERR MESSAGES TO BE TRUNCATED AFTER TRAILING
BLANKS LIKE COBOL DISPLAYS.
71 MAKE IT POSSIBLE FOR OPERATORS TO BACK UP FIELDS.
72 ALLOW CONTROL/C TRAPPING IF THE USER SPECIFIES IT
BY SETTING OLD%CC=-1 EITHER DURING ASSEMBLY OF VIA
A CALL TO TFRSYS.
73 FIX A COUPLE BUGS WITH EDIT 67 WHERE ILLEGAL FIELD NAMES
AND SECTION NUMBER CAN CAUSE UNTOWARD RESULTS (SOMETIMES).
74 TFR.MAC -- CHANGE TO MAKE IT ACCEPT EDIT FILES WITH PAGE
BREAKS IN THEM.
75 INCLUDE A TABLE OF FIELD NUMBERS IN THE FILE WITH THE RECORD
DESCRIPTION
76 ADD THE FIELD NUMBER TO THE SUMMARY FILE.
77 IF RUNNING UNDER VERSION 12 OF COBOL, THEN PUT CODE
OF TFRCOB INTO 'HIGH' SEGMENT
100 SOME ERRORS OCCURING IN THE RIGHT MOST COLUMN (80 ON VT52)
CAUSE THE CURSOR TO BE IMPROPERLY PLACED AFTER THE ERROR
MESSAGE.
101 IF NO FORM HAS BEEN INITIALIZED (OR AN ERROR WAS IGNORED),
MAKE THE FIND ROUTINE INFORM THE CALL OF 'NO FIELD' CONDITION.
102 ADD THE CANADIAN DATE DD/MM/YY
103 TFR PROBLEM -- TRAFFIC ERROR MESSAGES SOMETIMES MASK PROBLEMS
WHICH WOULD HAVE BEEN DETECTED IF SYSTEM (JSYS) ERROR
MESSAGE WERE OUTPUT
104 CONTROL/C NEVER GETS SET IF THE PROGRAM HAS SET OLDTT. MAKE
SURE CONTROL/C GETS SET IF WHEN THE FLAG GETS SET NOT AFTER.
105 CONTROL/S, CONTROL/Q ARE TRAPPED AND THUS NOT OPERATIONAL. ON
TERMINALS WHICH HAVE SILO'S THIS CAN LOOSE IF THE TERMINAL
SENDS A CONTROL/S WHEN ITS SILO FILLS UP. ALLOW THE DEFAULT
TO MAKE THIS OPERATIONAL, BUT ALLOW IT TO BE CHANGED WITH
TFRSYS.
106 RUBOUT IS NOT OPERATIONAL. THE REASON FOR RUBOUT NOT DOING
ANYTHING HAS BEEN LOST IN ANTIQUITY. AS A DEFAULT MAKE IT
ACT AS A BACKSPACE. IF THE USER WANTS IT TO DO NOTHING,
THEN ALLOW IT TO BE SET VIA TFRSYS.
107 TFR.MAC ONLY. ADD ADDITIONAL STUFF TO THE SUMMARY LISTING.
110 CHANGE THE WAY TRAFFIC STORES NEGATIVE NUMBERS FROM LEADING SIGN
TO OVERPUNCHED TRAILING DIGIT. THIS WILL INSURE THAT IT WORKS
IN ALL CASES. PROBLEMS REPORTED WITH PROGRAMS MOVING NEGATIVE
NUMBERS TO OTHER DATA TYPES OF FEWER DIGITS, AND SIGN GETTING
TRUNCATED. CANNOT CAUSE THIS UNLESS LEADING DIGIT IS ALSO
TRUNCATED, BUT THIS FIX WILL NARROW DOWN THE PROBABILITY.
ALSO DO SOME CLEAN UP WHERE THIS CHANGE TOUCHES OTHER THINGS.
111 FIX A PROBLEM WITH 110 WHICH CAUSES FIELDS WITH BLANK FILLERS
TO BE DONE WRONG. ANOTHER PROBLEM ASSOCIATED WITH CLEAN UP
AND CAUSING SUBFIELDS TO TERMINATE IMPROPERLY AFTER A TAB
WHEN IN FIRST DIGIT OF NEXT SUBFIELD.
^
ENTRY TFRINI,TFRCLR,TFRWRT,TFRRD,TFRERR,TFRCHG
ENTRY TFRSYS,TFRRST,TFRRWT,TFRSET,TFRFNO
SEARCH MONSYM,MACSYM
SEARCH TFRUNV
REMARK ASSEMBLY SWITCHES
; FTARGS==0 ............. DONT CHECK NUMBER OF ARGS
; FTARGS==1 ............. DO CHECK NUMBER OF ARGS
FTARGS==1
IFNDEF COB%VR, <COB%VR=+1> ;COBOL VERSION; 0=12,+1=11 AND 12
;[37] START OF SYMBOLS
;THE INTERPRETATION OF REQUIRED FIELDS HAS CHANGED
; FROM THE OLD (AND ERRONEOUS WAY). BUT BECAUSE
; PEOPLE MAY BE UTILIZING THESE LIMITATIONS AS
; FEATURES, THE OLD WAY CAN BE PRESERVED BY SETTING
; THE FOLLOWING SWITCHES TO -1.
IFNDEF OLD%TT, <OLD%TT=-1> ;[43]=-1 THEN TERMINAL MODE IS SET ON
;[43] EACH CALL TO A TFR??? ROUTINE.
;[43]THIS WILL INSURE THAT THE
;[43] TERMINAL CHARACTERISTICS ARE
;[43] SET PROPERLY. =0, THEN THIS
;[43]FAIRLY EXPENSIVE PROCEDURE IS
;[43]NOT DONE EXCEPT WHEN THE USER
;[43]EXPLICITLY CALL TFRSET.
IFNDEF OLD%CR, <OLD%CR=0> ;=0CARRIAGE RETURN GIVES 'END-INDICATOR'
; OF 5. IF -1, THEN GIVES VALUE OF 3.
IFNDEF OLD%AR, <OLD%AR=0> ;LEFT AND RIGHT ARROWS FUNCTIONS AS BACKSPACE
; AND TAB RESPECTIVELY. IF -1, THEN
; GIVES SAME 'END-INDICATOR' AS CR.
IFNDEF OLD%RQ, <OLD%RQ=0> ;REQD ATTRIBUTE IS INDEPENDENT
; OF ALL OTHERS.
IFNDEF OLD%YN, <OLD%YN=0> ;YES/NO FIELDS NOT NECESSARILY
; REQUIRED.
IFNDEF OLD%ZR, <OLD%ZR=0> ;BLANK FILL NUMERICS ON SCREEN
; WHEN RIGHT JUSTIFIED.
IFNDEF OLD%MD, <OLD%MD=0> ;IF USER BYPASSES AN OPTIONAL
; MASTER DUPE FIELD, DO NOT
; DELCARE IT MASTER DUPPED WITH
; BLANKS OR ZEROS.
IFNDEF OLD%PR, <OLD%PR=0> ;RESET THE ATTRIBUTES FROM THE
; FORM FILE WHENEVER A FIELD
; IS INITED.
IFNDEF OLD%RN, <OLD%RN=0> ;0=,THEN REWRITE NUMERICS RIGHT
; JUSTIFIED. ELSE DO NOT (THIS
; MAY BE DESIRABLE WITH EXPER-
; IENCED USERS ON SLOW TERMINALS.
IFNDEF OLD%WR, <OLD%WR=0> ;0=ALL TFRWRT TO FIELDS TO CAUSE
; INITIALIZATION (NEW)
;-1=TFRWRT TO UNITIALIZED FIELDS
; FAILS.
IFNDEF OLD%UD, <OLD%UD=0> ;0=UP/DOWN ARROW = CARRIAGE RETURN
IFNDEF OLD%LC, <OLD%LC=0> ;[61]0=NO LOWER CASE, -1 LOWER CASE.
IFNDEF OLD%CC, <OLD%CC=0> ;[72]0=NO CONTROL/C TRAPPING,
;[72]-1= CONTROL/C TRAPPING.
IFNDEF OLD%CS, <OLD%CS=-1> ;[105]0=NO ACTION ON CONTROL/S,CONTROL/Q
;[105]-1=ALLOW MONITOR XON/XOFF FUNCTIONALITY
IFNDEF OLD%RB, <OLD%RB=-1> ;[106]0=NO ACTION ON RUBOUT
;[106]-1=RUBOUT SAME AS BACKSPACE.
IF1, <FT2SEG==0 ;ONE SEGMENT CODE>
IF1 <
IFE COB%VR,<PRINTX TFRCOB WORKS ONLY WITH V12 OF LIBOL
FT2SEG==1 ;TWO SEGMENT CODE
>
IFE COB%VR+1,<PRINTX TFRCOB WORKS ONLY WITH V11 OF LIBOL>
IFE COB%VR-1,<PRINTX TFRCOB WORKS WITH BOTH V11 AND>
IFE COB%VR-1,<PRINTX V12 OF LIBOL>>
OPDEF PJRST [JRST] ;JRST TO ROUTINE WHICH RET'S
OPDEF EXTEND [123000,,000000] ;FOR KL
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
F=0 ;INTERNAL FLAGS
A=1
B=2
C=3
D=4
E=5
INT.A=6
INT.B=7
INT.C=10
.WD1=11 ;HOLD AREA FOR A FIELDS DATA WORDS
WD1=11
WD2=12
WD3=13
WD4=14
WD5=15
PRM=11
ARG=16
P=17
PG2ADR=^D9 ;SHIFT FOR PAGE# TO ADDRESS
ADR2PG=-^D9 ;SHIFT FOR ADDRESS TO PAGE#
RUBOUT=177 ;ASCII VALUE FOR RUBOUT
BACKSP=10 ;ASCII VALUE FOR BACKSPACE
REMARK ERROR CODE DEFINITIONS; RETURNED TO COBOL
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.FE==6 ;FATAL ERROR - INTERNAL GOOF
ERR.WL==7 ;WRONG LENGTH RECD DESC IN PGM.
ERR.DP==^D8 ;[35]PMAP FAILURE FROM FORM FILE.
; ERR.SP==^D9 ;[35]NOT ENOUGH PAGES ALLOCATED
ERR.NC==^D10 ;[35]LIBOL DID NOT RETURN ENOUGH PAGES.
ERR.IV=^D11 ;[53]TFRSYS CALL WITH BAD VARIABLE#
ERR.NV=^D12 ;[53]TFRSYS CALL WITH NEW-VALUE NOT 0,-1.
DEFINE LBL(N)
<
HISTEP=N
>
DEFINE LABELZ(HI,LO)
<
%'HI'.'LO': >
;[40] DEFINE HIPO(STEPX,MSG,NEXTX)
;[40]<
;[40]IFNB <STEPX>,<
;[40]LABELZ \HISTEP,STEPX>
;[40] >;END DEFINE HIPO
REMARK DEFINE INTERNAL STORAGE LOCATIONS
REMARK GENERATE THE REQUIRED POINTERS TO DATA & STRINGS
DEFINE LOAD(REX,PTR,TMP<E>)
<
MOVE TMP,PTR
ADDI TMP,.WD1
LDB REX,TMP
>
DEFINE STORE(REG,PTR,TMP<E>) ;STORE A VALUE AWAY
<
MOVE TMP,PTR ;GET THE RELATIVE POINTER
ADDI TMP,.WD1 ;ADD IN REG DISPLACEMENT
DPB REG,TMP ;SAVE VALUE IN REGS.
MOVE TMP,PTR ;GET PTR AGAIN
ADD TMP,FLDPTR ;POINT TO CORE TABLE
DPB REG,TMP ;& SAVE THERE TOO.
> ;END OF STORE
;;; DO NOT EXPAND MACROS
;;;
IFN FT2SEG,<TWOSEG
RELOC 400000> ;RELOC TO HI SEG IF REENTRENT SWITCH ON.
PTRGEN
HICOLM: ^D80 ;HIGHEST COLUMN ALLOWED
CURFRM: POINT 7,FRMFIL ;POINTER TO CURRENT FORM STRING.
TXTNUM: ;NUMERICS ONLY - BREAK ON ALL OTHERS
-1 ;0 - 37
^B111111111111111100000000001111111111 ;NUMERICS
-1
-1
TXTAN: ;ALPHANUMERICS A-Z AND 0-9
-1 ;0 - 37
0 ;SPECIAL CHAR & NUMERICS
^B1 ;UPPER CASE, BRACKETS, BACKSLASH
-1
TXTA: ;ALPHABETICS ONLY!
-1
-1
^B100000000000000000000000000111111111
-1
REMARK INTERNALLY GENERATED ERROR MESSAGES FOLLOW (INTERR)
MSG.NN: ASCIZ ^ENTER NUMBERS ONLY^
MSG.NA: ASCIZ ^ENTER LETTERS OR NUMBERS ONLY^
MSG.AO: ASCIZ ^ENTER LETTERS ONLY^
MSG.RQ: ASCIZ ^A VALUE MUST BE ENTERED^ ;;[3] SPELLING FIX
MSG.FF: ASCIZ ^FIELD MUST BE FILLED^
MSG.ID: ASCIZ ^INCORRECT DATE^
MSG.YN: ASCIZ ^ENTER Y OR N^
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 ^
CHNTAB: 1,,IGNORE ;;[2] IGNORE IS HIGHEST PRIORITY
;[15] 2,,TYPEIN ;;[2] TYPEIN IS DEFERRED
;TYPIN DONE - CLEAR ERROR LINE
IGNORE: DEBRK ;;[2] IGNORE IS AN ACTIVE CHANNEL
REMARK TERMINATOR CODES (TFRRD - INTRD)
TRM.LN==1
TRM.TB==2
TRM.LF==3
TRM.FF==4
TRM.CR==5
REMARK TABLES FOR RANGE CHECKING
DEFINE TBL(ENT,PTR)
< [ASCIZ ^ENT^],,PTR >
DEFINE .CALL.
< SKIPA 777 ;[63]ALLOW 'CALL' STATEMENTS
XWD [0],%FILES> ;[63] TO WORK.
DEFINE ENTER(NAME,NUMARG,NUMAR2,%%OK) ;[7]
< ;[7]
NAME:: ;[7] DEFINE ENTRY POINT
.CALL. ;[63]COBOL 'CALL' ENTRY.
IFN FTARGS,< ;[7]
HLRE A,-1(ARG) ;[7] GET MINUS ARG NUMBER
MOVMS A ;[7] GET MAGNITUDE
IFNB <NUMAR2>,< CAIE A,NUMAR2> ;[7]
CAIN A,NUMARG ;[7] RIGHT NUMBER ?
JRST %%OK ;[7] YES - ALL OK
TMSG <?NAME CALLED WITH WRONG NUMBER OF ARGS> ;[7]
HALTF ;[7]
%%OK: ;[7]
> ;[7]
SKIPE OLDTT ;[55]IF WE MUST CHECK TERMINAL STATUS
CALL $TTCHK ;[55] ON EACH CALL, DO IT (ALAS).
> ;END ENTER ;[7]
REMARK TFRCHG ATTRIBUTE TABLES
CGTBL: ^D12,,^D12
TBL <ALPHABETIC>,CGAB
TBL <ALPHANUMERIC>,CGAN
TBL <LOWER-RANGE>,CGLR
TBL <MASTER-DUPE>,CGMD
TBL <NO-DUPE>,CGND
TBL <NUMERIC>,CGN
TBL <OPTIONAL>,CGO
TBL <PREVIOUS-DUPE>,CGPD
TBL <PROTECTED>,CGP
TBL <REQUIRED>,CGR
TBL <UNPROTECTED>,CGUP
TBL <UPPER-RANGE>,CGUR
;[16]
COMMENT +
BUILD UP TABLES FOR CHECKING THE DATE FIELDS FOR
LEGAL FORMAT.
THEY ARE:
MMMTAB -- ASCII 3 LETTER APPREVIATION FOR MONTH
MNMTAB -- ASCII 2 DIGIT NUMBER OF MONTH
MLDTAB -- ASCII 2 DIGIT MAX DAYS IN MONTH
+
DEFINE MONTHS,<
MM JAN,01,31
MM FEB,02,29
MM MAR,03,31
MM APR,04,30
MM MAY,05,31
MM JUN,06,30
MM JUL,07,31
MM AUG,08,31
MM SEP,09,30
MM OCT,10,31
MM NOV,11,30
MM DEC,12,31 >
DEFINE MM (A,B,C),<
"A">
MMMTAB: MONTHS
DEFINE MM (A,B,C),<
"B">
MNMTAB: MONTHS
DEFINE MM (A,B,C),<
"C">
MLDTAB: MONTHS
;[16] END OF MONTH TABLES FOR EDIT [16]
SALL
SUBTTL TFRINI - INITAILIZE CALL FROM COBOL
LBL 2
COMMENT +
CALL TFRINI (REC-PTR TFR-PTR FIELD-ID ERR)
RETURN (ERR)
+
TFRINI:
ENTER FRMINI,4 ;[7]
CALL $TTOPN ; THEN OPEN IT (SETS TTOPN TO -1).
CALL $SBEGIN ;[64]SETUP THE OUTPUT BUFFER
SETOM COBCAL ;INDICATE COBOL CALL
MOVE A,@0(ARG) ;GET RECORD POINTER
MOVEM A,RECPTR ;AND SAVE IT
CALL CHKFORM ;USING CURRENT FORM FILE ?
JRST %2.14 ;GOOD FORM NAME BUT NO FIELDS IN IT.
JRST %2.14A ;COULD NOT LOAD THE FORM.
JFCL ;EVERYTHING IS IN GOOD SHAPE.
%2.3: ;ON COBOL CALL, SETUP TO FIND THE FIRST FIELD.
MOVEI INT.A,@2(ARG) ;GET W.S. POINTER
HRRZ INT.B,1(INT.A)
MOVE INT.A,0(INT.A)
SKIPA ;SKIP COBCAL SETTING
INITAL: ;INTERNAL CALL TO INIT EVERYTHING
;INT.A MUST HAVE FIELD PTR
SETZM COBCAL ;INDICATE INTERNAL CALL
CALL FIND
JRST %2.14 ;NOT FOUND
JRST %2.11 ;NO MORE FIELDS
JFCL ;GOT A FIELD
SKIPE COBCAL ;[22] IF WE ARE IN AN INIT CALL
CALL GETPRM ;[22] THEN SET UP NEW STATUS BITS.
TXNE PRM,MSDUP% ;IF MASTER DUPE IS ON
TXZ PRM,PRDUP% ; THEN RESET TO INDICATE NOT FILLED.
TXNE PRM,PROT% ;IF A PROTECTED FIELD
JRST %2.8 ; THEN DO NOT REFORMAT.
CALL FORMAT ;FORMAT FIELD IN WORKING-STORAGE
;[41] CALL WS2VAL ; AND THEN REFORMAT INTERNAL VALUE.
%2.8: ;;WRITE THE FIELD TO THE SCREEN
TXNN PRM,%DSPLY ;IF THE FIELD IS NOT ON THE SCREEN
;[111] --AT LINE %2.8+4 IN SOURCE
JRST [TXNE PRM,PROT% ;[111]IF PROTECTED FIELD
CALL WRITE ;[111] THEN WRITE OUT FIELD
CALL FILL ; AND THEN FILL OUT REST
JRST %2.10] ; AND CONTINUE.
TXNN PRM,PROT% ; ELSE IF FIELD IS UNPROTECTED
CALL BLANK ; MERELY BLANK IT.
%2.10: ;;INDICATE FIELD IS ON THE SCREEN
TXO PRM,%DSPLY
TXNE PRM,PROT% ;DON'T SAY PROT FIELDS ARE EMPTY!!
JRST %2.10A
SETZ A,
CALL SV.NUMRD
%2.10A:
CALL STRPRM ;STORE PARAMETERS BACK
CALL $SCHKPNT ;[64]WRITE OUT BUFFER IN ROOM NEEDED
SKIPE COBCAL ;COBOL CALL ?
JRST %2.3 ;YES--GO FOR MORE FIELDS
JRST INITAL ;NO--RETURN FOR NEXT FIELD,
%2.11: ;NO MORE FIELDS TO INITIALIZE
;[41] CALL $HOME ;HOME THE CURSOR
CALL $SEND ;[64]SEND TERMINAL MESSAGE.
SETZB A,CURERR ;INITIALIZE TO 'NO ERROR'.
SKIPE LENERR ;ANY LENGTH ERRORS
JRST [SETZM LENERR
MOVEI A,ERR.WL
JRST .+1]
SKIPE COBCAL ;SKIP IF NOT COBOL CALL
MOVEM A,@3(ARG)
RET
%2.14: ;;RETURN THE 'NOT FOUND' ERROR
MOVEI A,ERR.NF ;NOT FOUND !
%2.14A: ;;ERROR RETURN -- CONTENTS OF A INDICATES WHICH.
MOVEM A,CURERR
SKIPE COBCAL
MOVEM A,@3(ARG) ;NOT FOUND ERROR
RET
PAGE
CHKFORM: ;CHECK CALLER'S FORM DESCRIPTION AND OPEN
; NEW FORM FILE IF NECESSARY.
MOVEI B,@1(ARG) ;FORM PTR
HRRZ A,1(B) ;COBOL LENGTH
MOVE B,0(B) ;BYTE PTR
TLNN B,100 ;ASCII ?
CALL INT627 ;NO - CONVERT SIXBIT TO ASCII IN INTBUF
MOVEI D,130 ;DEST LENGTH IN BYTES
MOVE E,CURFRM ;BUFFER PTR
SKIPE GOTFIL ;[35] IF NO FILE, THEN NO COMPARE
EXTEND A,[CMPSE ;COMPARE-SKIP EQ
" " ;SPACE FILL BOTH
" "]
SKIPA ;NOT THE SAME--OPEN NEW FILE.
JRST SKPRT2 ;GIVE GOOD RETURN.
CALL INITAB ;[67]INITIALIZE THE SECTION/FIELD TABLES
MOVEI INT.A,@1(ARG) ;POINTER TO NAME DATA BLOCK
CALL GETFIL ;GET JFN FOR FILE + OPEN
JRST [MOVEI A,ERR.UF ;UNKNOWN FILE NAME
SETZM GOTFIL ;[65]ON ERROR INDICATE NO FILE NAME.
JRST SKPRT1] ;INDICATE UNKNOWN FILE NAME.
JFCL ;FILE FOUND AND OPENED.
CALL SETINT ;ENABLE FOR INTERUPTS
CALL MAPIN ;MAPIN THE DATA FILE
JRST SKPRT1 ;[35]NOT ENOUGH MEMORY FOR FORM.
;[35] LDB A,.NMFLD ;GET NUMBER OF FIELDS
MOVE B,.NMFLD ;[35]GET THE POINTER TO #FIELDS
SUB B,V11DAT ;[35] OFFSET TO NEW PAGE
ADD B,V12DAT ;[35]
LDB A,B ;[35]
MOVEM A,HIFLD ;SAVE IT
; COPY ALL DATA TO WORKING-STORAGE
%2.18:
SETZ INT.A, ;FLD-PTR = 0; DO ALL FLDS ON INIT
CALL FIND ;FIND A DATA FIELD
RET ;NO FIELDS FOUND -- RETURN AN ERROR.
JRST %2.A20 ;NO MORE, WE ARE DONE.
JFCL ;WE FOUND IT.
CALL LD.NUMRD ;[66]GET NUMBER OF CHARS IN FIELD.
MOVE B,LENFLD ;[66] AND LENGTH OF FIELD
CAILE A,(B) ;[66]IF NUM .GT. LENGTH
MOVEI A,(B) ;[66] THEN TAKE LENGTH
CALL SV.NUMRD ;[66] AND SAVE THE LENGTH
CALL SETTAB ;[67]SETUP SECTION AND FIELD TABLES
CALL GETPRM ;SET UP THE 'PRM' AC.
CALL FORMAT ;FILL WORKING STORAGE WITH SPACES OR ZEROS.
TXNN PRM,%PROT ;IF FIELD IS UNPROTECTED
JRST %2.18 ; THEN DO NO FURTHER PROCESSING.
CALL LD.NUMRD ;GET NUMBER CHARS IN FIELD
CALL REFORM ;MOVE DATA FROM 'VALUE' TO WORKING
JFCL ; STORAGE.
JRST %2.18
%2.A20: ;;VERIFY RECORD LENGTH IS CORRECT
SETZM LENERR
LOAD A,.OFFST ;OFFSET OF LAST FIELD
ADD A,LENFLD ;PLUS LENGTH
MOVEI B,@0(ARG) ;SHOULD EQUAL ...
HRRZ B,1(B) ;... LENGTH OF RECORD.
CAME A,B ;THEY SHOULD BE EQUAL.
SETOM LENERR
;[35] LDB A,.ERRNM
MOVE B,.ERRNM ;[35] GET ERROR LINE NUMBER AFTER
SUB B,V11DAT ;[35] BY OFFSETTING
ADD B,V12DAT ;[35] TO THE PROPER PAGE
LDB A,B ;[35]AND THEN APPLYING THE BYTE POINTER.
SKIPN A ;SKIP IF NON-ZERO
CALL SETERL ;IF ZERO, SET ERR-LINE IN A
MOVEM A,ERRLIN
;CLEAR THE SCREEN AND THE INPUT BUFFER.
CALL $CLEAR
CALL $CLIBF ;CLEAR THE INPUT BUFFER.
JRST SKPRT2 ;RETURN TO CALLER.
PAGE
SUBTTL TFRINI -- SECOND LEVEL SUBROUTINES
GETPRM: ;[22] ROUTINE TO RESET THE TEMPORARY ATTRIBUTES OF THE FIELD
;[22] WITH THE INITIAL (FORM DEFINED) STATUS.
LDB A,[POINT 5,PRM,23] ;[22] GET REQ,FULL,PROT,MSD,PRED
DPB A,[POINT 5,PRM,13] ;[22] AND PLACE IN TEMPORARY POSITIONS.
LDB A,[POINT 4,PRM,31] ;[22] GET RANGU,RANGL,ALPHA,NUMER
DPB A,[POINT 4,PRM,17] ;[22] AND PLACE IN TEMPORARY POSITIONS.
SKIPN OLDRQ ;[37]IF NEW REQUIRED INTERPRETATION
RET ;[22] RETURN TO CALLER
TXNE PRM,%YN ;[37] ELSE SET REQUIRED IF
TXO PRM,REQD% ;[37] YES/NO
TXNE PRM,%RANGE ;[37] RANGE CHECKING
TXO PRM,REQD% ;[37]
TXNE PRM,%FULL ;[37] FULL FIELD NEEDED.
TXO PRM,REQD% ;[37]
RET ;[37]
SETINT:
MOVEI A,.FHSLF
RIR
HRLI B,0
MOVE A,CHNTAB
MOVEM A,0(B)
;[15] MOVE A,CHNTAB+1
;[15] MOVEM A,1(B)
RET
RSTINT:
RET
SKPRT2: AOS (P) ;RETURNS
SKPRT1: AOS (P)
RET
PAGE
;[67] INITIALIZE AND SET UP FIELD/SECTION TABLES FOR PERFORMANCE
INITAB: ;INITIALIZE THE TABLES
SETZM SECTAB ;INITIALIZE THE SECTION TABLE
MOVE A,[SECTAB,,SECTAB+1] ;BY STORING ZEROS IN IT.
BLT A,SECTAB+^D28
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
CALL SETFLD ;SET THE FIELD TABLE
RET
SETSEC: ;SET THE SECTION TABLE.
;THE SECTION TABLE HAS 28 ENTRIES INDEXED BY THE
; SECTION NUMBER.
LOAD B,.SECTN ;GET THE SECTION BITS FOR THIS FIELD
SETZ A, ;INITIALIZE SECTION TABLE INDEX.
MOVE C,CURFLD ;GET NUMBER OF CURRENT FIELD.
SKIPA ;SKIP OVER NEXT INSTRUCTION
SETSLP: LSH B,-1 ;PUT NEXT SECTION BIT IN LOW ORDER POSITION.
SKIPN B ;IF NO MORE SECTIONS
RET ; THEN DONE
AOS A ;INCREMENT SECTION TABLE INDEX
TRNN B,1 ;IF THIS SECTION DOES NOT HAVE BIT SET
JRST SETSLP ; THEN GO TO NEXT SECTION
SKIPN SECTAB(A) ; ELSE IF FIRST FIELD IN THIS SECTION
HRLM C,SECTAB(A) ; THEN STORE FIELD NUMBER IN LH.
HRRM C,SECTAB(A) ; AND STORE IN RH ANYWAY.
JRST SETSLP ;NEXT FIELD.
PAGE
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
SUB B,V11SYM ;OFFSET TO THE CORRECT
ADD B,V12SYM ; TO THE CORRECT PAGE
HRLI B,(POINT 7,0) ;MAKE 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
CALL MOV6OR7 ;MOVE FIELD NAME TO INTBUF IN ASCII
SETZB A,B ;AND FILL OUT REST OF THE AREA
EXTEND A,[MOVSLJ ;WITH SPACES
" "]
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
;[67] END OF TABLE SETTING ADDITION
SUBTTL INITSD - INIT NON-DUPED FIELDS
LBL 3
INITSD:
;FIND THE NEXT FIELD
CALL FIND ;INT.A MUST BE SET-UP
RET ;FIELD NOT FOUND
JRST SKPRT1 ;NO MORE FIELDS.
JFCL ;FIELD IS FOUND.
TXNN PRM,%DSPLY ;IF FIELD IS NOT ON THE SCREEN
JRST INITSD ;[17] THEN BYPASS IT.
TXNE PRM,PRDUP% ;[24]IF THIS IS A PREVIOUS DUPE FIELD
JRST INITSD ;[24] OR MASTER DUPE WITH FLAG SET THEN BYPASS IT ALSO.
TXNE PRM,PROT% ;[24]IF THIS IS A PROTECTED FIELD.
JRST INITSD ; THEN SKIP THIS FIELD.
CALL FORMAT ;OTHERWISE BLANK OUT WORKING STORAGE.
CALL BLANK ;THEN SEND BLANKS TO THE SCREEN.
;[41] CALL WS2VAL ;COPY WORKING STORAGE BACK TO THE LOCAL
SETZ A, ;AND FINALLY INDICATE ZERO CHARACTERS
CALL SV.NUMRD ; IN THE FIELD.
CALL $SCHKPNT ;[64]WRITE IT OUT IF ROOM NEEDED
JRST INITSD ;THEN LOOP FOR NEXT FIELD.
SUBTTL WRITE - WRITE A FIELD TO THE SCREEN
WRITE:
CALL LD.NUMRD ;GET NUMBER OF CHARS IN FIELD.
SKIPG C,A ;ANY TO WRITE ?
RET ; NO!
DMOVE A,LINFLD ;LINE AND COLUMN ON SCREEN
CALL $POSIT ;MOVE THE CURSOR THERE.
TXNN PRM,%SSN!%DATE!%MONEY ;SPECIAL SUB-FIELD WRITE ?
JRST WRT1FD ;NO - JUST DO ONE
MOVEM C,YET2WT ;# REMAINING TO WRITE
SUBWRT: ;HANDLE SUB-FIELD WRITES
CALL SUBFLD
RET ;DONE
JUMPE C,SUBWR5 ;PUNT THE EMPTY FIELDS
CAMLE C,YET2WT ;ENOUGH LEFT TO WRITE?
MOVE C,YET2WT ;NO-USE THOSE LEFT
JUMPE C,RSTRET ;PUNT IF NO MORE DESIRED
MOVN E,C ;SUB FROM # REM
ADDM E,YET2WT
REMARK SEPR CHAR IF NEEDED
SUBWR5: MOVE E,SUBY
SOSLE E
CALL SEPCHR
CALL WRT1FD ;WRITE 1 FIELD
JRST SUBWRT ;AND GO FOR NEXT
WRT1FD:
MOVE B,VALFLD ;FORM W.S. POINTER
CALL $SSTRING ;[64]SEND STRING TO TERMINAL
RET ;GO BACK
SUBTTL FORMAT - PUT SPACES INTO WORKING STORAGE
;[42] THIS ROUTINE WILL FILL WORKING STORAGE WITH
;[42] SPACES FOR ALPHA AND ALPHANUMERIC FIELDS AND
;[42] WITH ZEROS FOR NUMERIC FIELDS
FORMAT:
MOVE E,OFFFLD
MOVE D,LENFLD ;GET LENGTH
MOVEI A," " ;ASSUME BLANK FILL UNLESS
TXNE PRM,NUMER% ; THE FIELD IS NUMERIC AND
MOVEI A,"0" ; 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
;[10]
COMMENT + THIS SECTION ADDED FOR EDIT [10] AND CAUSES NUMERIC
VALUES STORED IN PROTECTED FIELDS BY THE
"VALUE ...." CLAUSE IN THE FORM FILE TO BE
RIGHT JUSTIFIED. WITHOUT THIS EDIT, ALL SUCH
VALUES ARE LEFT JUSTIFIED
+
SUBTTL REFWRT - REFORMAT AND WRITE FIELD TO SCREEN.
REFWRT:
TXNN PRM,PROT% ;IF THIS IS NOT A PROTECTED FIELD
RET ; THEN DO NOTHING.
CALL LD.NUMRD ;GET NUMBER OF CHARS IN FIELD.
CALL REFORM ; ELSE JUSTIFY IN MEMORY.
JFCL ;NO BOTHER
CALL WRITE ;WRITE TO THE SCREEN
RET ;ALL DONE
; END OF [10] EDIT
SUBTTL FIND - FIND THE NEXT DESIRED FIELD
LBL 11
COMMENT +
CALL FIND (FLD-ID)
NOT FOUND ERROR
NO MORE THIS TYPE
RETURN (CURFLD SET)
+
FIND:
SKIPN GOTFIL ;[101]IF NO FORM INIT HAS BEEN DONE
JRST %11.14 ;[101] 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,%11.12 ;IF ZERO THEN IS A FORM.
HLRE A,INT.A ;LEFT HALF WILL INDICATE TYPE.
JUMPE A,%11.7 ;IF ZERO, THEN IT IS A FIELD NUMBER.
AOJE A,%11.5 ; THIS IS A SECTION NUMBER.
JRST %11.9 ;OTHERWISE IT IS A FIELD NAME.
PAGE
;;;;;;;;;;;;;;;;;; USER HAD SPECIFIED A SECTION NUMBER ;;;;;;;;;;;;;;;;
%11.5:
SKIPE SECTAB ;[67]IF NOT FIRST FIELD IN SECTION
JRST %11.6 ;[67] THEN INITIALIZATION DONE.
MOVN A,INT.A ;[67]SECTION NUMBER BEING REQUESTED
CAILE A,^D28 ;[67]LEGAL ?
JRST %11.13 ;[67] NO
SKIPN A,SECTAB(A) ;[67]GET BEGINNING,,ENDING FIELD NUMBERS.
JRST %11.13 ;[67]ZERO--NO FIELDS THIS SECTION.
HRRZM A,SECTAB ;[67]SAVE ENDING FIELD NUMBER.
HLRZS A ;[67]GET BEGINNING FIELD #
SOS A ;[67]MAKE IT THE CURFLD-1
MOVEM A,CURFLD ;[67] AND UPDATE CURRENT FIELD #
%11.6:
CALL GETNXT ;GET NEXT DATA FIELD
JRST %11.13 ;NO MORE FIELDS.
JFCL ;GOT ONE.
MOVE A,CURFLD ;[67]IF THE CURRENT FIELD NUMBER
CAMLE A,SECTAB ;[67] IS NOT LESS THAN HIGHEST FIELD #
JRST %11.13 ;[67] IN SECTION, THEN WE ARE DONE.
;;DETERMINE IF WE ARE IN THE CORRECT SECTION.
MOVE C,.SECTN ;FORM SECTION POINTER
ADDI C,.WD1
LDB B,C ;FORM SECTION # - 1
MOVN C,INT.A ;FORM SEC # - 1
SOJ C,
MOVEI A,1 ;START WITH SECTION 1
LSH A,(C) ;SHIFT (C) PLACES
TDNE B,A ;SEE IF BIT IS ON
JRST [MOVE A,CURFLD ;THEN THIS IS A PROPER SECTION.
JRST %11.16] ;GOOD SECT = GO DO SET UP OF WD?
JRST %11.5 ;FIELD NOT IN DESIRED SECTION.
PAGE
;;;;;;;;;;;; USER SPECIFIED A SPECIFIC FIELD NUMBER ;;;;;;;;;;;;;;;;
%11.7:
SKIPE CURFLD ;IF FIELD ALREADY FOUND
JRST %11.15 ; THEN FINISH UP.
MOVE A,INT.A ;IF CURRENT FIELD IS
CAMLE A,HIFLD ; .GT. HIGHEST FIELD
JRST %11.14 ; THEN FINISH UP.
;;GET POINTER TO CURRENT FIELD
SOJ A, ;CURFLD-1
MOVEM A,CURFLD
CALL GETNXT ;REALLY GET CURRENT FIELD
JRST %11.14 ;IF HERE, WE GOT TROUBLE
JRST %11.16
PAGE
;;;;;;;;;;;;;;;;;;;;;;;; USER SPECIFIED FIELD NAME ;;;;;;;;
%11.9: ;;SAVE FIELD IN 'INTBUF' WITH TRAILING NULL
SKIPE CURFLD ;[67]IF CURRENT FIELD IS NOT 0,
JRST %11.13 ;[67] THEN WE HAVE BEEN HERE ALREADY.
MOVE B,INT.A
MOVE A,INT.B
CALL FLDHSH ;[67]HASH THE NAME
HLRZ A,FLDTAB(B) ;[67]GET THE STARTING FIELD
JUMPE A,%11.13 ;[73]IF NOTHING IN ENTRY, THEN ILLEGAL
SOS A ;[67] AND SET IT ONE BACK SO THAT
MOVEM A,CURFLD ;[67]WE CAN START IN THIS POSITION.
HRRZ A,FLDTAB(B) ;[67]GET THE LAST FIELD WITH THIS HASH
MOVEM A,FLDTAB ;[67] AND STORE IT INTO FLDTAB(0).
%11.10: CALL GETNXT ;SETUP THE NEXT FIELD.
JRST %11.13 ;NO MORE FIELDS.
JFCL ;GOT ONE
MOVE A,CURFLD ;[67]IF THE CURRENT FIELD NUMBER
CAMLE A,FLDTAB ;[67] IS ALREADY GREATER THAN THE LAST
JRST %11.13 ;[67] POSSIBLE, THEN STOP LOOKING.
LOAD B,.FIELD,C ;CHECK THIS FIELD
SUB B,V11SYM ;[35]OFFSET TO THE CORRECT
ADD B,V12SYM ;[35] PAGE.
HRLI B,(POINT 7,0)
MOVEI A,^D30 ;[67] AND THE LENGTH OF THE NAME TO 'A'.
MOVEI D,(A) ;[67]USE SAME LENGTH HERE
MOVE E,[POINT 7,INTBUF+8] ;[67]
CALL MOV.7 ;[67]MOVE THE STUFF TO INTBUF+8
SETZB A,B ;[67]AND NOW FILL IT UP WITH
EXTEND A,[MOVSLJ ;[67] BLANKS
" "] ;[67]
JFCL
DMOVE A,[^D30 ;[67]PREPARE TO COMPARE
POINT 7,INTBUF];[67] THE STUFF IN INTBUF
DMOVE D,[^D30 ;[67]WITH THE STUFF IN
POINT 7,INTBUF+8] ;[67] IN INTBUF+8
EXTEND A,[CMPSE ;[67]
" " ;SPACE FILL BOTH
" "] ; FIELDS
JRST %11.10 ;FIELDS ARE NOT THE SAME
JRST %11.16 ;FIELDS ARE THE SAME.
PAGE
;;;;;;;;;;;;;;;;;;;; USER SPECIFIED A FORM ;;;;;;;;;;;;;;;;;;;;;
%11.12:
CALL GETNXT ;GET THE NEXT FIELD.
JRST %11.13 ;NO MORE.
JRST %11.16 ;GOT ONE.
;;;;;;;;;;;;;;;;;; COMMON EXIT ROUTINES USED BY ALL ;;;;;;;;;;;;;;;;;;
%11.13: ;;NO FIELD (DETERMINE IF 'NONE' OR 'NO MORE'.
SETZM SECTAB ;[67]INDICATE FINISHED WITH SECTION.
SKIPE FRSTFD ;IF THIS IS NOT THE FIRST FIELD
JRST %11.15 ; THEN NO MORE FIELDS
JFCL ; ELSE RETURN 'NO FIELD FOUND'.
%11.14: ;;NO FIELD WAS FOUND TO MATCH SPECIFICATION.
SETZM CURFLD ;DONE THIS PASS
RET ;NON-SKIP
%11.15: ;;AT LEAST ONE FIELD WAS FOUND, BUT NONE ARE LEFT.
SETZM CURFLD ;DONE THIS PASS
JRST SKPRT1 ;RETURN TO CALL + 2.
%11.16: ;;HERE WHEN FIELD HAS BEEN FOUND TO MATCH.
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
ADDI A," "
MOVEM A,FILCHAR
LOAD A,.LENG ;SET UP THE FIELD LENGTH.
LOAD B,.VALUE ;SET UP POINTER TO THE VALUE.
SUB B,V11SYM ;[35]OFFSET TO THE CORRECT
ADD B,V12SYM ;[35] PAGE.
HRLI B,(POINT 7,0)
DMOVEM A,LENFLD
MOVEM A,FULLEN ;SAVE FULL LENGTH OF FIELD
LOAD A,.OFFST
IBP A,RECPTR ;POINT TO REC IN W.S.
MOVEM A,OFFFLD
JRST SKPRT2 ;RETURN TO CALL+3.
SUBTTL GETNXT - GET NEXT FIELD AND PUT DATA INTO WD1 - WD5
LBL 12
COMMENT +
CALL GETNXT - NO ARGS
NO MORE FIELDS
RETURN-OK CURFLD SETUP; WD1 - WD5 LOADED
+
GETNXT:
AOS A,CURFLD ;BUMP FIELD COUNTER
CAMLE A,HIFLD ;IF FIELD # TOO LARGE
RET ; THEN PROCESS IS DONE.
;CALC POINTER TO DATA = DATA + (FLDLEN*(CURFLD-1))
MOVE B,CURFLD ;FORM FIELD-1
SOJ B,
IMULI B,FLDLEN ;TIME FLD LENGTH
;[35] ADDI B,DATA ;+ DATA = PTR TO FIELD
ADD B,V12DAT ;[35] GET THE STARTING PAGE
ADDI B,2 ;[35] AND THEN OFFSET IT.
MOVEM B,FLDPTR ;SAVE FOR STRPRM
DMOVE WD1,(B) ;LOAD WD1-WD5 WITH FIELD'S DATA.
DMOVE WD3,2(B) ;WD3 - WD4
MOVE WD5,4(B) ;WD5
AOS (P)
RET
STRPRM:
;;STORE THE FLAG REGISTER (PRM) BACK INTO THE
;; FIELD AREA FOR SAVING BETWEEN CALLS
SKIPE OLDPR ;[37]IF FIELDS ARE TO REMAIN
CALL STRP50 ;[35] THEN MAKE ALL TEMPORARY CHANGES
;[35] PERMINENT.
MOVEM PRM,@FLDPTR ;STORE PRM BACK IN DATA
RET
STRP50:
PUSH P,A ;[37]
LDB A,[POINT 5,PRM,13] ;[37] REQ,FULL,PROT,MSD,PREDUP
DPB A,[POINT 5,PRM,23] ;[37]
LDB A,[POINT 4,PRM,17] ;[37] RANGU, RANGL, ALPHA,NUMER
DPB A,[POINT 4,PRM,31] ;[37]
POP P,A ;[37]
RET ;[37]
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 ;[21]
;[21] RET ;IGNORE ERRORS
;[21] BEGIN EDIT WHICH FIXES NUMERICS AND BLANKS LEADING ZEROS
TXNN PRM,NUMER% ;IF THIS IS NOT A NUMERIC
RET ; THEN RETURN
TXNE PRM,%DATE+%SSN ;IF THIS IS A DATE OR SSN
RET ; THEN RETURN,
MOVE A,LENFLD ;INDICATE THAT THE FIELD
CALL SV.NUMRD ; IS THE FULL LENGTH OF THE FIELD.
MOVEI Z," " ;INDICATE BLANKING DESIRED
SKIPE OLDZR ;[37]IF NOT BLANKING LEADING ZEROS
MOVEI Z,"0" ;[37] THEN INDICATE THAT.
TXNE PRM,%ZERBL ;[50]IF USING LEADING ZEROS
MOVEI Z,"0" ;[50] THEN INDICATE THAT.
CALL REPZER ;REPLACE ZEROS
RET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
REPZER: ;ROUTINE TO REPLACE LEADING ZEROS WITH BLANKS
;AND PUT IN STANDARD NUMERIC FORM
SETZM ISNEG ;INDICATE NUMBER NOT NEGATIVE.
MOVE A,LENFLD ;GET LENGTH OF FIELD
ADJBP A,VALFLD ;GET BYTE POINTER TO LAST CHAR.
LDB B,A ;GET LAST CHARACTER OF FIELD
MOVE C,CHRTAB(B) ; AND DETERMINE IF NUMERIC.
TRNE C,NUMCHR ;IF IT IS NUMERIC
JRST WS2V50 ; THEN CONTINUE
SUBI B,31 ;IF NOT TURN IT INTO A NUMERIC.
MOVE C,CHRTAB(B) ; OVERPUNCHED MINUS SIGN.
TRNN C,NUMCHR ;IF NOT 1-9 THEN ASSUME AN
MOVEI B,"0" ; OVERPUNCHED ZERO.
SETOM ISNEG ;IN ANY CASE, INDICATE NEGATIVE NUMBER.
DPB B,A ;AND RESTORE THE NUMERIC VALUE.
WS2V50:
MOVE A,LENFLD ; AND LENGTH OF FIELD.
CAIE Z," " ;ARE WE BLANKING ?
JRST WS2V60 ;NO..
SUBI A,1 ;DO NOT BLANK LAST ZERO IF ALL ZEROS
TXNN PRM,%MONEY ;IF NOT A MONEY FIELD
JRST WS2V60 ; THEN SCAN ALL BUT LAST DIGIT.
LDB B,.SUBTP ; OTHERWISE REMEMBER NOT TO BLANK
SUBI A,(B) ; 0'S TO THE RIGHT OF THE DECIMAL.
WS2V60: ;HERE WITH:
; A -- MAXIMUM NUMBER OF CHARACTERS TO ATTEMPT TO BLANK.
SETZ C, ;INITIALIZE NUMBER OF CHARACTERS BLANKED.
MOVE D,VALFLD ;POINTER TO VALUE.
;[46] JUMPE A,WS2V70 ;BLANK NO DIGITS -- INSERT NO SIGN
JUMPLE A,WS2V70 ;BLANK NO DIGITS -- INSERT NO SIGN
WS2V62: ;BLANKING LOOP
ILDB B,D ;GET NEXT CHARACTER
CAIN B,"0" ;IF LEADING 0
JRST WS2V65 ; THEN CONTINUE BLANKING.
CAIN B," " ;IF LEADING BLANK
JRST WS2V65 ; THEN CONTINUE BLANKING.
CAIN B,"+" ;IF LEADING PLUS SIGN
JRST WS2V65 ; THEN CONTINUE BLANKING.
CAIE B,"-" ;IF NOT LEADING MINUS
JRST WS2V70 ;THEN SEARCH IS DONE.
SETOM ISNEG ; OTHERWISE INDICATE NEGATIVE.
WS2V65: AOS C ;COUNT BLANKED DIGITS
DPB Z,D ;INSERT THE BLANKING CHARACTER.
SOJG A,WS2V62 ;IF MORE CHARACTERS..LOOP.
IBP D ;LEAVE BYTE POINTER IN GOOD STATE.
WS2V70: ;HERE AFTER SEARCH FOR LEADING ZEROS IS DONE WITH:
; C == NUMBER OF LEADING CHARACTERS BLANKED.
; D == POINTING AT LAST CHARACTER BLANK.
; ISNEG = 0 IF POSITIVE, -1 IF NEGATIVE.
SKIPE C ;IF NO CHARACTERS BLANKED
SKIPL ISNEG ; OR A POSITIVE NUMBER
JRST WS2V80 ; THEN JUST LEAVE IT AS IS.
MOVEI A,"-" ; ELSE INSERT THE MINUS SIGN.
CAIE Z," " ;IF NOT BLANKING
JRST [MOVE D,VALFLD ; THEN PUT SIGN IN THE
IDPB A,D ; FIRST POSITION.
RET]
SETO B, ;BACKUP THE POINTER BY 1
ADJBP B,D ; BYTE
DPB A,B ; AND DEPOSIT THE MINUS SIGN.
WS2V80: ;HERE WHEN THE NUMBER IS PROPERLY BLANKED IN THE VALUE AREA.
RET
;[21] END OF BLANKING AND MINUS PATCH.
SUBTTL SUBFLD - GET THE NEXT SUB-FIELD POSITION & LENGTH
; CALL SUBFLD (SUBX, SUBY, SUBTAB, PRM, .LINE, .COLM)
; <NO-MORE> THIS FIELD
; RETURN (A=LINE; B=COLM; C=LENGTH)
SUBFLD:
SKIPL SUBX ;IF -1, DO INITIALIZATION
JRST $SF.1 ;ELSE GO CALC STUFF RETURN
SETZM SUBY ;START FRESH
SETZM SUBP ;NO PRIOR DISPLACEMENT
CALL SAVCPM ;SAVE CURRENT STATUS
MOVE D,LENFLD ;REMEMBER IN CASE OF MONEY FIELD
SETZM LENFLD ;NO PREVIOUS LENGTH ON FIRST SUB-FIELD
TXNN PRM,%DATE ;A DATE FIELD
JRST $SF.2
LDB A,.SUBTP ;GET TYPE OF DATE FIELD.
CAIN A,5 ;[102] IF THIS IS THE CANDIAN DATE
SETZ A, ;[102] THEN TREAT AS SLASH
CAIL A,3
TRZ A,6 ;3=1 4=0
JRST $SF.0 ;GO SAVE SUBX NUMBER
$SF.2: TXNN PRM,%MONEY ;MONEY ?
JRST $SF.3
MOVEI A,4
LDB B,.SUBTP
DPB B,[POINT 7,SUBTAB+4,13] ;CENTS
MOVE C,D
SUB C,B
DPB C,[POINT 7,SUBTAB+4,6]
JRST $SF.0
$SF.3: TXNN PRM,%SSN
RET
MOVEI A,3 ;SSN FIELDS
$SF.0: MOVEM A,SUBX
$SF.1: MOVE A,SUBY
IBP A,[POINT 7,SUBTAB,6] ;FORM PTR TO ENTRY
ADD A,SUBX ;CORRECT TABLE DISPLACEMENT
LDB C,A ;C=LENGTH OF SUB FIELD
CAME A,[POINT 7,SUBTAB+4,6] ;FIRST MONEY ENTRY MAY BE 0
JUMPE C,$SF.4 ;0=DONE (IF NOT DOLLARS)
DMOVE A,LINFLD ;GET LINE AND COL NUMBER.
ADD B,SUBP ;FORM CORRECT DISPLACEMENT
MOVE D,LENFLD ;FORM OFFSET TO VALUE FIELD
ADJBP D,VALFLD
MOVEM D,VALFLD
MOVEM C,SUBP ;SAVE DISPLACEMENT FOR NEXT TIME
AOS SUBP
DMOVEM A,LINFLD ;SAVE NEW POSITION
MOVEM C,LENFLD ;SAVE LENGTH
AOS SUBY
JRST SKPRT1 ;SKIP RETURN
$SF.4: SETOM SUBX
CALL RSTCPM ;RESTORE STATE OF WORLD
RET
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
CALL MOV.7 ;ELSE DO ASCII MOVE
RET ;AND RETURN
MOV.6:
TLO A,400000 ;INDICATE STOP ON SPACE & NULLS
EXTEND A,[MOVST SIX27
" "] ;SIXBIT TO 7BIT
SETZ A, ;ABORT = ALL SOURCE BYTES DONE
RET
MOV.7:
TLO A,400000 ;INDICATE STOP ON SPACE & NULLS
EXTEND A,[MOVST SVN27
" "] ;ASCII TO ASCII
SETZ A, ;ABORT = ALL SOURCE BYTES DONE
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
" "] ; SPACES
JFCL
MOVE B,[POINT 7,INTBUF]
POP P,A
RET
PAGE
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," " ;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
LBL 5
COMMENT +
CALL TFRWRT (FIELD-ID, ERR)
RETURN (ERR)
+
TFRWRT:
ENTER FRMWRT,2 ;[7]
SETZM @1(ARG) ;[17]INDICATE NO ERROR.
MOVEI INT.A,@0(ARG) ;GET W.S. POINTER
HRRZ INT.B,1(INT.A)
MOVE INT.A,0(INT.A)
CALL $SBEGIN ;[64]INITIALIZE OUTPUT BUFFER
%5.1:
CALL FIND ;GET THE NEXT FIELD
JRST %5.4 ;NO FIELDS FOUND WITH SPECIFICATION.
JRST %5.3 ;NO MORE FIELDS FOUND.
JFCL ;FIELD FOUND.
CALL WRTDSP ;[60]IF FIELD NOT DISPLAYED AND NOT
JRST %5.5 ;[60] NOT INITIALIZING NEW FIELDS..DO THIS.
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.
TXON PRM,%DSPLY ;[60]IF FIELD WAS NOT DISPLAY, THEN
CALL FILL ;[60] APPLY FILLERS TO END OF LINE.
TXNE PRM,MSDUP% ;[45]IF THE FIELD IS MASTER DUPE
TXO PRM,PRDUP% ;[45] THEN SET MASTER DUPE FLAG.
CALL STRPRM ;SAVE THE 'PRM' INFORMATION.
CALL $SCHKPNT ;[64]FLUSH OUTPUT BUFFER IF ROOM NEEDED.
JRST %5.1 ;DO IT AGAIN
%5.3: ;RETURN TO USER,... NO MORE FIELDS
;[17] SETZM @1(ARG)
CALL $SEND ;[64]SEND OUTPUT BUFFER.
RET
%5.4: MOVEI A,ERR.NF ;INDICATE FIELD NOT FOUND ERROR.
MOVEM A,@1(ARG)
RET
%5.5: MOVEI A,ERR.ND ;INDICATE FIELD NOT DISPLAYED ERROR.
MOVEM A,@1(ARG)
;[17] CALL $SEND ;[65] SEND OUT THE BUFFER
;[17] RET
JRST %5.1 ;[17]CONTINUE AROUND.
;[60] BEGIN PATCH
WRTDSP: ;ROUTINE TO TEST DISPLAY BIT, AND DETERMINE IF
;UNDISPLAYED FIELDS ARE TO BE INITIALIZED ANYWAY.
TXNE PRM,%DSPLY ;[60]IF THIS FIELD IS DISPLAYED
JRST [CALL BLANK ;[60] THEN BLANK IT AND
JRST SKPRET] ;[60] RETURN.
SKIPE OLDWR ;[60] ELSE IF NOT INITIALIZING DURING WRITE
RET ;[60] THEN ERROR RETURN.
CALL GETPRM ;[60]INITIALIZING NONDISPLAYED FIELD SO
CALL STRPRM ;[60] PRM VALUES MUST BE SET UP.
MOVEI A,ERR.ND ;[60]INFORM USER THAT AT LEAST ONE
MOVEM A,@1(ARG) ;[60] FIELD IS NOT DISPLAYED.
JRST SKPRET ;[60] AND RETURN
SUBTTL FILL & BLANK - FILL OR BLANK A FIELD WITH FILL
FILL:
TXNE PRM,%DATE!%SSN!%MONEY ;SPECIAL
JRST SF1 ;DO SUBFIELDS
MOVE 0,FILCHAR ;GET THE FILLER AND
CAIN 0," " ;IF FILLER IS A BLANK
RET ; THEN DON'T BOTHER FILLING.
SF1:
CALL LD.NUMRD ;GET NUMBER OF CHARS IN FIELD.
MOVEI C,(A) ; AND MOVE THEM TO 'C'
DMOVE A,LINFLD ;GET LINE AND COLUMN IN A&B
TXNN PRM,PROT% ;[11]IF FIELD IS UNPROTECTED
TXNE PRM,%DSPLY ;[11] AND CURRENTLY NOT ON SCREEN
SKIPA ;[11] THEN
SETZ C, ;[11] FILL THE WHOLE FIELD.
MOVE D,LENFLD
MOVEM D,YET2WT ;SAVE TOTAL # IN FIELD.
SUB D,C ;NUM REMAINING IN FIELD
SKIPG D ;ANY?
RET ;NO
ADD B,C ;START + NUM RD
TXNN PRM,%DATE!%SSN!%MONEY ;SPECIAL
JRST [CALL $POSIT ;POSITION TO FIELD
PJRST COMFIL] ; AND FILL IT OUT.
MOVEM D,NUMREM ;SAVE NUMBER REMAINING UNFILLED
FILOOP:
CALL SUBFLD
JRST RSTRET
MOVN D,C ;THIS MUCH IS LEFT AND SO
ADDB D,YET2WT ;UPDATE BOTH.
CAML D,NUMREM ;TOO FAR YET?
JRST FILOOP ;NO
MOVE D,NUMREM
SUB D,YET2WT
ADD B,C ;COL+LENG
SUB B,D ; -#THIS WRITE
MOVN E,D ;THIS MUCH LESS
ADDM E,NUMREM
CAME D,C ;FULL SUBFIELD ?
JRST JUSTFL ;NO - JUST FILL
MOVE E,SUBY ;SEE IF ON FIRST SUB-FIELD
SOJE E,JUSTFL ;JUMP IF FIRST
SOS B ;BACKUP COLUMN POSITION
CALL $POSIT ; AND POSITION CURSOR
CALL SEPCHR ; PRINT SEPARATOR
CALL COMFIL ; AND FILL IN.
JRST FILOOP ;NEXT SUBFIELD.
JUSTFL:
JUMPLE D,FILOOP ;DO NOTHING IF NOTHING
CALL $POSIT ;POSITION TO SUBFIELD
CALL COMFIL
JRST FILOOP
COMFIL:
PUSH P,C ;[64]USE 'C' FOR THE
MOVE C,D ;[64] FOR THE CHARACTER COUNT
MOVE A,FILCHAR ;GET THE FILLER CHARACTER.
CALL $SMCHAR ;[64]SEND OUT 'A' MULTIPLE TIMES
POP P,C ;[64]RESTORE 'C'.
RET
ABLANK:
MOVE C,LENFLD
MOVEI A," "
MOVEM A,FILCHAR ;SAVE FILL CHAR FOR A WHILE
DMOVE A,LINFLD
TXNE PRM,%SSN
ADDI C,2
TXNE PRM,%MONEY
AOJ C,
TXNN PRM,%DATE
JRST COMBLK
TXNN PRM,%DATDE!%DATSL
TXNN PRM,%DATJU
ADDI C,2
JRST COMBLK
BLANK:
CALL LD.NUMRD ;LOAD NUMBER OF CHARS IN FIELD
MOVEI C,(A) ; AND MOVE THEM TO 'C'
TXNN PRM,PROT% ;[11]IF FIELD IS UNPROTECTED
TXNE PRM,%DSPLY ;[11] AND CURRENTLY NOT ON SCREEN
SKIPA ;[11] THEN
MOVE C,LENFLD ;[11] FILL THE WHOLE FIELD.
SKIPN C
RET
DMOVE A,LINFLD
TXNN PRM,%DATE!%SSN!%MONEY ;SPECIAL?
JRST COMBLK ;NO
MOVEM C,YET2WT
SETOM SUBX ;[4] INDICATE START OF SPECIAL FLD
BKLOOP:
CALL SUBFLD ;GET A SUBFLD
JRST RSTRET
JUMPE C,BKLOOP ;IGNORE NULL FIELDS
CAMLE C,YET2WT ;LESS LEFT TO WRITE THAN WE HAVE ?
MOVE C,YET2WT ;YES - USE MOST RESTRICTIVE CASE
JUMPLE C,RSTRET ;RESTORE THE WORLD IF NO MORE
MOVN D,C ;DECR. COUNTER
ADDM D,YET2WT
CALL COMBLK ;DO SOME BLANKING
JRST BKLOOP ;& LOOP 'TILL DONE.
COMBLK:
CALL $POSIT
MOVE A,FILCHAR
CALL $SMCHAR ;[64]SEND 'A' 'C' TIMES
RET
SEPCHR: ;PICK A SEPR. CHAR. & OUTPUT IT.
PUSH P,A
PUSH P,B
TXNE PRM,%MONEY
MOVEI A,"."
TXNE PRM,%SSN
MOVEI A,"-"
TXNN PRM,%DATE
JRST SEPOUT
MOVEI A,"-"
LDB B,.SUBTP
CAIE B,%DATCA ;[102]IF THIS IS EITHER CANADIAN
CAIN B,%DATSL ; OR SLASH THEN
MOVEI A,"/" ; SET A SLASH.
SEPOUT:
CALL $SCHAR ;[64]SEND THE SINGLE CHAR IN 'A'.
POP P,B
POP P,A
RET
SUBTTL TFRRD - READ A FIELD-ID FROM SCREEN
LBL 6
COMMENT +
CALL TFRRD (FIELD-ID, END-CHAR, ERR)
RETURN (END-CHAR, ERR)
+
TFRRD:
ENTER FRMRD,3 ;[7]
SETZM @2(ARG) ;[17]INITIALIZE ERROR RETURN.
CALL $SBEGIN ;[64]INITIALIZE THE OUTPUT LINE
SETZM MAXFLD ;[71]INDICATE NOT BACKING UP.
%6.1: MOVEI INT.A,@0(ARG) ;GET W.S. POINTER
HRRZ INT.B,1(INT.A)
MOVE INT.A,0(INT.A)
CALL INITSD
JRST %6.14 ;INIT FAILED = NOT FOUND
JFCL ;FIELD WAS FOUND
SETZM DEFALT ;INDICATE NOT DEFAULTING FIELDS
%6.4:
CALL FIND ;GET NEXT FIELD SPECIFIED
JRST %6.14 ;NO FIELD WAS FOUND.
JRST %6.15 ;NO MORE FIELD ANSWER SPECIFICATION.
JFCL ;A FIELD WAS FOUND.
TXNN PRM,%DSPLY ;[17]ON THE SCREEN ?
JRST [MOVEI A,ERR.ND ;INDICATE NOT DISPLAYED
MOVEM A,@2(ARG) ;[17] ON RETURN
JRST %6.4] ;[17]AND GO FOR NEXT FIELD
TXNE PRM,PROT% ;IF FIELD IS PROTECTED
JRST %6.4 ; THEN BYPASS IT.
MOVN INT.C,PRM ;IF BOTH MSDUP% AND PRDUP% ARE ON
TXNN INT.C,MSDUP%+PRDUP% ; THEN FIELD IS MASTER DUPED
JRST %6.4 ; AND SHOULD BY BYPASSED.
SETZM PREDUP ;[15]INDICATE NOT PREVIOUS DUPE
MOVE A,MAXFLD ;[71]IF WE WERE BACKING UP BUT HAVE
CAMG A,CURFLD ;[71] NOW COME BACK TO THE STARTING POINT
SETZM MAXFLD ;[71] OF THE BACKUP, RESET.
SKIPE MAXFLD ;[71]IF WE ARE BACKING UP THEN
SETOM PREDUP ;[71]INDICATE FIELD IS PREVIOUS DUPE.
TXNE PRM,MSDUP% ;IF MASTER DUPE BUT NOT VALUE
JRST %6.7 ; THEN TREAT LIKE NORMAL.
TXNN PRM,PRDUP% ;IF NOT PREVIOUS DUPE THEN
JRST [SKIPN MAXFLD ;[71]IF NOT BACKING UP
JRST %6.7 ;[71] THEN IT IS NOT PREVIOUS DUPE
JRST .+1] ;[71] ELSE TREAT AS PREVIOUS DUPE.
SETOM PREDUP ;[15] INDICATE PREVIOUS DUP
SKIPN DEFALT ;IF READING ALL FIELDS THEN
JRST %6.8 ; THEN GO TO READ
CALL LD.NUMRD ; ELSE GET CURRENT SIZE AND
MOVE INT.C,A
JRST %6.10 ;AND MERELY CHECK REQUIRED STATUS.
%6.7:
SKIPN DEFALT ;IF READING ALL FIELDS
JRST %6.8 ; THEN GO TO READ ROUTINE
SETZB A,INT.C ; ELSE SET SIZE TO ZERO AND
JRST %6.10 ; GO CHECK FOR REQUIRED STATUS.
;;;;;;;; READ THE SPECIFIED FIELD ;;;;;;
%6.8:
CALL FLDRD ; AND THEN READ THE FIELD.
JUMPN B,%6.ESC ;ESCAPE WAS RETURNED FROM INTRD.
%6.9: SKIPN OLDMD ;[37]IF MASTER DUPE IS NOT TO BE TURNED
JRST %6.10 ;[37] ON UNLESS CHARACTERS TYPED..GO ON.
TXNE PRM,MSDUP% ;[37]ELSE ;IF MASTER DUPE AND
TXNE PRM,PRDUP% ;[37] NOT ON THE SCREEN
JRST %6.10 ;[37] THEN
TXO PRM,PRDUP% ;[37] INDICATE THAT IT HAS VALUE.
CALL STRPRM ;[37] AND
JRST %6.10 ;[37] THEN CONTINUE.
%6.10:
CALL CKREQD ;CHECK REQUIRED ATTRIBUTE
JRST [HRROI C,MSG.RQ ;REQUIRED ERROR
CALL INTERR
JRST %6.8] ;GO FOR IT AGAIN
SKIPGE DEFALT ;[14]IF ONLY CHECKING REQUIRED STATUS
JRST %6.4 ;[14] THEN GO ON TO NEXT FIELD.
JUMPE A,%6.4 ;IF NOTHING TYPED, NO FURTHUR PROCESSING.
SKIPN NEWDAT ;IF NOT NEW DATA (PREVIOUS DUPE)
JRST %6.4 ; THEN ALL IS OK.
CALL REFORM ;SKIPS IF FIELD ON SCREEN IS CORRECT
CALL REWRITE ;[51]REWRITE FIELD IF DESIRABLE.
SKIPLE DEFALT ;[33]IF WE JUST STARTED DEFAULTING
SETOM DEFALT ;[33] THEN INDICATE NO MORE WRITING.
TXNE PRM,MSDUP% ;IF MASTER DUPE AND
TXNE PRM,PRDUP% ; NOT ON THE SCREEN
JRST %6.11 ; THEN
TXO PRM,PRDUP% ; INDICATE THAT IT HAS VALUE.
CALL STRPRM ; AND CONTINUE
;;;;;;;;;;;;;;;;;;;; CHECK THE FIELD FOR LEGALITY ;;;;;;;;;;;;;;;
%6.11:
TXNN PRM,%DATE ;[16]DATE CHECK REQUIRED
JRST %6.11B ;[16] NOT A DATE.. CONTINUE
CALL CKDATE ;[16] DATE CHECKING
JRST [HRROI C,MSG.ID ;[16] ILLEGAL DATE
CALL INTERR ;[16]
JRST %6.13] ;[16]
%6.11B: ;[16]JUMP HERE IF NOT DATE
TXNN PRM,%RANGU%+RANGL% ;[110]IF NO RANGE CHECKS
JRST %6.4 ;[110] THEN ALL IS OK
PUSH P,VALFLD ;[110] MOVE THE VALUE INTO A FIELD
MOVE A,INTBUF ;[110] WITH LEADING ZEROS IF NUMERIC
MOVE A,[POINT 7,INTBUF] ;[110] WITH LEADING ZEROS IF NUMERIC
MOVEM A,VALFLD ;[110]
PUSH P,OLDZR ;[110] SAVE BLANKING INDICATOR
SETOM OLDZR ;[110] INDICATE LEADING ZEROS
CALL WS2VAL ;[110] MOVE IT.
POP P,OLDZR ;[110] RESTORE THE VALUE
POP P,VALFLD ;[110] AND THE POINTER
CALL CKRGLW
JRST [LOAD B,.LRANG,A ;NOT WITHIN RANGE.
SUB B,V11SYM ;[35]OFFSET TO THE CORRECT
ADD B,V12SYM ;[35] PAGE.
HRLI B,(POINT 7,0)
MOVEM B,ERRRNG
HRROI C,MSG.LR
CALL INTERR
JRST %6.13]
CALL CKRGUP
JRST [LOAD B,.URANG,A ;NOT WITHIN RANGE
SUB B,V11SYM ;[35]OFFSET TO THE CORRECT
ADD B,V12SYM ;[35] PAGE.
HRLI B,(POINT 7,0)
MOVEM B,ERRRNG
HRROI C,MSG.UR
CALL INTERR
JRST %6.13]
JRST %6.4 ;ALL OK
%6.13: ;;ERROR (NOT WITHIN RANGE, ILLEGAL DATE) DISCOVERED.
CALL INTCFD ;RE-INITIALIZE THE FIELD.
JRST %6.8 ;REREAD THE FIELD.
%6.14: MOVEI INT.C,ERR.NF ;FLAG FIELD NOT FOUND ERROR.
MOVEM INT.C,@2(ARG)
SETZM @1(ARG) ;ERROR GIVES OK TERM CHAR
RET ;RETURN
%6.15: ;;NORMAL RETURN
;[17] SETZM @2(ARG)
CALL $SEND ;[64]FLUSH ANY OUTPUT
MOVE A,TRMCHR ;SET TERMINATOR
MOVEM A,@1(ARG)
RET ;RETURN
CKREQD: ;CHECK REQUIRED ATTRIBUTE
SKIPE A ;IF SOMETHING WAS ENTERED
SKIPA ; THEN GIVE GOOD (SKIP) RETURN
TXNN PRM,REQD% ;IF NOTHING ENTERED BUT FIELD OPTIONAL
AOS (P) ; THEN GIVE GOOD RETURN
RET ; ELSE GIVE BAD (NOSKIP)RETURN.
;[51]TEST IF FIELD SHOULD REALLY BE REWRITTEN TO THE SCREEN.
REWRITE:
SKIPN OLDRN ;IF REWRITING NUMBERS
CALL WRITE ;THEN DO IT.
RET ;ELSE RETURN
;[51]END OF ADDITION
;*************** HANDLE THE ESCAPE SEQUENCES ****************
%6.ESC: PUSH P,A ;[71]SAVE THE CHARACTER COUNT OF FIELD.
CALL SV.NUMRD ;SAVE COUNT OF # RD SO FAR
CALL INICUF ;[24]INITIALIZE CURRENT FIELD.
POP P,A ;[71]RESTORE CHARACTER COUNT TO 'A'.
JRST .(B) ;B=1 THRU 3
JRST ESC.P ;(BLUE) BACKUP TO BEGINNING OF FIELD.
JRST ESC.Q ;(RED) BACKUP TO BEGINNING OF READ.
JRST ESC.R ;(BLACK)REWRITE SCREEN.
ESC.P:
TXNE PRM,PRDUP% ;[71]IF THIS IS A PREVIOUS DUPE FIELD
JRST [SKIPL PREDUP ;[71] THEN IF SOME CHARACTERS WERE TYPED
JRST [SETOM PREDUP ;[71] THEN RAISE THE PREV-DUPE FLAG
JRST %6.7] ;[71] AND REREAD THE FIELD.
JRST ESC.P1] ;[71] ELSE FIND PREVIOUS FIELD
;[71] ELSE NEXT STATEMENT.
SKIPN MAXFLD ;[71]IF NOT BACKING UP
JRST [JUMPG A,%6.7 ;[71] THEN IF ERASE CURRENT FIELD, DO IT
JRST ESC.P1] ;[71] ELSE BACKUP ONE FIELD.
SKIPL PREDUP ;[71] ELSE IF SOME CHARACTERS WERE TYPED
JRST [SETOM PREDUP ;[71] THEN RAISE THE PREV-DUPE FLAG
JRST %6.7] ;[71] AND REREAD FIELD.
JRST ESC.P1 ;[71] ELSE BACKUP ONE FIELD.
ESC.P1: MOVE A,CURFLD ;[71] BACKUP TO PREVIOUS FIELD.
SKIPN MAXFLD ;[71]IF NOT CURRENTLY BACKING UP,
MOVEM A,MAXFLD ;[71] THEN START BACKUP HERE.
PUSH P,A ;[71]SAVE THE CURRENT FIELD NUMBER.
SETZM CURFLD ;[71]PREPARE TO FIND PREVIOUS FIELD
SETZM SECTAB ;[71] BY STARTING AT BEGINNING OF
SETZM LASTFLD ;[71] THE READ AND SAVING THE PREVIOUS
;[71] FIELD NUMBER.
ESC.PA:
CALL FIND ;[71]FIND THE NEXT FIELD
JFCL ;[71] WE SHOULD NOT GET THESE
JFCL ;[71] THESE RETURNS.
JFCL ;[71]
TXNN PRM,%DSPLY ;[71]IF FIELD NOT DISPLAYED, THEN
JRST ESC.PA ;[71] IT IS NOT OF INTEREST.
TXNE PRM,PROT% ;[71]IF FIELD IS PROTECTED, THEN IT
JRST ESC.PA ;[71] IS NOT OF INTEREST EITHER.
MOVN INT.C,PRM ;[71]IF FIELD IS SET-MASTER DUPE
TXNN INT.C,MSDUP%+PRDUP%;[71] THEN IT IS NOT OF INTEREST.
JRST ESC.PA ;[71]
MOVE A, CURFLD ;[71]IF THIS FIELD'S NUMBER IS
CAMN A,(P) ;[71] IS THE SAME AS THE CURRENT ONE
JRST ESC.PB ;[71] THEN LASTFLD WILL HAVE PREVIOUS ONE
MOVEM A,LASTFLD ;[71]ELSE SAVE THIS FIELD AS PREVIOUS FIELD.
JRST ESC.PA ;[71] AND CONTINUE SEARCHING FOR CURRENT.
ESC.PB:
POP P,0 ;[71]RESTORE THE STACK.
SKIPN A,LASTFLD ;[71]IF LAST FIELD IS STILL ZERO THEN
JRST %6.7 ;[71] THEN WE CANNOT BACKUP FARTHER.
SOS A ;[71] ELSE USE THIS AS NEXT FIELD
MOVEM A,CURFLD ;[71] TO READ
JRST %6.4 ;[71] GO GET IT.
ESC.Q:
MOVE A,CURFLD ;[71]SAVE CURRENT FIELD #
SETZM CURFLD
SETZM SECTAB ;[67]INITIALIZE SECTION TABLE
SKIPN MAXFLD ;[71]IF NOT IN BACKUP YET
MOVEM A,MAXFLD ;[71] THEN INDICATE WE ARE.
JRST %6.4 ;RESTART CURRENT READ
ESC.R: ;RE FORMAT SCREEN
PUSH P,INT.A ;SAVE SOME STUFF
PUSH P,SECTAB ;[67]SAVE THE SECTION INITIALIZATION
PUSH P,CURFLD
SETZB INT.A,CURFLD
CALL $CLEAR ;CLEAR ALL OF SCREEN
ESC.RF: ;ESC.R LOOP
CALL FIND
JRST ESC.RG ;NOT-FOUND.
JRST ESC.RG ;[24] RESTORE REGISTERS.
JFCL ;[24]FOUND IT.
TXNN PRM,%DSPLY ;DO THOSE PREVIOUSLY ON SCREEN
JRST ESC.RF
CALL WRITE
CALL FILL
CALL $SCHKPNT ;[64]FLUSH BUFFER IF NECESSARY
JRST ESC.RF
;[24] START OF PATCH TO FIX UP ESCAPE SEQUENCES
ESC.RG:
MOVE INT.A,0(P) ;RESTORE CURRENT FIELD.
SETZM CURFLD
CALL INITSD ;MAKE SURE WE POINT AT IT.
JFCL
ESC.RH: POP P,CURFLD
POP P,SECTAB ;[67]RESTORE SECTION TABLE STUFF
POP P,INT.A
JRST %6.7
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 ;[71]IF BACKING UP FIELDS
JRST INIC50 ;[71] THEN TREAT LIKE PREVIOUS DUPE.
TXNE PRM,PRDUP% ;IF THIS IS A PREVIOUS DUPE FIELD
JRST INIC50 ; THEN HANDLE IT DIFFERENTLY.
MOVE INT.A,CURFLD ;RE-INITIALIZE FILLERS
SETZM CURFLD
CALL INITSD ; BY CALLING INTERNAL INITIALIZATION.
JFCL ;SHOULD NOT HAPPEN.
INIC10: ;COMMON EXIT.
POP P,CURFLD ;RESTORE THE FIELD INDICATORS
POP P,INT.A
POP P,B ; AND THE ESCAPE TYPE.
RET
INIC50: ;HANDLE THE PREVIOUS DUPE FIELD.
SKIPE PREDUP ;IF FIRST CHAR OF PRE-DUP NOT TYPED
JRST INIC10 ; 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 ;[64]SEND OUT BUFFER IF NECESSARY.
JRST INIC10
;[24] END OF CODE TO FIX UP THE ESCAPE SEQUENCES
;***************** END OF ESCAPE HANDLING ****************
SUBTTL REFORM - REFORMAT VALUE => W.S. => VALUE
LBL 14
REFORM:
;[20] MOVE VALFLD
;[20] ILDB E,0
;[20] CAIN E,11
;[20] TXNN PRM,PRDUP%
;[20] JRST .+2
SKIPE ISTAB ;[20]IF PREVIOUS DUPE TABBED OVER
JRST SKPRET ;[20] THEN IS IN GOOD FORM.
TXNE PRM,NUMER% ;NUMERIC
JRST %14.2 ;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
" "]
JFCL ;DUMMY ERROR RETURN
SKIPL DEFALT ;[41]IF NOT DEFAULTING VALUES
CALL WS2VAL ;PUT SPACED OUT FIELD IN CORE TABLE
JRST SKPRET ;SKIP RETURN = NO CHANGES
%14.2: ;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
MOVE C,B ;CHECK FOR LEADING MINUS OR PLUS.
ILDB Z,C ;GET LEAD CHARACTER
REPEAT 0,< ;[110] FOLLOWING CODE IS PRIOR TO EDIT.
TXNE PRM,%DATE ;[5] SKIP IF NOT DATE
SKIPE C,A ;[5] IF 0 TYPED, USE THAT LENGTH
MOVE C,D ;SAVE LENGTH
CAIE "-"
CAIN "+"
JRST [IBP B
IDPB 0,E
SOJ D,
SOJA A,.+1]
>;[110] END OF REPEAT 0
;[110] FOLLOWING IS REPLACEMENT CODE FOR THE ABOVE
CAIN Z,"-" ;IF FIRST CHARACTER IS MINUS SIGN
JRST [PUSH P,A ; THEN OVERPUNCH THE LAST CHARACTER
ADJBP A,B ; BY FIRST DETERMINING ITS POSITION
LDB Z,A ; AND THEN GETTING THE CHARACTER
ADDI Z,"J"-"1" ; AND OVERPUNCHING IT.
CAIN Z,"I" ; IF IT WAS A ZERO THEN USE THE
MOVEI Z,":" ; NECESSARY SYMBOL.
DPB Z,A ; PUT THE OVERPUNCHED SYMBOL BACK,
MOVEI Z,"-" ; RESTORE THE SIGN TO THE REGISTER,
POP P,A ; RESTORE THE REGISTER
JRST .+1] ; AND RETURN TO IN LINE.
CAIE Z,"-" ;IF A SIGN WAS TYPED (EITHER MINUS OR
CAIN Z,"+" ; PLUS)
JRST [MOVEI Z,"0" ; THEN REPLACE IT WITH A LEADING ZERO
DPB Z,C ; SO THAT MOVE CAN WORK EASILY AND
JRST .+1] ; CONTINUE NORMALLY.
TXNE PRM,%DATE ;[5]IF FIELD IS A DATE
SKIPE C,A ;[5] AND NO CHARACTERS TYPED USE ZERO LENGTH
MOVE C,D ;[5] ELSE USE FULL LENGTH.
;[110] END OF THE INSERT
EXTEND A,[MOVSRJ ;MOVE & JUSTIFY
"0"] ;ZERO FILL
JFCL ;IGNORE ERRORS
MOVE A,C ;RESTORE LENGTH
CALL SV.NUMRD ;SAVE NUMBER READ
SKIPL DEFALT ;[41]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.
SUB E,V11SYM ;[35] OFFSET TO THE PROPER
ADD E,V12SYM ;[35] PAGE.
TXNN PRM,%DATE ;[16]NO..BUT IS IT ANOTHER TYPE OF DATE?
JRST CKRGU2 ;[16]NOT A DATE.
LDB A,.SUBTP ;[16]GET THE TYPE OF DATE.
CAIN A,%DATJU ;[16]IS IT JULIAN ?
JRST CKRGU2 ;[16]YES..TREAT NORMALLY.
CALL DATRNG ;[16]DATE (NON-JULIAN) SO DO SPECIAL.
SKIPL E ;[16]IS UPPER RANGE .LT. DATE ?
AOS (P) ;[16] NO.. THUS IT IS OK.
RET ;[16]RETURN.
CKRGU2: ;[16]
CALL CKRGSU ;DO SET-UP
CALL CMPRNG ;[32]COMPARE RANGE (DATE:RANGE)
SKIPG C ;[32]IF DATE .LE. RANGE
AOS (P) ;[32] THEN SKIP RETURN.
RET ;[32]
CKRGLW:
TXNN PRM,RANGL%
JRST SKPRET ;NO CHECK NEEDED
LOAD E,.LRANG,C ;ADDRESS OF LOWER RANGE STRING.
SUB E,V11SYM ;[35]OFFSET TO THE PROPER PAGE.
ADD E,V12SYM ;[35]
TXNN PRM,%DATE ;[16]NO..BUT IS IT ANOTHER TYPE OF DATE?
JRST CKRGL2 ;[16]NOT A DATE, TREAT NORMALLY.
LDB A,.SUBTP ;[16]GET TYPE OF DATE.
CAIN A,%DATJU ;[16]IS IT JULIAN ?
JRST CKRGL2 ;[16] YES..TREAT NORMALLY.
CALL DATRNG ;[16]DATE (NON-JULIAN) SO DO SPECIAL.
SKIPG E ;[16]IS LOWER RANGE .GT. DATE ?
AOS (P) ;[16] NO.. THUS IT IS OK.
RET ;[16]RETURN.
CKRGL2: ;[16]
CALL CKRGSU ;SET-UP
CALL CMPRNG ;[32]COMPARE DATE:RANGE
SKIPL C ;[32]IF DATE .GE. RANGE
AOS (P) ;[32] THEN SKIP RETURN
RET ;[32]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.
TXNE PRM,NUMER% ;[110] IF THIS IS NUMERIC
MOVE B,[POINT 7,INTBUF];[110] THEN USE STORED VALUE.
RET
;[32] 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,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,NUMER% ;IF NOT A NUMERIC
JRST CMPR90 ;THEN WE ARE DONE
TXNE PRM,%DATE+%SSN ; 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
;[32] END OF PATCH
;==;==;==;==;==;==;==;==;==;==;
DATRNG: ;[16] TEST USER SUPPLIED DATE AGAINST RANGE
;[16] AND SET 'E' -1,0,1 FOR (LT,EQ,GT)
PUSH P,VALFLD ;[16]SAVE ADDRESS OF INPUT STRING.
DMOVE A,DATBUF ;[16]MOVE USER'S DATE TO SAVE AREA
DMOVEM A,USRDAT ;[16]
MOVEM E,VALFLD ;[16]INSERT ADDRESS OF RANGE.
CALL CKDT2 ;[16]PUT INTO CONONICAL FORM IN DATBUF
JRST DATAR2 ;[16]RANGE NOT IN GOOD FORMAT.
DMOVE A,DATBUF ;[16]GET CONONICAL FORM OF RANGE.
CAMLE A,USRDAT ;[16]IS RANGE(1) .GT. DATE(1) ?
JRST [MOVEI E,1 ;[16] YES...TELL CALLER
JRST DATAR3] ;[16]TEST COMPLETED.
CAME A,USRDAT ;[16]IS RANGE(1) .LT. DATE(1) ?
JRST [SETO E, ;[16]YES..
JRST DATAR3] ;[16]TEST COMPLETED.
CAMLE B,USRDAT+1 ;[16]RANGE(2) .GT. DATE (2)?
JRST [MOVEI E,1 ;[16]IT IS GREATER
JRST DATAR3] ;[16]TEST COMPLETED.
CAME B,USRDAT+1 ;[16]RANGE(2) .EQ. DATE(2)?
JRST [SETO E, ;[16]NO..THEN IT IS LESS.
JRST DATAR3] ;[16]TEST COMPLETED.
SETZ E, ;[16]YES..INDICATE EQUAL
JRST DATAR3 ;[16]TERMINATE TEST.
DATAR2: ;[16]RANGE NOT GOOD FORMAT--SAY IN RANGE
SETZ E, ;[16]
DATAR3: ;[16]TERMINATION OF DATRNG
DMOVE A,USRDAT ;[16] AND ALSO RESTORE
DMOVEM A,DATBUF ;[16] THE INTERNAL FORM OF THE DATE.
POP P,VALFLD ;[16]RESTORE CURRENT VALUE POINTER
RET
CKDATE: ;CHECK THE VALIDITY OF THE DATE
LBL 30
LOAD C,.NUMRD,D ;[5] ANY CHARACTERS TYPED ?
JUMPE C,SKPRET ;[5] NO - DON'T VALIDITY CHECK
CKDT2:
LDB C,.SUBTP ;[16]GET THE DATE TYPE.
CAIN C,%DATJU ;[16]IS IT JULIAN ?
JRST %30.9 ;[16]YES..TREAT SEPARATELY.
;;EXTRACT MONTH AND VERIFY DIGITS.
SETZM DATBUF ;[16] CLEAR DATE STORAGE AREA
SETZM DATBUF+1 ;[16] (2 WORDS)
MOVE A,VALFLD
HRLI A,(POINT 14,0,13)
TXNE PRM,%SUB1 ;SUB TYPE 1 OR 4
HRLI A,(POINT 21,0,34);NO
CAIN C,%DATCA ;[102] IF THIS IS THE CANADIAN DATE
HRLI A,(POINT 14,0,27) ;[102] THEN SET TO LOOK FOR MONTH.
LDB E,A ;[16]GET THE MONTH STRING.
MOVEI A,MMMTAB ;[16] ADDRESS OF 3 LETTER TABLE NAMES
TXNN PRM,%SUB1 ;[16] IS IT A SLASH/DASH ?
MOVEI A,MNMTAB ;[16] YES.. USE THE 2 DIGIT TABLE.
CAIN C,%DATCA ;[102] IF THIS IS A CANADIAN DATE
MOVEI A,MNMTAB ;[102] THEN USE 2 DIGIT TABLE
PUSH P,C
CALL TBLUK. ;[16] DO SEQUENTIAL LOOKUP IN TABLE
;[16] RETURNS MONTH NUMBER IN 'A'.
;[16] AND 'B' = -1 IF NOT IN TABLE
POP P,C
JUMPL B,%30.8 ;[16]JUMP IF NOT A PROPER MONTH.
MOVE B,MNMTAB(A) ;[16] GET THE MONTH NUMBER
DPB B,DBMMBP ;[16] DEPOSIT IN DATBUF
MOVE E,A ;[16]SAVE MONTH NUMBER.
;;EXTRACT DAY AND VERIFY DIGITS.
MOVE B,VALFLD
HRLI B,(POINT 14,0,27)
CAIE C,%DATDE
CAIN C,%DATMI
HRLI B,(POINT 14,0,13) ;SLASH/DASH
CAIN C,%DATCA ;[102]IF THIS IS A CANADIAN DATE
HRLI B,(POINT 14,0,13) ;[102] THEN GET THE DAY
LDB A,B ;[16]GET THE DAY OF THE MONTH.
DPB A,DBDDBP ;[16]SAVE THE DAY
LSHC A,-7 ;[16]LEAVE ONLY FIRST DIGIT.
CAIL A,"0" ;[16]IS DIGIT LESS THAN 0 OR
CAILE A,"9" ;[16] GREATER THAN 9 ?
JRST %30.8 ;[16]YES.. THEN NOT A DIGIT.
SETZ A, ;[16] CLEAR OUT THIS DIGIT
LSHC A,7 ;[16]GET SECOND DIGIT BACK
CAIL A,"0" ;[16]IS DIGIT LESS THAN 0 OR
CAILE A,"9" ;[16] GREATER THAN 9 ?
JRST %30.8 ;[16]YES.. THEN NOT A DIGIT.
LDB A,DBDDBP ;[16] GET THIS BACK.
CAIL A,"01" ;[16]IS IT LESS THAN 01 ?
CAMLE A,MLDTAB(E) ;[16]OR GREATER THAN LAST DAY OF MONTH?
JRST %30.8 ;[16]NO...ERROR
;; NOW GET AND VALIDATE THE YEAR
MOVE D,VALFLD ;[16]GET ADDRESS OF DATE FIELD.
CAIE C,%DATDE ;[16] IS IT A DEC
CAIN C,%DATMI ;[16] OR DASH DATE ?
SKIPA ;[16]YES...
JRST %30.6 ;[16]NO..SLASH OR DASH
LDB A,[POINT 14,1(D),13] ;[16] GET YEAR IN DDMMMMYY
JRST %30.7 ;[16] AND CONTINUE
%30.6: ;[16] SLASH/DASH DATE
LDB A,[POINT 7,1(D),6] ;[16] GET THE SECOND DIGIT IN YY
LSHC A,-7 ;[16] SHIFT INTO 'B'
LDB A,[POINT 7,(D),34] ;[16] GET FIRST DIGIT
LSHC A,7 ;[16] AND THEN SHIFT BOTH INTO 'A'.
%30.7:
DPB A,DBYYBP ;[16] DEPOSIT THE YEAR
LSHC A,-7 ;[16] TEST FOR 00 TO 99 RANGE
CAIL A,"0" ;[16] IS FIRST CHAR A DIGIT ?
CAILE A,"9" ;[16] 0-9 ?
JRST %30.8 ;[16] NO... AND ERROR
SETZ A, ;[16] CLEAR OUT FIRST DIGIT
LSHC A,7 ;[16] AND GET THE SECOND
CAIL A,"0"
CAILE A,"9"
JRST %30.8
AOS (P) ;[16] GOOD YEAR
%30.8: RET ;ERROR RETURN (NO SKIP).
%30.9: ;HERE WHEN JULIAN DATE
MOVE D,VALFLD ;[16]GET ADDRESS OF USER DATE FIELD.
LDB E,[POINT 21,(D),34] ;[16] GET THE DAY
CAML E,["001"] ;[16] IS IT LSS THAN 001
CAMLE E,["366"] ;[16] OR GREATER THAN 366 ?
SKIPA ;[16] YES... THEN ERROR
AOS (P)
RET
TBLUK.: ;[16] THIS IS THE TABLE LOOKUP FOR MONTH TABLES
;[16] THE TABLE ADDRESS IS IN 'A' AND THE MONTH
;[16] IS IN 'E'.
PUSH P,A ;[16]SAVE REG 'A'.
HRLI A,-^D12 ;[16]NEGATIVE TABLE SIZE IN LEFT HALF.
SETZ B, ;[16]B=0 INDICATES FOUND, B=-1,NOT FOUND
TBLK1.:
CAMN E,(A) ;[16]IS THIS THE ONE ?
JRST TBLK2. ;[16] YES..
AOBJN A,TBLK1. ;[16]NO..JUMP IF MORE
SETO B, ;[16]IT IS NOT THERE
TBLK2.: ;[16] IS HAS BEEN FOUND
POP P,C ;[16]RESTORE TABLE ADDRESS
HRRZS A ;[16]RESULT ADDRESS ONLY
SUBI A,(C) ;[16]OFFSET INTO TABLE.
RET ;[16]
;[16] END OF EDIT [16] DATE FORMAT AND RANGE CHECKING CODE
SUBTTL INTCFD - INITIALIZE CURRENT FIELD & RESTORE STATE OF WORLD
INTCFD:
PUSH P,INT.A
PUSH P,CURFLD
MOVE INT.A,CURFLD
SETZM CURFLD
CALL INITAL
POP P,CURFLD
POP P,INT.A
RET
SUBTTL REGISTER LOAD/SAVE ROUTINES
SV.NUMRD:
STORE A,.NUMRD
RET
LD.NUMRD: ;LOAD REGISTER 'A' WITH COUNT OF CHARS
LOAD A,.NUMRD
RET
SUBTTL FLDRD - READ A FIELD AND SET .NUMRD & PRDUP IF MSDUP
LBL 24 ;=20 DECIMAL
COMMENT +
IF SPECIAL-TYPE-OF-FIELD
THEN CALL SUBFLD
CALL INTRD
UNTIL SUBFLD RETURNS ZERO
ELSE
CALL INTRD;
RETURN (A=NUMBER READ; B=TERMINATING CHARACTER)
+
FLDRD:
MOVEI A,PNCCHR ;[57]SET TO ALLOW SPACES IN ALPHABETICS
TXNE PRM,%SPACE ;[57] IF FIELD HAS BIT SET
MOVEI A,ALPCHR ;[57] AND IF
TXNE PRM,ALPHA% ;[57]FIELD IS ALPHABETIC
MOVEM A,CHRTAB+40 ;[57]
SETZM FRSTSB ;[27]INDICATE IN FIRST SUBFIELD.
TXNN PRM,<%TYPE^!%YN> ;ANY SPECIAL BITS SET ?
JRST %24.5 ;NO--NOT A SUBFIELD.
%24.2: CALL SUBFLD ;GET NEXT SUBFIELD
RET ;NO MORE SUBFIELDS.
JUMPE C,%24.2 ;DON'T READ EMPTY FIELDS
CALL INTRD ;READ THIS FIELD.
ADDM A,TOTNRD ;ADD IN TOTAL # READ
JUMPN B,RSTRET
MOVE E,TRMCHR
CAIN E,TRM.LN ;LENGTH ?
JRST [SETOM FRSTSB ;[27] YES--INDICATE IN NEXT SUBFIELD
JRST %24.2] ;[27]
RSTRET:
CALL RSTCPM ;PUT BACK WORLD IF ESC TYPED
RET
%24.5: CALL INTRD ;READ THIS FIELD.
RET
SAVCPM:
MOVE A,[LINFLD,,SAVFLD]
BLT A,SAVFLD+4
SETZM TOTNRD ;NONE READ SO FAR
RET
RSTCPM:
MOVE A,[SAVFLD,,LINFLD]
BLT A,OFFFLD
;[111] AT LINE RSTCPM+3 IN SOURCE
;[111] MOVE A,TOTNRD
SKIPE A,TOTNRD ;[111]IF NON-NULL INPUT INTO WHOLE FIELD
SETOM NEWDAT ;[111] THEN INDICATE THAT DATA WAS ENTERED.
SETOM SUBX ;MAKE SURE SUB-F STUFF WORKS OK
RET
SUBTTL INTRD - INTERNAL READ ROUTINE FOR ONE FIELD
COMMENT +
1..POSITION CURSOR;
2..SET UP PTR TO VALUE IN CORE
3..IF NUMERIC
4..SET UP TEXTI FOR NUMERIC
5..ELSE SET UP FOR A-N;
6..DO TEXTI UNTIL . . .
7.. NOT SPECIAL CHARACTER
8..IF UNACCEPTABLE CHARACTER
9..GO TO 6
10..GOOD END (TAB)
11..GOOD END (LENGTH)
12..SPECIAL END (LF, CR, ESC)
13..BACKSPACE (BS)
14..RETURN LENGTH READ AND TERMINATOR
+
LBL 23 ;A BRAND NEW LABEL JUST FOR US
INTRD: ;INTERNAL READ OF A FIELD
DMOVE A,LINFLD ;WITH FIELD'S LINE AND COLUMN,
CALL $POSIT ; POSITION CURSOR
CALL $SEND ;[64]AND FORCE POSITIONING OUT
MOVE A,VALFLD ;SET UP POINTER TO CORE VALUE AREA.
MOVEM A,TXTTAB+.RDDBP ;DESTINATION BYTE POINTER
MOVEM A,TXTTAB+.RDBFP ;BACKUP LIMIT FOR CTRL-U ETC.
TXNN PRM,NUMER% ;IF FIELD IS NOT NUMERIC
JRST %23.5 ; THEN CHECK FOR ALPHA ONLY.
;[15] MOVEI A,TXTNUM ; ELSE SETUP FOR NUMERIC BREAKS
;[15] MOVEM A,TXTTAB+.RDBRK ;SAVE BREAK SET ADDRESS
MOVEI A,ALPCHR+PNCCHR+CONCHR+FCCCHR ;[15] ALL BUT NUMERICS
MOVEM A,FLDTYP ;[15] STORE THE BREAK SET.
JRST %23.6
%23.5: ;HERE IF NOT A NUMERIC FIELD, MAY BE ALPHA ONLY.
;[15] MOVEI A,TXTAN ;ALPHANUMERIC BREAKS
MOVEI A,CONCHR+FCCCHR ;[15]BREAK ONLY ON CONTROL CHARACTERS
TXNE PRM,ALPHA% ;IF ALPHA ONLY
MOVEI A,CONCHR+FCCCHR+PNCCHR+NUMCHR ;[15]BREAK ON ALL BUT ALPHAS.
MOVEM A,FLDTYP ;[15] STORE THE BREAK SET.
%23.6: ;;ALL DATA TYPES RETURN HERE FOR READ.
MOVE INT.C,LENFLD ;SAVE MAX LENGTH AVAIL FOR INPUT
MOVEM INT.C,TXTTAB+.RDDBC ;DESTINATION BYTE COUNT
%23.TI: ;[15] MOVE THIS TAG HERE AFTER ELIMINATING THE CODE.
MOVEI A,TXTTAB ;POINT TO DATA BLOCK
SETZM TRMCHR ;NO TERM CHAR YET
CALL TEXTI. ;[15] READ THE FIELD,RETURN LAST CHAR
;[20] IN 'E'.
JFCL ;[15]PLAN FOR SKIP RETURN
MOVE B,TXTTAB+.RDFLG ;DETERMINE IF ACCEPTABLE CHAR.
TXNN B,RD%BTM ;BREAK TERMINATED TEXTI ?
JRST %23.LN ;NO MUST BE LENGTH DONE
;[20] SETZ E, ;GET LAST BYTE READ
;[20] LDB E,TXTTAB+.RDDBP ;USE DESTINATION BYTE POINTER
CAIN E,11 ;TAB
JRST %23.TB
CAIN E,10 ;BS
JRST %23.BS
CAIN E,12 ;LF
JRST %23.LF
CAIN E,14 ;FF
JRST %23.FF
CAIN E,15 ;CR
JRST %23.ES
CAIN E,33 ;ESCAPE
JRST %23.ES
REMARK TEST FOR LEADING OPERATION SIGN IF NUMERIC
TXNE PRM,%DATE+%SSN ;SIGN NOT LEGAL FOR DATE AND SSN
JRST %23.8
TXNN PRM,NUMER%
JRST %23.8 ;NOT NUMERIC
MOVE A,INT.C ;[21]LENGTH OF SUBFIELD
SUB A,TXTTAB+.RDDBC ;[21]AND COMPUTE THE NUMBER OF CHARS
SOJG A,%23.8 ;[21]NOT THE FIRST CHARACTER.
SKIPE FRSTSB ;[27]IF NOT THE FIRST SUB FIELD
JRST %23.8 ;[27] THEN ALSO AN ERROR.
CAIE E,"-" ;LEADING SIGN
CAIN E,"+"
SKIPA ;YES-OK.
JRST %23.8 ;NO - ILLEGAL CHARACTER
MOVEI A,"0" ;[21]IF A PLUS REPLACE WITH 0.
CAIN E,"+" ;[21]IS IT A PLUS ?
DPB A,TXTTAB+.RDDBP ;[21] YES...REPLACE IT.
JRST %23.TI ;[21]CONTINUE
;;;;;;;;;;;;;;;;;;; ERRONEOUS CHARACTER ;;;;;;;;;;;;;;;;
%23.8:
HRROI C,MSG.NN ;GUESS NOT NUMERIC
TXNN PRM,NUMER% ;SKIP IF RIGHT
HRROI C,MSG.NA ;WRONG - THEN ALPHA
TXNE PRM,ALPHA% ;JUST ALPHA ?
HRROI C,MSG.AO ;WRONG AGAIN - ALPHA ONLY
PUSH P,E ;SAVE THE CHARACTER.
CALL INTERR ;INTERNAL ERROR CALL
CALL BACKUP ;BACK UP THE TEXTI POINTERS
POP P,E ;RESTORE THE CHARACTER.
CAIGE E,40 ;IF AN ILLEGAL CONTROL CHARACTER
JRST [CALL BACKCU ;BACKUP THE CURSOR
JRST %23.TI] ; AND CONTINUE.
CALL DOABS ;BACKSPACE CURSOR ON SCREEN IF ANY
JRST %23.TI ;DO TEXTI WITHOUT REINITTING
%23.TB: CALL BACKUP ;T A B -- ENDED FIELD READ.
MOVEI A,TRM.TB ;TAB TERMINATOR
JRST %23.12 ;COMMON ENDING
%23.LN: MOVEI A,TRM.LN ;READ TERMINATED ON LENGTH.
JRST %23.12
%23.CR: MOVEI A,1 ;[33] C R --ENDED READ (JUSTIFY FIELD)
MOVEM A,DEFALT ;[33] IF REQUIRED.
MOVEI A,TRM.CR
SKIPE OLDCR ;[37]IF USER WANT'S CR.EQ.LF
MOVEI A,TRM.LF ;[37] THEN DO IT.
JRST %23.12
%23.LF: CALL BACKUP ;L F (LINE FEED) TERMINATED READ.
MOVEI Z,1 ;[33]JUSTIFY LAST FIELD
MOVEM Z,DEFALT ;[33] IF REQUIRED.
MOVEI A,TRM.LF
JRST %23.12
%23.FF: CALL BACKUP ;F F (FORM FEED) TERMINATED READ.
MOVEI Z,1 ;[33]JUSTIFY LAST FIELD
MOVEM Z,DEFALT ;[33] IF REQUIRED.
MOVEI A,TRM.FF
JRST %23.12
;;;;;;;; FIELD OR SUBFIELD ALL IN -- SO CHECK LEGALITY ;;;;;;;;
;[27] MAKE ALL THIS WORK RIGHT
%23.12:
MOVEM A,TRMCHR ;SAVE THE TERMINATION CODE.
SKIPE FRSTSB ;[27]IF NOT IN FIRST FIELD
JRST %2312K ; THEN BYPASS CHECKS
MOVE A,INT.C ;COMPUTE THE NUMBER OF CHARS
SUB A,TXTTAB+.RDDBC ; TYPED IN.
SOJGE A,%2312K ;IF ANY TYPED BYPASS CHECKS
;NO CHARACTERS TYPED
TXNN PRM,REQD% ;IF NOT A REQUIRED FIELD
JRST %2312Z ; THEN ALL IS GOOD
;NO CHARACTERS TYPED, BUT REQUIRED.
TXNN PRM,PRDUP% ;IF NOT PREVIOUS DUPE
JRST [SKIPE MAXFLD ;[71]IF BACKING OVER THE FIELD
JRST .+1 ;[71] THEN TREAT LIKE PREV-DUPE.
JRST %2312G] ;[71] ELSE TREAT AS BLANK FIELD.
CALL LD.NUMRD ;GET LAST AMOUNT IN PREV DUPE
JUMPG A,%2312Z ; AND NO CHECKS IF MORE THAN 0.
%2312G: ;NO CHARACTERS TYPED--BUT THEY WERE REQUIRED
HRROI C,MSG.RQ ;SO ISSUE ERROR
CALL INTERR
JRST %23.TI
%2312K:
TXNN PRM,FULL% ;IF THIS IS NOT A FULL FIELD
JRST %2312P ; THEN DO NOT CHECK FOR IT.
SKIPN TXTTAB+.RDDBC ;IF FIELD WAS FULL
JRST %2312P ; THEN GO ON TO NEXT CHECK.
HRROI C,MSG.FF ; ELSE DO THE ERROR MESSAGE.
CALL INTERR
JRST %23.TI
%2312P:
TXNN PRM,%YN ;IF THIS IS NOT A YES/NO FIELD
JRST %2312Z ; THEN WE WON THE CHECKS.
MOVE C,TXTTAB+.RDBFP ;GET BEG OF FIELD PTR
ILDB B,C
CAIE B,"Y" ;YES
CAIN B,"N" ;NO
JRST %2312Z ;YES.
HRROI C,MSG.YN
CALL INTERR
CALL BACKUP
CALL DOABS
JRST %23.TI
%2312Z:
JRST %23.14
;[27] END OF VALIDITY CHECKING ON SUBFIELD LEVEL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
%23.BS: CALL BACKUP ;B S (BACKSPACE) TERMINATED READ.
JRST %23BAK ;DO THE BACKUP.
;;;;;;;;;;;
%23.14: SETZ B, ;RETURN LENGTH AND TERMINATOR.
%23.CE:
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
RET ; RETURN WITH COUNT IN 'A'.
SETZM NEWDAT ;INDICATE NO NEW DATA WAS ENTERED.
SKIPE MAXFLD ;[71]IF IN A BACKUP MODE
PJRST LD.NUMRD ;[71] THEN GET THE OLD COUNT.
TXNE PRM,PRDUP% ;RET IF NORMAL FIELD
CALL LD.NUMRD ;ELSE LENGTH IS SAME AS LAST LENGTH
RET
%23.ES: CALL BACKUP ;E S C (ESCAPE/SEL) TERMINATED.
CALL ECOOFF ;TURN OFF ECHO
CALL $RDCHAR ;GET THE CHARACTER
push p,a
CALL ECOON ;BACK ON
pop p,a
SKIPE OLDUD ;[37]IF UP-DOWN ARROW ILLEGAL THEN
JRST %23ESA ;[37] THEN DO NOT CHECK ON ARROWS.
CAIE A,"A" ;IF UP ARROW OR
CAIN A,"B" ; DOWN-ARROW THEN
JRST %23.CR ; TREAT LIKE CARRIAGE RETURN.
CAIE A,"C" ;IF RIGHT-ARROW OR
CAIN A,"D" ; LEFT ARROW THEN
JRST [SKIPE OLDAR ;[37] IF NO SPECIAL TREATMENT
JRST %23.CR ;[37] THEN TREAT AS CARRIAGE RETURN
JRST %23ESB] ;[37] ELSE DO SPECIAL TREATMENT
%23ESA: ;NOT AN ESC-ARROW OR NOT PROCESSING THESE.
CAIN A,12 ;IF LINE-FEED AFTER A CARRIAGE RETURN
JRST %23.CR ; THEN PROCESS THE CARRIAGE RETURN.
SETZ B,
CAIN A,"P" ;PUNT FIELD
MOVEI B,1
CAIN A,"Q" ;PUNT SECTION
MOVEI B,2
CAIN A,"R" ;REFRESH SCREEN
MOVEI B,3
SKIPE B
JRST %23.CE
HRROI C,MSG.ES ;BAD ESCAPE SEQUENCE
CALL INTERR
JRST %23.TI ;INPUT SOME MORE
%23ESB: ;SPECIAL HANDLING FOR RIGHT AND LEFT ARROW.
CAIN A,"D" ;IF LEFT-ARROW
JRST %23ESC ; THEN GO PROCESS IT
MOVEI A,TRM.TB ;ELSE TREAT IT AS A TAB
JRST %23.12
%23ESC: ;LEFT ARROW.
%23BAK: ;BACKUP CODE
CALL BACKUP ;DO A LOGICAL BACKUP
JRST [CALL DOABS ;THERE WAS A CHARACTER
JRST %23.TI] ;FINISH TEXTI
HRROI C,MSG.BU ;BACK UP NO FURTHER
CALL INTERR ;TELL USER
JRST %23.TI ;TRY AGAIN
BACKUP:
CAMG INT.C,TXTTAB+.RDDBC ;ANY BYTES LEFT ?
JRST SKPRET ;SKIP RETURN IF NONE LEFT
SETO A, ;MINUS ONE BYTE
IBP A,TXTTAB+.RDDBP ;IN B
MOVEM A,TXTTAB+.RDDBP
AOS TXTTAB+.RDDBC ;UP BYTES REMAINING
RET
DOABS:
;REPOSITION THE CURSOR TO LAST CHARACTER
PUSH P,A
PUSH P,B
MOVE B,HICOLM ;IF WE HAVE PASSED THE
CAMGE B,INTCOL ; END OF THE SCREEN
JRST [MOVE A,LINFLD ; THEN POSITION THE HARD
SETOM INTCOL ; WAY.
CALL $POSIT
JRST INTTRB]
CALL BACKCU ; ELSE JUST BACKUP THE CURSOR.
INTTRB:
MOVE A,FILCHAR ;SET UP THE FILLER CHARACTER.
CALL $SCHAR ;[64]SEND CHARACTER IN 'A'
CALL $SEND ;[64]AND MAKE SURE IT GOES.
SKIPGE INTCOL ;IF THE LAST CHARACTER WAS OFF THE SCREEN
JRST [AOS INTCOL ; THEN MERELY CONTINUE
POP P,B
POP P,A
RET]
CALL BACKCU ; ELSE BACKUP CURSOR.
POP P,B
POP P,A
RET
BACKCU: ;BACKUP CURSOR.
PUSH P,A
MOVEI A,33 ;USE THE ESC-D SEQUENCE
CALL $SCHAR ;[64]SEND CHARACTER IN 'A'
MOVEI A,"D"
CALL $SCHAR ;[64]SEND CHARACTER IN 'A'
CALL $SEND ;[64]AND MAKE SURE IT GOES.
POP P,A
RET
SKPRET: AOS (P) ;SKIP RETURN
RET
SUBTTL ----- PHYSICAL DATA ENTRY ROUTINE -- TEXTI.
;**********************************************
;
;[15] --- ROUTINES FOR SIMULATING TEXTI. ROUTINE
;
;**********************************************
TEXTI.: ;REPLACEMENT ROUTINE FOR TEXTI JSYS
PUSH P,PRM ;SAVE THIS REGISTER
MOVEI PRM,(A) ;SAVE POINTER TO TXTTAB
SKIPG B,.RDDBC(PRM) ;IF ZERO OR LESS CHAR COUNT
JRST GOODCHR ; THEN INDICATE WE ARE DONE.
SETZM ISTAB ;[20] INDICATE NO TAB ON PREVIOUS DUPE SEEN.
MOVE A,FILCHAR ;[25] SAVE THE FILLER FOR ERRORS
SKIPE PREDUP ;[25]IF THIS IS PREVIOUS DUPE
JRST [MOVE B,.RDDBP(PRM);[25] THEN
ILDB A,B ;[25] GET SAVE THE FIRST
JRST .+1] ;[25] CHARACTER
MOVEM A,FRSTCHR ;[25]
SETZ A, ;[72]CLEAR INPUT CHARACTER
TXTI.: CALL $RDCHAR ;LOOP FOR CHARACTERS
JUMPE A,TXTI. ;[72]IF NULL FORGET IT (FOR CONTROL/C)
SKIPE ERRDSP ;WAS THERE AN ERROR ON LAST CHARACTER?
CALL TXTERR ;YES---GO CLEAR IT.
SKIPE PREDUP ;ARE WE ABOUT TO DO A PREVIOUS DUP ?
JRST [CALL TXTPRE ;YES -- HANDLE IT
JRST .+1 ;NORMAL RETURN
JRST .+2 ; BYPASS DEPOSITING THE CHARACTER
JRST TXTI.] ; BACKSPACE
IDPB A,.RDDBP(PRM) ;DEPOSIT THE CHARACTER.
SOS B,.RDDBC(PRM) ;SUBTRACT 1 FROM CHARACTER COUNT
MOVE C,FLDTYP ;GET TYPE OF DATA TO INTERRUPT ON
TDNN C,CHRTAB(A) ;IS IT INTERRUPT CHARACTER ?
JRST GOODCHR ;NO...SEE IF FIELD DONE
MOVE B,[RD%BTM] ;INDICATE BREAK ENDED FIELD
MOVEM B,.RDFLG(PRM) ;STORE IT.
DONCHR:
MOVEI E,(A) ;[20]RETURN FINAL CHARACTER.
POP P,PRM ;RESTORE REGISTER
AOS (P)
POPJ P, ;RETURN TO USER
GOODCHR:
JUMPG B,TXTI. ;NOT FINISHED
SETZM .RDFLG(PRM) ;INDICATE GOOD LENGTH
JRST DONCHR
TXTERR: ;ERROR ON LAST CHARACTER---CLEAR IT.
CAIN A,33 ;IF AN ESCAPE THEN
RET ; HONOR IT.
PUSH P,A
CALL CLRERR ;CLEAR OFF THE ERROR MESSAGE
SETZM ERRDSP ;TURN OFF INDICATOR
MOVE B,LENFLD ;GET THE FIELD LENGTH
SUB B,.RDDBC(PRM) ; AND SUBTRACT NUMBER OF CHARS LEFT.
AOS B ;
ADD B,COLFLD ;GET COLUMN NUMBER
MOVE A,LINFLD ;GET THE LINE NUMBER
CALL $POSIT ;POSITION
MOVE A,(P) ;GET THE CHARACTER BACK
CAIN A,10 ;[30]IF THIS IS A BACKSPACE
CALL $SCHAR ;[64]SEND THE CHARACTER OUT
CALL $SEND ;[64]MAKE SURE IT GOT THERE
POP P,A ;RESTORE THE CHARACTER
RET
TXTPRE: ;STARTING A PREVIOUS DUP FIELD
MOVEI B,FCCCHR+CONCHR ;[25]LEAVE PREDUPE FIELD ON ANY
TDNN B,CHRTAB(A) ;[25] END OF FIELD CHAR.
JRST TXTP50 ;NO..USER IS TYPING A NEW VALUE
SETOM ISTAB ;[20] INDICATE TABBED OUT OF PREVIOUS DUPE.
CAIN A,10 ;[25] IF THIS IS A BACKSPACE
JRST [ AOS (P) ;[25] THEN DO NOT MOVE
AOS (P) ;[25] THE CURSOR
RET] ;[25]
IBP .RDDBP(PRM) ;[20] BUT ACT AS IF WE DID.
AOS (P) ;[20]DO NOT DEPOSIT CHARACTER
RET ;AND CONTINUE NORMALLY.
TXTP50: ;HERE WHEN USER WANTS TO CONTINUE.
SETZM PREDUP ;FLAG PREVIOUS DUPE INDICATOR
PUSH P,A ;SAVE CURRENT CHARACTER
MOVE A,FILCHAR ;REPLACE WITH THE FILLER.
MOVEM A,FRSTCHR
PUSH P,LINFLD ;[46]SAVE THE CURRENT LINE NUMBER,
PUSH P,COLFLD ;[46] COLUMN NUMBER,
PUSH P,PRM ; AND INDEX
PUSH P,INT.A ;SAVE THE WORLD
PUSH P,CURFLD
PUSH P,C
PUSH P,LENFLD
PUSH P,SUBX
PUSH P,SUBY
PUSH P,SUBP
MOVE INT.A,CURFLD ;SET UP TO POINT AT CURRENT FIELD
SETZM CURFLD ;INDICATE CURRENT FIELD
CALL INITAL ; AND INITIALIZE IT.
POP P,SUBP
POP P,SUBY
POP P,SUBX
POP P,LENFLD
POP P,C
POP P,CURFLD
POP P,INT.A
POP P,PRM ;RESTORE MY VARIABLES
POP P,COLFLD ;[46]
POP P,LINFLD ;[46]
DMOVE A,LINFLD ;GET POSITION OF THIS FIELD
CALL $POSIT ;POSITION TO IT.
MOVE A,(P) ;GET THE CHARACTER
;[64]
CALL $SCHAR ;[64]OUTPUT THE CHARACTER
CALL $SEND ;[64]AND MAKE SURE ITS THERE
POP P,A ;RESTORE THE CHARACTER
RET ;AND CONTINUE NORMALLY.
;************************************************
;
;[15] --- END OF TEXTI. SIMULATION
;
;************************************************
;
; VT52 TERMINAL SPECIFIC OPERATIONS
;
;
;[36] IS AN EDIT WHICH IS COMPLEMENTARY TO THE REMOVAL OF THE
;[36] TEXTI JSYS.
$RDCHAR: PBIN ;READ THE CHARACTER
CAIN A,RUBOUT ;[106]IF THIS IS A RUBOUT
MOVEI A,BACKSP ;[106] THEN MAKE IT A BACKSPACE.
RET ;RETURN WITH CHAR IN 'A'.
$CLIBF: MOVEI A,.PRIIN ;CLEAR THE TERMINAL INPUT
CFIBF ; BUFFER.
RET
ECOON:
MOVEI A,.PRIIN
RFMOD
TXO B,TT%ECO
SFMOD
RET
ECOOFF:
MOVEI A,.PRIIN
RFMOD
TXZ B,TT%ECO
SFMOD
RET
$TTCHK: ;[55] CHECK THE STATUS OF THE TERMINAL ON EACH CALL
SKIPN TTOPN ;[55]IF TERMINAL IS NOT OPEN DO IT.
CALL $TTOPN ;[55]
CALL $TTSET ;[43]AT ANY RATE, RESET THEM.
RET ;[55]RETURN TO CALLER.
$TTOPN:
SKIPE TTOPN ;IF TTY IS OPEN
RET ; THEN FORGET IT.
MOVEI A,.PRIOU
RFMOD
MOVEM B,OLDMOD
RFCOC ;[55]GET CONTROL CHARACTER BITS
DMOVEM B,COC ;[55] AND SAVE THEM.
CALL $TTSET ;[43]SETUP THE TERMINAL CHARACTERISTICS.
SETOM TTOPN ;[55]INDICATE TERMINAL NOT OPEN.
RET
$TTSET: ;[43]SET THE TERMINAL MODES
SKIPE DORESET ;[72]IF FORCED RESET, DO IT.
CALL $TTRST ;[72]BUT IF IT HAS, MAKE SURE TO RESET.
CALL DOATI ;TURN ON THE INTERRUPT SYSTEM
MOVEI A,.PRIOU ;[43] USE PRIMARY JFN
MOVE B,NEWMOD ;[43] AND NEW MODE BITS
SKIPE OLDLC ;[61]IF LOWER CASE IS BEING ALLOWED
MOVE B,NLCMOD ;[61] THEN DO NOT TRANSLATE
STPAR ;[43] TO SET THE PROPER CONTROLS
SFMOD ;[43]
DMOVE B,$.BYTE ;[43]ALSO INSURE CONTROL CHARS ARE NOT
SFCOC ;[43] ECHOED.
RET ;[43]
DOATI:
SKIPE INTSET ;ARE INTERRUPTS SETUP ?
RET ;YES
MOVEI A,.FHSLF ;[72]NORMALLY INHIBET CONTROL/C
RPCAP ;[72] TRAPPING UNLESS SPECIFIED
TXZ C,SC%CTC ;[72]INITIALIZE IT TO OFF
SKIPE OLDCC ;[72]IF WE WANT CONTROL/C TRAPPING
TXO C,SC%CTC ;[72] THEN LABEL IT ON.
EPCAP ;[72]AND SET THE CAPABILITY.
MOVSI A,.TICCC ;[72]INDICATE CONTROL-C TRAPPING
ATI ;[72] THEN TRAP THE INTERRUPT.
ERJMP .+1 ;[72] BUT ALLOW TO WORK IF HE/SHE HASN'T
MOVSI A,.TICCO ;CONTROL/O
ATI
MOVSI A,.TICRB ;RUBOUT
SKIPN OLDRB ;[106]IF RUBOUT TO BE TRAPPED,
ATI ;[106] THEN SET THE INTERRUPT.
MOVSI A,.TICCR ;CONTROL/R
ATI ;;DEBUG
MOVSI A,.TICCT ;CONTROL/T
ATI
MOVSI A,.TICCU ;CONTROL/U
ATI
MOVSI A,.TICCV ;CONTROL/V
ATI
MOVSI A,.TICCW ;CONTROL/W
ATI
MOVSI A,.TICCS ;CONTROL/S
SKIPN OLDCS ;[105]IF XON/XOFF NOT ALLOWED
ATI ;[105] THEN SET INTERRUPT.
MOVSI A,.TICCQ ;CONTROL/Q
SKIPN OLDCS ;[105]IF XON/XOFF NOT ALLOWED
ATI ;[105] THEN SET INTERRUPT.
;[36] MOVE A,[.TICTI,,1]
;[36] ATI
REMARK SET ALL INTERUPTS DEFERRED
MOVE A,[RT%DIM+.FHSLF]
RTIW
;[36] SETO 3, ;ALL TYPIN CHAR ARE DEFERRED
HRLI A,0
STIW
SETOM INTSET ;INDICATE INTERRUPTS ARE SET UP.
SETZM DORESET ;[72]NO NEED TO FORCE RESET.
RET
$TTRST: ;[62]RESET THE TERMINAL MODES
SKIPN TTOPN ;IF THE TERMINAL IS NOT OPEN
RET ; THEN NO NEED TO RESET.
MOVEI A,.PRIOU
MOVE B,OLDMOD ;RESTORE OLD MODE WORD
STPAR
SFMOD
DMOVE B,COC ;RESTORE THE OLD CHARACTERISTICS
SFCOC
SKIPN INTSET ;IF INTERRUPTS ARE NOT SET
RET ; THEN NOTHING TO DO.
;REMOVE THE INTERRUPT CHARACTERS
MOVEI A,.TICCC ;[72]CONTROL/C
DTI ;[72]
ERJMP .+1 ;[72]PREPARE FOR THE WORST.
MOVEI A,.TICCO ;CNTRL/O
DTI
MOVEI A,.TICRB ;RUBOUT
DTI
MOVEI A,.TICCR ;CNTRL/R
DTI ;;DEBUG
MOVEI A,.TICCT ;CNTRL/T
DTI
MOVEI A,.TICCU ;CNTRL/U
DTI
MOVEI A,.TICCV ;CNTRL/V
DTI
MOVEI A,.TICCW ;CNTRL/W
DTI
MOVEI A,.TICCS ;CNTRL/S
DTI
MOVEI A,.TICCQ ;CNTRL/Q
DTI
SETZM INTSET ;CLEAR INTERRUPT SET FLAG.
RET
;;[62] END OF RESET
$ERASE:
HRROI A,[BYTE (7)33,"K",0,0,0]
JRST PUTOUT
$POSIT:
ADDI A," "-1 ;CREATE LINE NUMBER.
ADDI B," "-1 ;CREATE COLUMN NUMBER.
PUSH P,A ;SAVE LINE NUMBER
MOVEI A,33 ;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.
RET ;RETURN
PUTOUT:
CALL $SASCIZ ;[64]SEND OUT ASCIZ STRING
RET
$CLEAR:
HRROI A,[BYTE (7)33,"H",33,"J",0]
JRST PUTOUT
$HOME:
HRROI A,[BYTE (7)33,"H",0,0,0]
JRST PUTOUT
$TTCLS:
CALL $CLEAR ;CLEAR TERMINAL FIRST
CALL $SEND ;[64]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
;[36] NEWMOD: TT%LCA+TT%WKF+TT%WKN+TT%WKP+3B29+TT%WKA+TT%ECO+TT%PGM
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
PAGE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; TERMINAL OUTPUT ROUTINES -- DEFINED WITH EDIT [64]
;
; $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,$SBUFPNT ;INITIALIZED BUFFER POINTER
MOVEM A,$SBPTR ;AND SET UP DYNAMIC ONE.
RET
$SEND: ;SEND OUT THE BUFFER
SKIPG A,$SNUM ;IF NOTHING TO SEND THEN
RET ; THEN DO NOT SEND IT.
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,$SBUFPNT ;GET POINTER TO BUFFER.
PSOUT ;SEND IT.
CALL $SBEGIN ;RE-INITIALIZE
RET
$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
$SCHAR: ;SEND THE CHARACTER IN 'A'
SKIPG A ;IF NULL CHARACTER THEN
RET ; FORGET IT.
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 THEIR ARE
JRST [AOS OVRFLOW ; THEN COUNT OVERFLOWS
CALL $SEND ; SEND OUT THE BUFFER
JRST .+1] ; AND CONTINUE.
POP P,A
RET
$SSTRING: ;SEND THE 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
CALL $SCHAR ;SEND OUT THE CHARACTER IN 'A'
SOJG C,.-1 ; SPIN UNTIL ALL DONE.
RET ;RETURN
SUBTTL TFRCLR - CLEARS A FIELD, SECTION, OR FORM FROM SCREEN
LBL 4
COMMENT +
CALL TFRCLR (FIELD-ID, ERR)
RETURN (ERR)
+
TFRCLR:
ENTER FRMCLR,2,0 ;[7] ALLOW TWO OR ZERO
CALL $SBEGIN ;[64]RESET THE OUTPUT BUFFER.
SETZM ALLCLR
CALL $TTOPN ;MAKE SURE TERMINAL IS OPEN
HLRZ A,-1(ARG) ;GET ARG COUNT
JUMPN A,%4.1 ;MORE THAN ZERO - JUMP
SETOM ALLCLR
SETZ INT.A,
SKIPN DATJFN ;ANY FORMS INITED YET ?
JRST %4.12 ;NO - JUST CLEAR SCREEN
JRST %4.2
%4.1: MOVEI INT.A,@0(ARG) ;GET W.S. POINTER
HRRZ INT.B,1(INT.A)
SKIPN INT.A,0(INT.A) ;IF USER SPECIFIED, 'CLEAR FORM',
SETOM ALLCLR ; THEN SET FLAG TO CLEAR SCREEN.
SETZM @1(ARG) ;[17]INDICATE VALID ERROR RETURN.
%4.2: CALL FIND ;SETUP NEXT FIELD.
JRST %4.8 ;NOT FOUND = ERROR
JRST %4.9 ;NO MORE = DONE
JFCL
TXNE PRM,%DSPLY ;ON SCREEN
JRST %4.4 ;YES
SKIPE ALLCLR ;NO--CLEAR EVERYTHING?
JRST %4.2
JRST %4.10
%4.4:
SKIPN INT.A ;IF CLEARING THE WHOLE SCREEN
JRST %4.7 ; THEN JUST MARK EACH FIELD.
LOAD A,.FILLR ; ELSE
SKIPE A ; IF THE FILLER IS NOT A BLANK
JRST [CALL ABLANK ; THEN BLANK WHOLE THING
JRST %4.7] ; AND MARK THE FIELD
CALL BLANK ; ELSE BLANK ONLY UNSPACED CHARACTERS.
CALL $SCHKPNT ;[64]WRITE OUT TERMINAL BUFFER IF NECESSARY.
%4.7: TXZ PRM,%DSPLY ;INDICATE FIELD NOT ON SCREEN.
CALL STRPRM ;PUT PRM BACK
JRST %4.2 ;GO FOR NEXT FIELD
%4.8: MOVEI A,ERR.NF ;FIELD NOT FOUND ERROR.
MOVEM A,@1(ARG)
RET
%4.9: ;NORMAL EXIT
JUMPE INT.A,%4.11 ;JUMP IF NO ARGUMENT OR FORM SPECIFIED.
;[41] CALL $HOME
CALL $SEND ;[64]CLEAR THE OUTPUT BUFFER
RET
%4.10: MOVEI A,ERR.ND ;FIELD NOT DISPLAYED ERROR.
MOVEM A,@1(ARG) ;NOT DISPLAYED FIELD ERROR
JRST %4.2 ;[17] CONTINUE TILL REQUEST EXHAUSTED.
;[17] RET
;RESET TTY MODE WORD IF FORM CLEAR
%4.11:
HLRZ A,-1(ARG) ;CLEARING WHOLE SCREEN.
JUMPE A,%4.12 ;IF USER SPECIFIED 'FORM',
CALL $CLEAR ; THEN CLEAR THE SCREEN AND
CALL $SEND ; FORCE CLEAR OUT
RET ; RETURN TO CALLER
%4.12: ; ELSE
CALL $TTCLS ; CLEAR SCREEN AND CLOSE TERMINAL.
RET
SUBTTL CLRERR -- CLEAR ERROR LINE
LBL 13
CLRERR:
MOVE A,ERRLIN ;LOCATION OF ERROR LINE FOR FORM.
MOVEI B,1 ;STARTING AT FIRST POSITION
CALL $POSIT ;POSTION TO LINE AND COLUMN
CALL $ERASE ; AND ERASE THE LINE.
RET ;RETURN TO CALLER
SUBTTL TFRERR - USER GENERATED ERROR MESSAGES
TFRERR:
ENTER FRMERR,3 ;[7]
SETZM CURERR ;NO ERRORS YET
SETZM @2(ARG) ;ERROR RET
CALL $SBEGIN ;[64]INITIALIZE TERMINAL OUTPUT BUFFER
MOVE A,CURFLD ;SAVE FOR LATER
PUSH P,A
MOVEI INT.A,@1(ARG) ;GET W.S. POINTER
HRRZ INT.B,1(INT.A)
MOVE INT.A,0(INT.A)
PUSH P,INT.A ;SAVE
SKIPLE INT.A
CALL INITAL
POP P,INT.A ;RESTORE
POP P,A ;&CURFLD
MOVEM A,CURFLD
MOVE A,CURERR
JUMPE A,%FE.1 ;NO ERROR
MOVEM A,@2(ARG)
;[56] RET
%FE.1:
MOVEI B,@0(ARG) ;[70]GET THE ADDRESS OF ERROR MESSAGE
MOVE A,0(B) ;[70] BYTE POINTER AND
HRRZ B,1(B) ;[70] ITS LENGTH
PUSH P,A ;[70]SAVE THE BYTE POINTER
CALL TRNCBL ;[70]AND THEN FIND LAST NON-BLANK.
MOVEI A,(B) ;[70]GET LENGTH.
POP P,B ;[70]RESTORE BYTE POINTER TO 'B'
MOVEI D,(A) ;[70] AND USE LENGTH RETURNED FROM TRNCBL
MOVE E,[POINT 7,INTBUF] ;[70] IN ORDER TO MOVE THE SIGNFICANT
EXTEND A,[MOVSLJ] ;[70] CHARACTERS TO INTBUF.
JFCL ;[70]
SETZ A, ;[70]STORE A NULL BYTE AT THE
IDPB A,E ;[70] END IN ORDER TO MAKE ASCIZ STRING
HRROI C,INTBUF ;[70] STARTING AT INTBUF WHICH IS
CALL PUTMSG ;[70] TO BE PUT ON ERROR LINE
CALL $SEND ;[70] FORCE THE MESSAGE OUT.
RET ;[70].
INTERR: ;INTERNAL CALL TO ERROR
CALL PUTMSG
;[26] SKIPE DEFALT ;NO REPOSIT IF DEFAULTING
;[26] JRST CLRBF
MOVE A,LINFLD
MOVE B,COLFLD
ADD B,INT.C
MOVEM B,INTCOL ;[100]FLAG THAT WE ARE OFF THE SCREEN.
SUB B,TXTTAB+.RDDBC ;FORM NEW POSITION
CALL $POSIT
CALL $SEND ;[64]INSURE MESSAGE IS OUTPUT
CALL $CLIBF ;CLEAR TERMINAL INPUT BUFFER.
SETZM DEFALT ;CLEAR DEFAULTING
RET
PUTMSG:
MOVEI A,7 ;BELL
CALL $SCHAR ;[64]SEND ONE CHARACTER
CALL CLRERR ;CLEAR ERROR LINE
MOVE A,ERRLIN
MOVEI B,1
CALL $POSIT
MOVE A,C ;DISPLAY MSG
CALL $SASCIZ ;[64]SEND ASCII STRING
SETOM ERRDSP ;SAY ERROR IS ON SCREEN
SKIPN B,ERRRNG ;OUTPUT RANGE IF NEEDED
RET
MOVEI A,""""
CALL $SCHAR ;[64]SEND THE CHARACTER OUT.
MOVE A,B
CALL $SASCIZ ;[64]SEND ASCII STRING
MOVEI A,""""
CALL $SCHAR ;[64]SEND THE CHARACTER OUT.
SETZM ERRRNG
RET
SUBTTL TFRCHG - CHANGE ATTRIBUTES OF FIELDS
LBL 10
TFRCHG:
FRMCHG::
.CALL. ;[63]ALLOW COBOL 'CALL' VERBS.
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.
MOVEI INT.B,@0(ARG) ;SET UP POINTERS TO ATTRIBUTE/FIELD-ID PAIR.
MOVE INT.A,0(INT.B)
HRRZ INT.B,1(INT.B) ;LENGTH OF FIELD-ID
%10.3A: MOVE E,ARG ;ARG = PTR 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 %10.9 ;NOT THERE.
JRST %10.10 ;DONE
JFCL
POP P,C
POP P,E
POP P,D
%10.5: SOJL C,%10.3A ;IF NO MORE ATTRIBUTES THEN LOOP
AOS B,E
PUSH P,E
PUSH P,D
DMOVE D,[130
POINT 7,INTBUF] ;MOVE TO INTBUF
MOVE B,0(B) ;PTR TO 2-WD BLOCK
HRRZ A,1(B) ;LENGTH
MOVE D,A ;LENGTH OF DEST
MOVE B,0(B) ;BYTE PTR
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 ;IF NOT FOUND
JRST %10.11 ; THEN TRY NEXT ONE.
HRRZ A,(A) ; ELSE GET ADDRESS OF PROPER ROUTINE.
PUSHJ P,(A) ;DISPATCH TO ROUTINE
CALL STRPRM ;SAVE THE 'PRM' SETTINGS.
JRST %10.5
%10.9: MOVEI A,ERR.NF ;FIELD WAS NOT FOUND ERROR.
JRST %10.R
%10.10: SETZ A, ;GOOD RETURN.
JRST %10.R
%10.11: MOVEI A,ERR.IA ;INVALID ATTRIBUTE ERROR.
SETZM CURFLD ;DON'T FORGET TO RESET - EARLY EXIT (FIND)
JRST %10.RN
%10.R: POP P,C ;RESTORE SAVED
POP P,E ; REGISTERS.
POP P,D
%10.RN: SOJ D, ;ONE LESS ARG
ADDI D,(ARG)
MOVEM A,@(D) ;SET ERR CODE
RET
SUBTTL CG---- ROUTINES FOR USE BY TFRCHG
CGAB:
TXZ PRM,CLASS%
TXO PRM,ALPHA%
RET
CGAN:
;[13] TXO PRM,CLASS%
TXZ PRM,CLASS% ;[13]CLEAR THE ALPHA ONLY OR NUMERIC
; ONLY BITS.
RET
CGMD:
TXZ PRM,DUPE%
TXO PRM,MSDUP%
CALL LD.NUMRD ;[45]IF THE FIELD ALREADY HAS
SKIPE A ;[45] INFORMATION IN IT
TXO PRM,PRDUP% ;[45] 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
CGLR:
AOS B,E ;NEXT ATTRIBUTE
SOSGE C ;ONE LESS AROUND
PJRST SKPRET ;BOMB IF NONE LEFT
PUSH P,C
PUSH P,D
PUSH P,E
MOVE B,(B) ;GET PTR & LENGTH
HRRZ A,1(B) ;LENGTH
ANDI A,37 ;[12]LEAVE ONLY THE LENGTH BITS
TXZ PRM,RANGL% ;[31]TURN OFF LOWER RANGE CHKING.
JUMPE A,CGREX ;[31]IF NULL LENGTH, THEN NO RANGE CHK.
MOVE B,(B) ;PTR
CALL CGRGMV ;MOVE TO INTBUF
MOVE B,[POINT 7,INTBUF] ;[31]IF LOW VALUES
ILDB C,B ;[31] THEN LOWER RANGE CHKING OFF.
JUMPE C,CGREX ;[31]
LOAD E,.LRANG,0 ;DEST
SUB E,V11SYM ;[35]OFFSET TO THE PROPER
ADD E,V12SYM ;[35] PAGE.
HRLI E,(POINT 7,0)
MOVE D,LENFLD ;&LENGTH
TXO PRM,RANGL% ;SET RANGE INDICATOR
PJRST CGRGCM ;MOVE TO DESTINATION IN CORE
CGUR:
AOS B,E ;NEXT ATTRIBUTE
SOSGE C ;ONE LESS AROUND
PJRST SKPRET ;BOMB IF NONE LEFT
PUSH P,C
PUSH P,D
PUSH P,E
MOVE B,(B) ;GET PTR & LENGTH
HRRZ A,1(B) ;LENGTH
ANDI A,37 ;[12]LEAVE ONLY THE LENGTH BITS
TXZ PRM,RANGU% ;[31]TURN OFF UPPER RANGE CHK.
JUMPE A,CGREX ;[31]LEAVE OFF IF NULL INPUT.
MOVE B,(B) ;PTR
CALL CGRGMV ;MOVE TO INTBUF
MOVE B,[POINT 7,INTBUF] ;[31]IF USER SPECIFIED FIELD
ILDB C,B ;[31] OF LOW VALUES (ASCII 0),
JUMPE C,CGREX ;[31] THEN RETURN TO USER.
LOAD E,.URANG,0 ;DEST
SUB E,V11SYM ;[35] OFFSET TO THE PROPER
ADD E,V12SYM ;[35] PAGE.
HRLI E,(POINT 7,0)
MOVE D,LENFLD ;&LENGTH
TXO PRM,RANGU% ;SET RANGE INDICATOR
PJRST CGRGCM ;MOVE TO DESTINATION IN CORE
CGRGMV: ;MOVE TO INTBUF D-6 OR D-7
TXNN PRM,NUMER% ;SKIP IF NUMERIC
JRST [MOVE SIX27 ;MODIFY TABLE
TLZ 100000
MOVEM 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,NUMER% ;RESTORE TABLE IF NOT NUMER
PJRST [MOVE SIX27
TLO 100000
MOVEM SIX27
RET]
RET
CGRGCM: ;MOVE INTBUF TO DESTINATION & PAD
MOVE B,[POINT 7,INTBUF]
TXNN PRM,NUMER% ;NUMERIC ?
JRST CGCMAL ;NO
PUSH P,E ;[31] SAVE THE POINTER TO THE RANGE
EXTEND A,[MOVSRJ
"0"] ;ZERO FILL
JFCL
POP P,E ;[31] RESTORE THE POINTER.
MOVEI Z,"0" ;[31]INDICATE NON-BLANK SCANNING.
PUSH P,VALFLD ;[31]SAVE CURRENT VALUE POINTER
MOVEM E,VALFLD ;[31] AND POINT TO RANGE FIELD.
CALL REPZER ;[31]PUT IN STANDARD FORM.
POP P,VALFLD ;[31]RESTORE VALUE FIELD.
JRST CGREX ;[31]EXIT.
CGCMAL:
EXTEND A,[MOVSLJ
" "] ;SPACE FILL A/N
JFCL
JRST CGREX
CGREX:
POP P,E
POP P,D
POP P,C
;[12] PJRST SKPRET
RET ;[12] RETURN AND UPDATE PRM.
;[43] START OF NEW CALL FOR RESETING TERMINAL CHARACTERISTICS
SUBTTL TFRSET -- SET THE ATTRIBUTES OF THE TERMINAL
COMMENT ^
THIS ROUTINE IS NECESSARY AFTER CALLING A LOWER FORK OR
AFTER USING A DISPLAY TO THE TERMINAL.
THERE ARE NO ARGUMENTS.
^
TFRSET::
.CALL. ;[63]ALLOW COBOL 'CALL' VERBS.
CALL $TTCHK ;RESET THE TRAFFIC TERMINAL CHARACTERISTICS
RET ;RETURN TO CALLER.
SUBTTL TFRRST -- RESET TERMINAL CHARACTERISTICS FOR THE USER
;THIS WILL ALLOW USAGE OF CONTROL CHARACTERS, TFRSET
; OR DEFAULT STARTUP SHOULD BE CALLED WHEN TRAFFIC
; CONTROL IS NEEDED AGAIN
TFRRST::
.CALL. ;[63]ALLOW COBOL 'CALL' VERBS.
CALL $TTRST ;RESET THE TERMINAL CHARACTERISTICS
RET
PAGE
SUBTTL TFRRWT -- RE-WRITE THE SCREEN
; THIS IS SIMILAR TO USING THE BLACK KEY TO CAUSE THE CURRENT
; CONTENTS OF THE SCREEN TO BE REWRITTEN
;
; IT IS MOST USEFUL AFTER A CALL TO IPRUNI TO RUN A LOWER FORK.
;
; THERE ARE NO ARGUMENTS
;
TFRRWT::
.CALL. ;[63]ALLOW COBOL 'CALL' VERBS.
SKIPE OLDTT ;[43]IF WE NEED TO SET CHARACTERISTICS
CALL $TTCHK ;[44] THEN DO IT.
CALL $SBEGIN ;[64]INSURE TERMINAL BUFFER FLUSHED.
SETZB INT.A,CURFLD
CALL $CLEAR ;CLEAR ALL OF SCREEN
RWT.RF: ;RWT.R LOOP
CALL FIND
JRST RWT.RG ;NOT-FOUND.
JRST RWT.RG ; RESTORE REGISTERS.
JFCL ;[24]FOUND IT.
TXNN PRM,%DSPLY ;DO THOSE PREVIOUSLY ON SCREEN
JRST RWT.RF
CALL WRITE
CALL FILL
CALL $SCHKPNT ;[64]OUTPUT BUFFER IF GETTING FULL
JRST RWT.RF
RWT.RG:
SETZM CURFLD
CALL $SEND ;[64]MAKE SURE BUFFER IS OUTPUT
RET
;[43] END OF NEW CALLS
PAGE
;[44] START OF NEW CALL TO RETURN THE FIELD NUMBER BASED ON FIELD NAME.
;
;
; TFRFNO -- GIVEN A FIELD NAME IN SIXBIT OR ASCII, THIS ROUTINE WILL
; RETURN THAT FIELDS INTERNAL NUMBER. THIS NUMBER CAN
; THEN BE USED IN FUTURE CALLS IN ORDER TO GAIN MORE
; EFFICIENCY.
; ENTER MACRO USING FIELD-NAME, FIELD-NUMBER, ERROR
;
; FIELD-NAME -- DISPLAY-7 OR DISPLAY-6 NAME OF A FIELD AS
; SPECIFIED IN CURRENTLY INITIALIZED FORM.
;
; FIELD-NUMBER -- COMP ITEM FOR THE FIELD NUMBER TO BE RETURNED.
;
; ERROR -- COMP ITEM FOR THE ERROR RETURN.
;
TFRFNO::
ENTER FRMFNO,3
MOVEI INT.A,@(ARG) ;GET THE POINTER TO THE
HRRZ INT.B,1(INT.A) ; TO THE LENGTH
MOVE INT.A,0(INT.A) ; AND ITS FIELD-NAME.
JUMPE INT.A,FNO90 ;IF FORM,
HLRE A,INT.A ; OR
JUMPE A,FNO90 ; FIELD-NUMBER
AOJE A,FNO90 ; OR SECTION NUMBER THEN ERROR.
;OTHERWISE ITS A STRING POINTER.
CALL FIND ;FIND THIS FIELD
JRST FNO95 ;FIELD NOT FOUND.
JRST FNO95 ;NO MORE FIELDS
JFCL ;GOT THE FIELD
MOVE A,CURFLD ;GET THIS FIELD NUMBER
MOVEM A,@1(ARG) ;RETURN IT FOR USER
SETZM @2(ARG) ;INDICATE NO ERROR
SETZM CURFLD ;CLEAR FIRST FIELD INDICATOR
RET ;RETURN TO CALLER.
FNO90:
MOVEI A,ERR.BA ;BAD ARGUMENT IN CALL
JRST FNO99 ;EXIT.
FNO95:
MOVEI A,ERR.NF ;FIELD ID NOT FOUND
SETZM CURFLD ;CLEAR FIELD INDICATOR
JRST FNO99
FNO99:
MOVEM A,@2(ARG) ;RETURN AN ERROR
SETZM @1(ARG) ;CLEAR RETURNED VALUE
RET ;RETURN TO CALLER.
PAGE
;[53] BEGIN NEW SUBROUTINE CALL TO CHANGE SYSTEM VARIABLES.
SUBTTL TFRSYS
;;;;;
;
; TFRSYS -- GIVEN A SYSTEM VARIABLE NUMBER, THIS ROUTINE WILL RETURN
; ITS CURRENT VALUE AND UPDATE ITS VALUE TO THAT SPECIFIED BY
; THE CALLER
;
; ENTER MACRO TFRSYS VARIABLE#,NEW-VALUE,OLD-VALUE,ERROR.
;
; ALL VARIABLES ARE COMPUTATIONAL.
;
; 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.
;
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 ;IF -1, THEN RESET TERMINAL CHARACTERISTICS
; ON EACH TRAFFIC CALL.
;IF 0, THEN ONLY RESET THEM ON DEMAND (TFRSET).
OLDRN ;IF 0, THEN REWRITE NUMERIC VALUES RIGHT JUSTIFIED.
;IF -1, THEN DO NOT REWRITE THESE VALUES.
OLDLC ;IF 0, THEN NO LOWERCASE, IF -1 THEN LC.
SYS100,,OLDCC ;[104]IF 0, THEN NO CONTROL/C TRAPPING, IF
SYS100,,OLDCS ;[105]IF 0, THEN XON/XOFF IGNORED
;[105]IF-1, THEN XON/XOFF USED FOR CONTROL.
SYS100,,OLDRB ;[106]IF 0, THEN RUBOUT IGNORED
;[106]IF-1, THEN RUBOUT IS BACKSPACE.
;[72]-1 THEN CONTROL/C TRAPPING.
SYSMAX=.-SYSTAB
TFRSYS::
ENTER FRMSYS,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.
CAILE A,SYSMAX ;IF NOT LEGAL NUMBER
JRST SYS90 ; THEN INFORM USER.
SYS50:
HRRZ C,SYSTAB(A) ;[104]GET ADDRESS OF VARIABLE
MOVE B,(C) ;[104]GET CURRENT VALUE OF VARIABLE.
;[104] MOVE B,@SYSTAB(A) ;GET CURRENT VALUE OF FIELD
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) ;[104]STORE NEW VALUE.
;[104] MOVEM B,@SYSTAB(A) ;STORE THE NEW VALUE
HLRZ C,SYSTAB(A) ;[104]GET THE ROUTINE TO CALL IF ANY
SKIPE C ;[104] IF EMPTY THEN NO ROUTINE.
CALL (C) ;[104]ELSE CALL THE ROUTINE.
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:
MOVEI A,ERR.IV ;INVALID VARIABLE NUMBER
JRST SYS99
SYS95:
MOVEI A,ERR.NV ;ARGUMENT NOT 0 OR -1.
SYS99: MOVEM A,@3(ARG) ;STORE THE ERROR.
RET
SYS100: SETOM DORESET ;[104]MAKE SURE WE CHANGE SOMETHING.
CALL $TTCHK ;[104] DURING CHECK.
RET
;;;;;;;;;;;;;;;[53] END OF ADDITION;;;;;;;;
;[44] END OF EDIT
SUBTTL GETFIL - GET AND OPEN INPUT DATA FILE
GETFIL:
HRRZ A,1(INT.A)
MOVE B,0(INT.A)
TLNN B,100 ;ASCII IN COBOL
MOVE B,[POINT 7,INTBUF] ;NO - CONVERTED IN INTBUF
DMOVE D,[130 ;LENGTH OF INT.BUF.
POINT 7,FRMFIL]
EXTEND A,[ MOVSLJ
" "] ;FILL WITH SPACES
JRST .GTF1 ;FILE NAME TOO LONG
SKIPN A,DATJFN ;[6] SKIP IF FILE OPEN
JRST .GTF0 ;[6] SKIP CLOSF IF NOT
MOVE B,V12DAT ;[52]FREE THE DATA PAGES
; MOVE B,V12DCO ;[54]REAL ADDRESS GOTTEN
MOVE C,DATSIZ ;[52] BY SPECIFYING LOCATION
CALL FREPAG ;[52] AND SIZE.
MOVE B,V12SYM ;[52]THEN FREE THE SYMBOL PAGES
; MOVE B,V12SCO ;[54]REAL ADDRESS GOTTEN
MOVE C,SYMSIZ ;[52] BY SPECIFYING LOCATION
CALL FREPAG ;[52] AND SIZE.
HRRZ A,DATJFN ;[6] CLOSE AND RELEAS
CLOSF ;[6] OLD JFN (IGNORE ERRORS)
CALL .GTF2 ;[6] INDICATE ERROR TO USER
.GTF0: ;[6] HERE TO SKIP CLOSF
MOVE A,[GJ%SHT+GJ%OLD]
HRROI B,FRMFIL ;NAME IN FRMFIL
GTJFN
RET ;ERROR
MOVEM A,DATJFN ;SAVE JFN
MOVE B,[36B5+OF%RD+OF%PLN]
OPENF
ERJMP [RLJFN
JFCL
RET]
AOS (P)
RET
.GTF1: TMSG <TFRCOB(GETFIL) FILENAME TOO LONG>
RET ;ERROR
.GTF2: ;[6] INDICATE CLOSF FAILURE
TMSG <TFRCOB(GETFIL) CLOSF FAILED>
RET
.GTF3: ;[6] PMAP FAILURE
TMSG <TFRCOB(GETFIL) PMAP FAILED>
RET
SUBTTL MAPIN -- MAP USER'S FORM FILE INTO MEMORY
;[52] THE FOLLOWING ROUTINE REPLACED THE PREVIOUS ROUTINE WITH THIS EDIT.
;[52] IS DYNAMICALLY ACQUIRED AND FREED AS FORMS ARE CHANGED. THE ROUTINE
;[52] WILL WORK WITH THE MEMORY ALGORITHMS OF V12 COBOL OR VERSION 11.
MAPIN:
SETZM GOTFIL ;INDICATE NO FILE MAPPED YET.
SETZM PAGINI ;INDICATE GOING FOR DATA PAGES.
SETZ A, ;START WITH PAGE-0 OF FORM FILE
MOVEI C,1 ; AND MAP ONLY THE FIRST PAGE.
SETZM DATSIZ ;INITIALIZE TO NO PAGES.
SETZM SYMSIZ
CALL GETPAG ;GET MEMORY AND MAP PAGE.
RET ;ERROR RETURN--REASON IN 'A'.
; MOVEM A,V12DCO ;[54]SAVE ACTUAL STARTING ADDRESS.
; ADDI A,777 ;[54]BUMP UP TO NEXT PAGE BOUNDRY.
; ANDI A,777000 ;[54]MAKE PAGE ALIGNED.
MOVEM A,V12DAT ;SAVE ADDRESS OF PAGE.
AOS DATSIZ ;INDICATE 1 PAGE.
MOVE B,.DATPG ;BUILD THE BYTE POINTER
SUB B,V11DAT ; TO THE VARIABLE WHICH
ADD B,V12DAT ; HAS THE SIZE OF THE DATA AREA.
LDB C,B ;GET THE SIZE OF THE DATA AREA.
JUMPE C,MAPI50 ;IF ONE PAGE, THEN WE HAVE GOT IT.
PUSH P,C ; ELSE MORE THAN 1 PAGE SO
MOVEI C,1 ; FREE THIS PAGE
MOVE B,V12DAT ; AND THEN
; MOVE B,V12DCO ;[54]GET ACTUAL STARTING ADDRESSRESS.
CALL FREPAG ;
POP P,C ;GET THE LENGTH OF DATA AREA
AOS C
SETZM DATSIZ ;INDICATE NO PAGES YET.
SETZ A, ; THEN GET A CONTIGUOUS AREA
PUSH P,C ;NUMBER OF PAGES DESIRED SAVED.
CALL GETPAG ; OF THE PROPER SIZE.
JRST [POP P,C ;NO MORE PAGES AVAILABLE
RET]
POP P,DATSIZ ;AND RESTORED TO DATA SIZE VARIABLE.
; MOVEM A,V12DCO ;[54]SAVE THE ACTUAL ADDRESS
; ADDI A,777 ;[54]BUMP UP TO NEXT PAGE BOUNDRY.
; ANDI A,777000 ;[54]PAGE ALLIGNED.
MOVEM A,V12DAT ;SAVE ADDRESS OF DATA AREA.
MAPI50: ;GET AREA FOR THE SYMBOL AREA
SETOM PAGINI ;INDICATE SYMBOL AREA PAGES.
MOVE A,DATSIZ ;SYMBOL AREA STARTS ON THIS PAGE
MOVE B,.STRPG ; OF THE FILE. SIZE OF THE
SUB B,V11DAT ; SYMBOL AREA IS CONTAINED
ADD B,V12DAT ; IN BYTE VARIABLE
LDB C,B ; NOW IN 'C'.
AOSG C ;IF ZERO, THEN NO
JRST SKPRET ; SYMBOLS WERE INVOLVED.
PUSH P,C ;SAVE THE SIZE OF SYMBOL AREA.
CALL GETPAG ;ELSE GET THE PAGES
RET ; UNLESS NOT AVAILABLE.
POP P,SYMSIZ ;RESTORE SIZE OF SYMBOL AREA.
; MOVEM A,V12SCO ;[54]SAVE ACTUAL ADDRESS.
; ADDI A,777 ;[54]BUMP UP TO NEXT PAGE BOUNDRY.
; ANDI A,777000 ;[54]MAKE PAGE ALIGNED.
MOVEM A,V12SYM ;SAVE ADDRESS OF MEMORY AREA.
SETOM GOTFIL ;INDICATE WE HAVE GOT IT.
JRST SKPRET ;RETURN.
;;;;;;;;;;;;;;;;;;;;
GETPAG: ;ROUTINE TO GET MEMORY FROM COBOL MEMORY MANAGEMENT
;ROUTINES AND MAP FORM FILE INTO IT.
;CALL WITH: A -- PAGE OF FILE TO START MAP.
; B -- ANYTHING.
; C -- NUMBER OF PAGES TO MAP.
;RETURN WITH:A -- ADDRESS OF FIRST PAGE
;ERROR RETURN WITH: A -- ERROR NUMBER.
;ON CALL PAGINI=0 IF DATA AREA PAGES AND -1 IF
; SYMBOL AREA PAGES.
;CALL: CALL GETPAG
; ERROR RETURN WITH ERROR IN 'A'.
; GOOD RETURN.
SKIPGE V11V12 ;IF DEFINITELY VERSION 11 COBOL
JRST GETP75 ; THEN GO TO IT NOW.
PUSH P,A ;SAVE THE REGISTERS WHILE GETTING THE
PUSH P,C ;MEMORY.
LSH C,PG2ADR ;TURN NUMBER OF PAGES TO NUMBER OF WORDS.
; ADDI C,777 ;[54]MAKE SURE WE GET ENOUGH UNALIGNED.
MOVEM C,IMP%SZ ;SET UP THE ARGUMENT BLOCK
SETZM IMP%ST ; FOR THE COBOL CALL.
PUSH P,ARG ;SAVE ARGUMENT LIST POINTER.
MOVEI ARG,ARG%GP ;LOAD POINTER TO ARGUMENT BLOCK.
CALL FUNCT.## ;GET THE MEMORY.
POP P,ARG
POP P,C
POP P,A
SKIPE IMP%ST ;IF ERROR ON CALL
JRST GETP50 ; THEN WE DID NOT GET THE MEMORY.
SETZM V11V12 ;INDICATE VERSION 12 OF COBOL.
GETP25:
HRL A,DATJFN ; ELSE PREPARE TO MAP THE FILE.
MOVE B,IMP%PT ;GET THE ADDRESS OF THE MEMORY
; ADDI B,777 ;[54]MAKE SURE WE GET TO PAGE BOUNDRY.
LSH B,ADR2PG ; AND TURN INTO PAGE NUMBER.
HRLI B,.FHSLF
TXO C,<PM%CNT+PM%CPY%+PM%RD>
PMAP
ERJMP GETP40 ;ERROR ON PMAP.
MOVE A,IMP%PT ;GET THE ADDRESS OF THE MEMORY
JRST SKPRET ;AND RETURN.
GETP40: MOVEI A,ERR.DP ;INDICATE PMAP FAILURE
RET ; AND GIVE ERROR RETURN.
GETP50: SKIPG IMP%ST ;IF NEGATIVE
JRST GETP75 ; THEN CALL NOT LEGAL (VERSION 11).
MOVEI A,ERR.NC ; ELSE NO MEMORY AVAILABLE.
RET
GETP75: SETOM V11V12 ;INDICATE DEFINITLY VERSION 11 COBOL.
;;HERE WHEN RUNNING UNDER VERSION 11 COBOL.
MOVEI B,HDRWRD ;...FOR NOW
MOVEM B,IMP%PT ;SAVE IN V12 ARGUMENT BLOCK.
SKIPL PAGINI ;IF WE ARE DEALING WITH THE DATA AREA
JRST GETP25 ; THEN CONTINUE.
MOVEI B,STRING ; ELSE USE THE SYMBOL PAGES.
MOVEM B,IMP%PT
JRST GETP25
;;;;;;;;;;;;;;;;;;;;;;;;;
FREPAG:
;UNMAP THE PAGES FROM THE FORM FILE AND RETURN THEM
; TO COBOL FREE POOL.
;CALL WITH: B -- ADDRESS OF MEMORY AREA
; C -- LENGTH (IN PAGES) OF AREA.
SKIPG C ;IF NO PAGES TO FREE
RET ; THEN WE ARE DONE.
MOVEM B,IMP%PT ;PUT THE MEMORY ADDRESS IN FUNCT. ARG BLK.
MOVE A,C ;AND AFTER CONVERTING
LSH A,PG2ADR ; TO SIZE IN WORDS
; ADDI A,777 ;[54]WAS DONE ON 'GET' TO INSURE PAGE ALIGNMENT.
MOVEM A,IMP%SZ ; PUT THE SIZE IN FUNCT. ARG BLK.
SETO A, ;INDICATE FREEING PAGES.
; ADDI B,777 ;[54]GETPAG WENT TO NEXT WHOLE PAGE.
LSH B,ADR2PG ;CONVERT TO PAGE NUMBER.
HRLI B,.FHSLF ;UNMAP FROM MY FORK.
TXO C,<PM%CNT> ;COUNT IS IMPORTANT.
PMAP
ERCAL FREP50 ;PMAP ERROR.
SKIPGE V11V12 ;IF VERSION 11 IS RUNNING
RET ; THEN DO NOT RELEASE CORE.
PUSH P,ARG ;SAVE THE ARGUMENT POINTER
MOVEI ARG,ARG%FP ;FREE-PAGES ARGUMENT BLOCK.
CALL FUNCT.## ;DO IT.
POP P,ARG ;RESTORE ARGUMENT POINTER.
RET ;RETURN TO CALLER.
FREP50: TMSG <TFRCOB (FREEPAGE) PMAP ERROR>
RET
;[52] END OF EDIT TO DO DYNAMIC PAGE GATHERING/FREEING
SUBTTL SETERL - DETERMINE ERROR LINE NUMBER AND PUT IN REG. A
SETERL:
PUSH P,B ;[35]
MOVE B,.TRMS ;[35]
SUB B,V11DAT ;[35]
ADD B,V12DAT ;[35]
LDB E,B ;[35]
POP P,B ;[35]
MOVEI A,^D24 ;DEFAULT TO LEAST RESTRICTIVE CASE
TXNE E,%%VT52
MOVEI A,^D24
TXNE E,%%VT05
MOVEI A,^D20
TXNE E,%%VT50
MOVEI A,^D12
RET
LIT
SUBTTL DATA AREA FOR TRAFFIC-20
;PURE DATA AREA (SMALL) BUT ALIVE.
$SBUFPTR: POINT 7,STRBUF ;[64]INITIALIZED POINTER TO BUFFER.
$SBUFMAX=^D300 ;[64]300 CHARACTERS IN BUFFER
$SBUFSND=$SBUFMAX-^D80 ;[64]SEND LESS THAN 80 CHARS IN BUFFER.
%FILES: XWD -1,0 ;[63] ALWAYS A 0.
DBYYBP: POINT 14,DATBUF,14 ;[16]BYTE POINTER FOR YEAR.
DBMMBP: POINT 14,DATBUF,28 ;[16]BYTE POINTER FOR MONTH.
DBDDBP: POINT 14,DATBUF+1,14 ;[16]BYTE POINTER FOR DAY.
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]
-4,,0
ARG%GP: 200,,GP.PAG ;GET PAGE ALLIGNED MEMORY
200,,IMP%ER ;ERROR CODE
200,,IMP%ST ;STATUS CODE
200,,IMP%PT ;POINTER TO AREA
200,,IMP%SZ ;SIZE TO BE GOTTEN
;[54]ONLY REMOVE THE ';[54]' ON NEXT LINE IF EDIT 54 IS REMOVED.
GP.PAG: 15 ;CODE FOR GETTING PAGE ALIGNED DATA.
;GP.PAG: 6 ;[54]CODE TO GET UNALIGNED DATA.
ARG%FP: 200,,FP.PAG ;GET PAGE ALLIGNED MEMORY
200,,IMP%ER ;ERROR CODE
200,,IMP%ST ;STATUS CODE
200,,IMP%PT ;POINTER TO AREA
200,,IMP%SZ ;SIZE TO BE GOTTEN
FP.PAG: 7 ;CODE FOR FREEING PAGE ALIGNED DATA.
REMARK CHARACTER TABLE FOR DEFINING CHARACTER CLASSES
;IMPURE DATA AREA
IFN FT2SEG,<RELOC 0> ;RELOC TO LOW SEG IF REENT. CODE DESIRED
TFRDAT:: ;START OF TFRCOB IMPURE DATA
SUBTAB: ;SUB-FIELD LENGTHS
BYTE (7)2,2,2,0 ;DT0, DDT4
BYTE (7)2,3,2,0 ;DT1, DT3
BYTE (7)5,0 ;DT2
BYTE (7)3,2,4,0 ;SSN
BYTE (7)"$","C",0 ;MONEY (MODIFIED)
CHRTAB: ;CHARACTER TABLE
CONCHR=1
FCCCHR=2
PNCCHR=4
NUMCHR=10
ALPCHR=20
REPEAT 8,<CONCHR> ;CONTROL/A THRU CONTROL/G
REPEAT 3,<FCCCHR> ;BACKSPACE,TAB,LF
REPEAT 1,<CONCHR> ;VT
REPEAT 2,<FCCCHR> ;FF,CR
REPEAT ^D17,<CONCHR> ;OTHERS
REPEAT 1,<FCCCHR> ;37
REPEAT ^D16,<PNCCHR> ;40-57
REPEAT ^D10,<NUMCHR> ;60-71 0-9
REPEAT ^D7,<PNCCHR> ;72-100
REPEAT ^D26,<ALPCHR> ;101-132 A-Z
REPEAT ^D6,<PNCCHR> ;133-137
REPEAT ^D26,<ALPCHR> ;140-172 SMALL(A-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>
MAXFLD: 0 ;[71]HIGHEST FIELD REACHED BEFORE BACKUP
FLAG1: 0 ;[71]STATE FLAG.
LASTFLD: 0 ;[71]SAVE PREVIOUS FIELD NUMBER.
SECTAB: BLOCK ^D30 ;[67]SECTION TABLE
FLDTLN=^D31 ;[67]LENGTH (PRIME #) OF ENTRIES IN FIELD TABLE
FLDTAB: BLOCK FLDTLN+2 ;[67]FIELD TABLE
MOVFILL: MOVSLJ ;[64]MOVE LEFT JUSTIFIED
0 ;[64] KEEP WITH MOVFILL.
FILCHAR: 0 ;FILLER CHARACTER FOR CURRENT FIELD.
TOTOUT: 0 ;[64]TOTAL NUMBER OF CHARACTERS OUT
NUMOUT: 0 ;[64] AND NUMBER OF CALLS TO $SEND
MAXOUT: 0 ;[64]LONGEST STRING SENT OUT
OVRFLOW: 0 ;[64]COUNT OF NEAR BUFFER OVERFLOWS.
$SBPTR: 0 ;[64]OUTPUT BUFFER BYTE POINTER
$SNUM: 0 ;[64]NUMBER CHARS LEFT IN BUFFER
STRBUF: BLOCK $SBUFMAX/5+^D10 ;[64]SIZE OF TERMINAL OUTPUT BUFFER WITH PADDING.
OLDMOD: 0 ;[55]MOVE TO IMPURE STORAGE
COC: BLOCK 2 ;[36]
GOTFIL: 0 ;[35]=0 IF NO FILE MAPPED, -1 OTHERWISE.
OLDTT: OLD%TT ;[43]=0 IF NOT SETTING CHARACTERISTICS
;[43] ON EACH CALL.
OLDCR: OLD%CR ;[37]=0, CR=5, -1, CR=3
OLDAR: OLD%AR ;[37]=0, LEFT/RIGHT ARROWS ARE BACKSP/TAB
;[37] IF -1, THEN END-INDICATOR OF 5.
OLDRQ: OLD%RQ ;[37]=0, USE CURRENT CODE,-1 OLD CODE.
OLDZR: OLD%ZR ;[37]
OLDMD: OLD%MD ;[37]
OLDPR: OLD%PR ;[37]
OLDRN: OLD%RN ;[51]=0, THEN REWRITE NUMERIC FIELDS
OLDWR: OLD%WR ;[60]=0,TFRWRT TO NONINITIALIZED FIELDS WORKS.
;[60]=-1, TFRWRT TO NONINITIALIZED FIELDS FAILS.
OLDLC: OLD%LC ;[61]=0, NO LOWERCASE, =-1, LOWERCASE
OLDCC: OLD%CC ;[72]=0, NO CNTRL/C TRAP,=-1 THEN DOIT.
DORESET: 0 ;[104]FORCE TERMINAL RESET FLAG.
OLDUD: OLD%UD ;[37]=0,UP/DOWN ARROWS = CARRIAGE RET.
OLDCS: OLD%CS ;[105]0,IGNORE XON/XOFF, -1, USE THEM
OLDRB: OLD%RB ;[106]0,IGNORE RUBOUT, -1,IS BACKSPACE.
SYMSIZ: 0 ;[35]STORAGE FOR SYMBOL AREA SIZE
DATSIZ: 0 ;[35]STORAGE FOR DATA AREA SIZE.
V11V12: COB%VR ;[35]0=V12,-1=V11,1=DYNAMIC
V12DCO: 0 ;[54]USED TO HOLD REAL (UNALLIGNED) ADDRESS.
V12SCO: 0 ;[54]USED TO HOLD REAL (UNALLIGNED) ADDRESS.
PAGINI: 0 ;[35]FLAG IF STORAGE GOTTEN ONCE.
V11SYM: STRING
V12SYM: 0
V11DAT: HD