Trailing-Edge
-
PDP-10 Archives
-
TRAFFIC-20_V4_840514
-
traffic-source/tfr.mac
There are 2 other files named tfr.mac in the archive. Click here to see a list.
TITLE TFR TERMINAL FORMATTING UTILITY
;COPYRIGHT (C) 1980, 1981, 1983 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH TFRUNV, MONSYM, MACSYM
SALL
IF1 <PRINTX TFR Version 4(200)>
LOC <.JBVER==137> ;SET PROGRAM VERSION
V%TFR
RELOC
;CONDITIONAL ASSEMBLY PARAMETERS
IFNDEF SHORTX,<SHORTX=1> ;SHORT EXTENSIONS <== 1
;LONG EXTENSIONS <== 0
DEFAULT=0 ;ALLOW COPYING OF DEFAULTS <== 1
;DISALLOW COPYING OF DEFAULTS <== 0
SUBTTL DEFINITIONS
ATOMLN==^D255 ;MAX LENGTH OF A COMMAND
TEXTLN==^D25+ATOMLN ;MAX LENGTH OF A COMPLETE COMMAND
PDLEN==100 ;PDL LENGTH
NRFLDS==2 ;NUMBER CMMDS REQUIRED PER FIELD
CIDCLN==30 ;COBOL ID CHARACTER LENGTH
FORMFD=14 ;FORM FEED
CR=15 ;CARRIAGE RETURN
SPACE=40 ;SPACE
A==1
B==2
C==3
D==4
T==5
E==T
T1==6
T2==7
HLDJFN==10
F==11 ;FLAGS
PRM==12 ;TMP PARAMETER STORAGE
ARG==13 ;TMP ARGUMENT PLACE
CFLD==14 ;PTR TO CURRENT FIELD
T3==15
T4==16
P==17
REMARK FLAG BITS FOR F (FIELD INDEPENDENT)
%TTYIN==1B0 ;INPUT ON TTY
%SWERL==1B1 ;SAW ERR-LINE
%SWFRM==1B2 ;SAW FRM NAME
%SWOUT==1B3 ;SAW OUTPUT FILE SPEC
%SWSUM==1B4 ;SAW SUMMARY FILE SPEC
%SWREC==1B5 ;SAW REC. DESC. FILE SPEC
%SWIDX==1B6 ;SAW INDEX FIELD
%FLBTS==-1^!<%TTYIN+%SWERL+%SWFRM>
%FLBTS==%FLBTS^!<%SWOUT+%SWSUM+%SWREC+%SWIDX>
REMARK FLAG BITS FOR F (FIELD DEPENDENT)
%SWFLD==1B9 ;CLEARED WEN REQD CMMDS GIVEN
%SWLEN==1B10 ;SAW LENGTH
%SWPOS==1B11 ;SAW POSITION.
%SWLRN==1B12 ;SAW RANGE
%SWURN==1B13 ;SAW UPPER RANGE
%SWVAL==1B14 ;SAW VALUE THIS FIELD
%SWHLP==1B15 ;SAW HELP MESSAGE
%SWVET==1B16 ;SAW VET NUMBER
%SWSFD==1B17 ;SAW SUBFIELD DESCRIPTOR
REMARK FLAG BITS IN F USED FOR CLASS DETERMINATION
;1B31 %MAALP==%ALPHA ;ALPHA SEEN
;1B32 %MANUM==%NUMER ;NUMERIC SEEN
;1B29 %MAPUN==%PUNCT ;PUNCTUATION SEEN
;1B20 %MSIGN==%SIGND ;SIGN ALLOWED IN NUMERICS
%MSSN==1B18 ;SOCIAL SECURITY NUMBER
%MTIM==1B19 ;TIME FIELD
%MTYPE==%MSSN+%MTIM
%DTYPE==7B35 ;DATE TYPE FLAG
SUBTTL MACROS
;
;TAB - GENERATE TABLE ENTRIES FOR COMND JSYS
;
DEFINE TAB(STR,ENT),<
IFDEF ENT,< XWD [ASCIZ !STR!],ENT>
IFNDEF ENT,< XWD [ASCIZ !STR (UNIMP)!],[HRROI A,[ASCIZ !? Unimplimented command !]
CALL CMDERR
RET] >
>
;
;ERROR - ISSUE AN ERROR MESSAGE AND PERFORM THE GIVEN INSTRUCTION(S)
;
DEFINE ERROR(MSG,INST<JRST .+1>,NOCR)
< JRST [HRROI A,[ASCIZ !?MSG!]
IFB <NOCR>,< SETZ T1,>
IFNB <NOCR>,< SETO T1,>
CALL CMDERR
INST]
>
;
;JERROR - ISSUE LATEST ERROR MESSAGE AND OUR OWN MESSAGE THEN
;PERFORM THE GIVEN INSTRUCTION(S)
;
DEFINE JERROR (MSG,INST<JRST .+1>)
< JRST [MOVEI A,.PRIOU ;OUTPUT ERROR TO PRIMARY JFN
HRLI B,.FHSLF ;INDICATE 'THIS' PROCESS.
SETZ C, ;INDICATE ANY LENGTH
ERSTR ;OUTPUT THE ERROR
JFCL ;FORGET ABOUT ANY ERRORS HERE
JFCL ; AND HERE
HRROI A,[ASCIZ !?MSG!]
CALL CMDERR
INST]
>
;
;WARN - ISSUE A WARNING MESSAGE AND PERFORM THE GIVEN INSTRUCTION(S)
;
DEFINE WARN(MSG,INST<JRST .+1>,NOCR)
< JRST [HRROI A,[ASCIZ !%'MSG!]
IFB <NOCR>,< SETZ T1,>
IFNB <NOCR>,< SETO T1,>
CALL CMDWRN
INST]
>
;
;CKERR - SEE IF AN ERROR OCCURED IN THE LAST COMND CALL
;
DEFINE CKERR
< TXNE A,CM%NOP >
;
;FMSG - SEND A STRING TO A GIVEN JFN. A SECOND STRING MAY BE SENT FROM
;THE SPECIFIED LOCATION (DATA).
;
DEFINE FMSG(JFN,MSG,DATA,TERM<0>,CR,LENG)
< ..N..==0
IFNB <MSG>,<IRPC MSG,<..N..==..N..+1>>
MOVEI T4,[XWD ..N..,[ASCIZ \MSG\]
XWD JFN,TERM
IFB <DATA>,< -1 >
IFNB <DATA>,< DATA >
XWD CR,LENG]
CALL DOFMSG
>
;
;NUMBR - OUTPUT A NUMBER IN DECIMAL TO THE GIVEN JFN
;
DEFINE NUMBR(JFN,DATA)
<
IFNB <JFN>,< MOVE A,JFN>
IFB <JFN>,< MOVEI A,.PRIOU>
IFNB <DATA>,<MOVE B,DATA>
MOVEI C,D10
NOUT
ERJMP ERRFIL
>
;
;LOAD - LOAD A VALUE FROM THE FIELD DATA AREA
;
DEFINE LOAD(AC,PTR,TEMP<T1>)
<
MOVE TEMP,PTR
ADD TEMP,T2
LDB AC,TEMP
>
;
;LOADC - LOAD A VALUE FROM THE FIELD DATA AREA (VIA CFLD)
;
DEFINE LOADC(AC,PTR,TEMP<T>)
<
MOVE TEMP,PTR
ADD TEMP,CFLD
LDB AC,TEMP
>
;
;PUTBYT - DEPOSIT A BYTE INTO THE FIELD DATA AREA
;
DEFINE PUTBYT(AC,PTR,TEMP<T>)
<
MOVE TEMP,PTR
ADD TEMP,CFLD
DPB AC,TEMP
>
;
;GOTYPE - DISPATCH TO ONE OF THE LISTED ROUTINES GIVEN THE LANGUAGE
;REQUIRED.
;
DEFINE GOTYPE(CBL,FOR,MAC)
<
MOVE T,RECTYP
JRST .+1(T)
JRST CBL
JRST CBL
JRST FOR
JRST MAC
>
D0==0
D1==1
D2==2
D3==3
D4==4
D5==5
D6==6
D7==7
D8==^D8
D9==^D9
D10==^D10
D11==^D11
D13==^D13
D15==^D15
D16==^D16
M1==777777
OPDEF EXTEND [123000,,000000]
OPDEF MOVSLJ [016000,,000000]
OPDEF MOVSRJ [017000,,000000]
OPDEF CMPSE [002000,,000000]
OPDEF PJRST [JRST]
COMMENT *
THE FOLLOWING SYMBOL DEFINES THE BEGINNING OF
THE PROGRAMS ADDRESS SPACE.
*
TFRBEG:
COMMENT *
A DESCRIPTION OF THE FIELD TABLE FOLLOWS.
EACH ENTRY IS A BYTE POINTER TO AN ENTRY
WITH THE APPROPRIATE OFFSET INTO THE TABLE
*
REMARK PTR .TAG ,LN,BT,OFFSET
PTRGEN ;GEN POINTERS
CTAB1: CTAB1E-.-1,,CTAB1E-.-1 ;LENGTH,,LENGTH
TAB <CHARACTER-SET>,CMCHAR ;CHAR SET
TAB <E-ATTRIBUTES>,CMERAT ;ERROR LINE ATTRIB.
TAB <ERROR-LINE>,CMERRM ;ERROR LINE NO.
TAB <F-ATTRIBUTES>,CMFRAT ;FORM ATTRIBUTES
TAB <FORM>,CMFORM ;FORM NAME
TAB <HIGHEST-SECTION-NUMBER>,CMHSN ;MAX SECTION
TAB <OUTPUT-FILE>,CMOUTF ;DATA FILE SPEC
TAB <RECORD-DESCRIPTION-FILE>,CMREC ;DESCRIPTION FILE SPEC
TAB <SIZE>,CMSIZE ;SCREEN SIZE
TAB <SUMMARY-FILE>,CMSUMM ;SUMMARY FILE SPEC.
TAB <TERMINALS-ALLOWED>,CMTERM
TAB <WORD-ALIGNED>,CMALG
CTAB1E:
CTAB2: CTAB2E-.-1,,CTAB2E-.-1
TAB <A>,CMALPH ;=ALPHABETIC
TAB <A-N>,CMAN ;APHNUMERIC
TAB <ALLOW-LOWERCASE>,CMALLC
TAB <ALPHABETIC>,CMALPH
TAB <ALPHANUMERIC>,CMAN ;ALPHANUMERIC
TAB <ANY-CHARACTER>,CMANP ;ALPHA-NUMERIC-PUNCTUATION
TAB <AUTO-TAB>,CMATO
TAB <BLINKING>,CMBLNK
TAB <BOLD>,CMBOLD ;NEW ATTRIBUTE
TAB <DATA-VET>,CMDVET ;NEW FACILITY
TAB <DATE>,CMDATE
TAB <DESCRIPTOR>,CMDESC
TAB <ECHO>,CMECHO
TAB <EXIT>,CMEXIT
TAB <FIELD>,CMFLD
TAB <FILLER>,CMFILL
TAB <FULL-FIELD>,CMFULL ;FULL FIELD REQD.
TAB <GRAPHIC>,CMGRPH
TAB <HELP>,CMHELP ;HELP MESSAGE
TAB <HIDDEN-FIELD>,CMHIDE ;NO-INIT
TAB <INCLUDE>,CMINCL ;INCLUDE FILE
TAB <INDEX-FIELD>,CMINDX ;MARK FIELD AS INDEX
TAB <LEADING-ZEROS>,CMZERO ;ZERO FILL NUMERIC
TAB <LENGTH>,CMLENG
TAB <LONG-DATE>,CMLONG
TAB <LOWER-RANGE>,CMLOWR
TAB <MASTER-DUPE>,CMMAST
TAB <MONEY>,CMMONY
TAB <MULTIPLE>,CMMULT ;MUTIPLE FIELD
TAB <NO-AUTO-TAB>,CMNATO
TAB <NO-DUPE>,CMNODP
TAB <NO-ECHO>,CMNEKO
TAB <NO-INIT>,CMHIDE ;PSEUDONYM FOR HIDDEN
TAB <NO-LEADING-ZEROS>,CMNZRO ;BLANK FILLED NUMERICS.
TAB <NO-RENDITION>,CMNORM
TAB <NO-SPACES>,CMNSPC ;SPACES ILLEGAL IN ALPHABETIC
TAB <NORMAL-VIDEO>,CMNORM
TAB <NOT-HIDDEN>,CMNHID
TAB <NUMERIC>,CMNUMR
TAB <OPTIONAL>,CMOPTN ;NOT REQUIRED
TAB <POSITION>,CMPOSI
TAB <PREVIOUS-DUPE>,CMPREV
TAB <PROTECTED>,CMPROT
TAB <RAISE-LOWERCASE>,CMRSLC
TAB <REQUIRED>,CMREQU
TAB <REVERSE-VIDEO>,CMREVS
TAB <SAME-AS>,CMSAME ;SAME-AS FIELDNAME
TAB <SECTION>,CMSECT
TAB <SECURE>,CMNEKO ;NO-ECHO ATTRIBUTE
TAB <SIGNED>,CMSIGN
TAB <SOCIAL-SECURITY-NUMBER>,CMSOCI
TAB <SPACES>,CMSPC ;SPACES LEGAL IN ALPHABETIC
TAB <T-ATTRIBUTES>,CMTATR ;TEXT ATTRIBUTES
TAB <T-POSITION>,CMTPOS ;TEXT POSITION
TAB <T-VALUE>,CMTVAL ;TEXT ATTRIBUTES
TAB <TALL>,CMTALL
TAB <TEXT-ATTRIBUTES>,CMTATR
TAB <TEXT-POSITION>,CMTPOS
TAB <TEXT-VALUE>,CMTVAL
TAB <TIME>,CMTIME
TAB <UNDERLINED>,CMUNDR
TAB <UNDERSCORE>,CMUNDR ;RENDITION ATTRIBUTE
TAB <UNPROTECTED>,CMUPT
TAB <UNSIGNED>,CMUNSN
TAB <UPPER-RANGE>,CMUPRR
TAB <VALUE>,CMVALU
TAB <VERTICAL>,CMVERT
TAB <VET-NUMBER>,CMDVET ;DATA VET ROUTINES
TAB <VIDEO-ATTRIBUTES>,CMVATR
TAB <WIDE>,CMWIDE
TAB <YES-NO>,CMYN
CTAB2E: ;END OF FIELD TABLE
CTAB3: 1,,1 ;TFR IN RESCAN MODE
TAB <TFR>,D0
TABLE2: TAB2ND-.-1,,TAB2ND-.-1
TAB <BOTTOM>,D0 ;0=BOTTOM
TAB <TOP>,D1 ;1=TOP OF FORM
TAB2ND:
CHRTAB: CHRTND-.-1,,CHRTND-.-1 ;CHAR SET TABLE
TAB <ALTERNATE>,%CSAL
TAB <GRAPHIC>,%CSGR
TAB <UK>,%CSUK
TAB <US>,%CSUS
CHRTND:
TABLE3: TAB3ND-.-1,,TAB3ND-.-1
TAB <CANADA>,%DATCA
TAB <COBOL>,%DATCB
TAB <DASH>,%DATDA
TAB <DEC>,%DATDE
TAB <JULIAN>,%DATJU
TAB <MILITARY>,%DATMI
TAB <SLASH>,%DATSL
TAB3ND:
TABLE4: TAB4ND-.-1,,TAB4ND-.-1
TAB <BLINKING>,D2
TAB <BOLD>,D4
TAB <GRAPHIC>,D8
TAB <NORMAL-VIDEO>,D0
TAB <REVERSE-VIDEO>,D1
TAB <TALL>,D6
TAB <UNDERLINED>,D3
TAB <UNDERSCORE>,D3
TAB <VERTICAL>,D7
TAB <WIDE>,D5
TAB4ND:
TRMTAB: TRMTBE-.-1,,TRMTBE-.-1
TAB <ALL>,%VTALL ; ALL TERMINAL TYPES
TAB <VT05>,%VT05 ; VT05
TAB <VT100>,%VT100 ; VT100
TAB <VT132>,%VT132 ; VT100 IN 132 COLUMN MODE
TAB <VT50H>,%VT50H ; VT50 H (CURSOR ADDRESSING)
TAB <VT52>,%VT52 ; VT52
TRMTBE:
TRMSIZ: ;SIZE OF TERMINAL SCREENS
REMARK [# OF LINES ,, # OF COLUMNS]
^D24,,^D132 ;DEFAULT. MUST BE HIGHEST
^D20,,^D72 ;VT05
^D12,,^D80 ;VT50H
^D24,,^D80 ;VT52
^D24,,^D80 ;VT100 IN NORMAL MODE
^D24,,^D132 ;VT100 IN 132 MODE
DEFINP: ;DEFAULT INPUT FILE-SPECS
0
377777,,377777 ;JFNS
0 ;DEVICE
0 ;DIRECTORY
0 ;FILENAME
IFN SHORTX,<POINT 7,[ASCIZ !FRM!]>
IFE SHORTX,<POINT 7,[ASCIZ !FORM-SPEC!]>
0 ;PROTECTION
0 ;ACCOUNT
0 ;JFN
BLOCK 5
DEFOUT: ;DEFAULT OUTPUT FILE
GJ%FOU ;OUTPUT FILE
0
0 ;DEVICE
0
POINT 7,NMFORM ;FORM NAME
IFN SHORTX,<POINT 7,[ASCIZ !DAT!]>
IFE SHORTX,<POINT 7,[ASCIZ !FORM-DATA!]>
0
0
0
BLOCK 5
DEFSUM: ;DEFAULT SUMMARY FILE
GJ%FOU
0
0
0
POINT 7,NMFORM
IFN SHORTX,<POINT 7,[ASCIZ !SUM!]>
IFE SHORTX,<POINT 7,[ASCIZ !FORM-LIST!]>
0
0
0
BLOCK 5
DEFREC: ;DEFAULT RECORD DESCRPTION
GJ%FOU
0
0
0
POINT 7,NMFORM
IFN SHORTX,<POINT 7,[ASCIZ !REC!]>
IFE SHORTX,<POINT 7,[ASCIZ !FORM-DESC!]>
0
0
0
BLOCK 5
DEFREL: ;GTJFN BLOCK FOR OUTPUT REL FILE
GJ%FOU
.NULIO,,.NULIO
0
0
0
POINT 7,[ASCIZ !REL!]
0
0
0
DFINCL: ;INCLUDE FILE DEFAULTS
GJ%OLD+GJ%CFM+GJ%MSG ;FLAGS,,GEN#
0 ;JFNS
0 ;DEVICE
0 ;DIRECTORY
0 ;FILENAME
IFN SHORTX,< POINT 7,[ASCIZ !INC!]>
IFE SHORTX,< POINT 7,[ASCIZ !FORM-INCL!] >
0 ;PROTECTION
0 ;ACCOUNT
0 ;JFN
BLOCK 5
FDBATR: FLDDB. .CMKEY,,TABLE4,<Video attribute>,,FDBCFM
FDBCFM: FLDDB. .CMCFM
FDBCHR: FLDDB. .CMKEY,,CHRTAB,<Character set identifier>
FDBCM1: FLDDB. .CMKEY,,CTAB1,<Form-wide command>,,FDBCMA
FDBCM2: FLDDB. .CMKEY,,CTAB2,<Field command>,,FDBCMB
FDBCMA: FLDDB. .CMKEY,,CTAB2,<Field command>
FDBCMB: FLDDB. .CMKEY,,CTAB1,<Form-wide command>
FDBCOL: FLDDB. .CMTOK,<CM%SDH>,<POINT 7,[ASCIZ /+/]>,,,FDBCL1
FDBCL1: FLDDB. .CMTOK,<CM%SDH>,<POINT 7,[ASCIZ /-/]>,,,FDBCL2
FDBCL2: FLDDB. .CMNUM,<CM%SDH>,^D10,<Column number where field begins>
FDBDAT: FLDDB. .CMKEY,,TABLE3,,<DEC>
FDBERL: FLDDB. .CMKEY,,TABLE2,<Line to use for errors or>,<BOTTOM>,FDBERX
FDBERX: FLDDB. .CMNUM,<CM%SDH>,^D10
FDBFIL: FLDDB. .CMFIL
FDBFLD: <FLD (.CMTXT,CM%FNC)>!CM%HPP!CM%DPP!CM%SDH
0
POINT 7,[ASCIZ /Field name/]
POINT 7,DEFFNM
FDBFLN: FLDDB. .CMNUM,<CM%SDH>,^D10,<Field length>
FDBFRM: FLDDB. .CMTXT,<CM%SDH>,,<Name of form>
FDBINI: FLDDB. .CMINI
FDBLIN: FLDDB. .CMTOK,<CM%SDH>,<POINT 7,[ASCIZ /+/]>,,,FDBLN1
FDBLN1: FLDDB. .CMTOK,<CM%SDH>,<POINT 7,[ASCIZ /-/]>,,,FDBLN2
FDBLN2: FLDDB. .CMNUM,<CM%SDH>,^D10,<Line number of field>
FDBMXC: FLDDB. .CMNUM,<CM%SDH>,^D10,<Maximum number of columns on screen>
FDBMXL: FLDDB. .CMNUM,<CM%SDH>,^D10,<Maximum length of screen>
FDBN.C: FLDDB. .CMNUM,<CM%SDH>,^D10,<Section number>,,FDBCFM
FDBN2C: FLDDB. .CMNUM,<CM%SDH>,^D10,<Decimal number or>,2,FDBCFM
FDBNUM: FLDDB. .CMNUM,,^D10
FDBQST: FLDDB. .CMQST
FDBSAM: <FLD (.CMTXT,CM%FNC)>!CM%HPP!CM%SDH
0
POINT 7,[ASCIZ /Previously defined field name/]
FDBTFR: FLDDB. .CMKEY,,CTAB3
FDBTRM: FLDDB. .CMKEY,<CM%SDH>,TRMTAB,<Terminal type>,,FDBCFM
SUBTTL SUBFIELD DEFINITION DESCRIPTORS
; SUBFIELD DEFINITIONS ARE IMPLEMENTED AS DESCRIPTORS AND PASSED
; IN THE BINARY FILE TO TFRCOB
DD.CAN: BYTE(9)%T.D,"/"+%SFSEP,%T.NM,"/"+%SFSEP ;DATE DD/MM/YY
BYTE(9)%T.Y,0,0,0
DD.CBL: BYTE(9)%T.Y,"-"+%SFSEP,%T.NM,"-"+%SFSEP ;DATE YY-MM-DD
BYTE(9)%T.D,0,0,0
DD.DSH: BYTE(9)%T.NM,"-"+%SFSEP,%T.D,"-"+%SFSEP ;DATE MM-DD-YY
BYTE(9)%T.Y,0,0,0
DD.DEC: BYTE(9)%T.D,"-"+%SFSEP,%T.AM,"-"+%SFSEP ;DATE DD-MMM-YY
BYTE(9)%T.Y,0,0,0
DD.JUL: BYTE(9)%T.Y,%T.JD,0 ;DATE YYDDD
DD.SLH: BYTE(9)%T.NM,"/"+%SFSEP,%T.D,"/"+%SFSEP ;DATE MM/DD/YY
BYTE(9)%T.Y,0,0,0
DD.SSN: BYTE(9)3+%SFLEN,%T.DIG,"-"+%SFSEP,2+%SFLEN
BYTE(9)%T.DIG,"-"+%SFSEP,4+%SFLEN,%T.DIG
BYTE(9)0,0,0,0
DD.TM4: BYTE(9)%T.H,":"+%SFSEP,%T.MS,0 ;TIME HH:MM
DD.TM6: BYTE(9)%T.H,":"+%SFSEP,%T.MS,":"+%SFSEP ;TIME HH:MM:SS
BYTE(9)%T.MS,0,0,0
DD%LNG=.-DD.CAN
; MONEY DESCRIPTORS ARE BUILT DYNAMICALLY
;BYTE POINTERS INTO DATE DESCRIPTION TABLE
DATLNG: POINT 6,DATTBL(B),5 ;LENGTH
DATCLS: POINT 1,DATTBL(B),6 ;CLASS 0=NUMERIC,1=ALPHA
DATSEP: POINT 2,DATTBL(B),8 ;NUMBER OF SEPARATORS
DATLEN: POINT 6,DATTBL(B),14 ;NUMBER OF BYTES IN DESCRIPTOR
DATDES: POINT 18,DATTBL(B),35 ;DESCRIPTOR ADDRESS.
DATTBL:
6B5+0B6+2B8+5B14+DD.CAN ;CANADIAN MM/DD/YY
6B5+0B6+2B8+5B14+DD.CBL ;COBOL YY/MM/DD
6B5+0B6+2B8+5B14+DD.DSH ;DASHES DD-MM-YY
7B5+1B6+2B8+5B14+DD.DEC ;DEC DD-MMM-YY
5B5+0B6+0B8+2B14+DD.JUL ;JULIAN YYDDD
7B5+1B6+2B8+5B14+DD.DEC ;MILITARY DD-MMM-YY
6B5+0B6+2B8+5B14+DD.SLH ;SLASH DD/MM/YY
DATTIM: 4B5+0B6+1B8+3B14+DD.TM4 ;TIME HH:MM
6B5+0B6+2B8+5B14+DD.TM6 ;TIME HH:MM:SS
DATSSN: 9B5+0B6+2B8+8B14+DD.SSN ;SSN NNN-NN-NNNN
SUBTTL MAIN-LINE CODE.
TFR::
RESET
ERCAL ERRPC
MOVEI A,.RSINI ;SEE IF ANYTHING IN RESCAN BUFF
RSCAN
SETZ A, ; DEFAULT TO NO
MOVEM A,RSCFLG ;SAVE THE RESULT
MOVE P,[IOWD 100,STACK] ;INIT STACK
SETZM INPJFN ;CLEAR THE INPUT JFN
TFR2:
CALL TFRINI ;PRESET THE LOCAL DATA
MOVEI CFLD,DEFFLD ;PTR TO DEFAULTS
MOVE T,CURFLD
CALL GETINF ;GET INPUT FILE JFN
HALTF ; ALL DONE WITH RESCAN
CALL NXTCMD ;GET A COMMAND
JRST .-1 ;LOOP UNTIL EXIT OR EOF
SKIPN CURFLD ;ANY FIELDS?
ERROR <No fields present in form - no files generated>
SKIPN ERRCNT ;IF NO ERRORS
JRST [CALL PUTREC ;OUTPUT RECORD FILE
CALL PUTSUM ;OUTPUT SUMMARY FILE
CALL PUTREL ;OUTPUT REL FILE (VET ROUTINES)
CALL DATOUT ;OUTPUT DATA FILE
JRST .+1]
CALL CLOSES ;CLOSE THE FILES DOWN
HRROI A,[ASCIZ /
/]
SKIPE ERRCNT ;IF WE HAD AN ERROR
PSOUT ; THEN EXTRA <CR><LF>
SKIPE RSCFLG ;IF RUN IMPLICITLY
SKIPE WILD ; AND NO WILDCARDS
SKIPA
HALTF ; THEN JUST END
JRST TFR2
NXTCMD: ;GET NXT CMD
CALL CMDINI ;INIT FUNCTION
REPARS:
SETZ ARG, ;USED FOR ARGS IN COMMANDS
MOVEI A,CSB ;SETUP FOR COMND
MOVE B,CMDPTR ;CURRENT COMMAND LIST (FDBCM1/2)
AOS LINENM ;UP LINE NUMBER
AOS FLDDSP ;ADD 1 TO FLD DISPLACEMENT
COMND
ERJMP REP10 ;MAY BE EOF
CKERR ;LEGAL COMMAND ?
JRST [LDB A,[POINT 7,TEXT,6] ;IF THIS ERROR OCCURED
CAIN A,FORMFD ;BECAUSE OF A FORMFEED
JRST [MOVEI A,SPACE ;THEN REPLACE IT
DPB A,[POINT 7,TEXT,6] ;WITH A SPACE AND
JRST REPARS] ;TRY AGAIN
ERROR <Ambiguous or undefined command>,RET]
HRRZ B,(B) ;WE HAVE A GOOD COMMAND
CALL (B) ;DO COMMAND
SKIPE EXITCM ;IF THIS WAS EXIT
AOS (P) ;THEN DONE
RET
REP10: ;HERE FOR POSSIBLE EOF ETC
HRRZ A,INPJFN
GTSTS ;GET FILE STATUS
TXNN B,GS%EOF ;END OF FILE?
JRST [CALL ERRPC ;NO - ASSUME OTHER ERROR
JRST NXTCMD]
SOSGE A,NMINCL ;YES - SEE IF INCLUDE FILE END
JRST [SETOM EOF ;NO - FLAG IT
CALL CMEXIT ;TREAT AS EXIT
AOS (P) ;GOOD RETURN
WARN <No EXIT command found>,RET]
PUSH P,A ;SAVE THE POINTER
CALL CLOSIF ;CLOSE INPUT FILE
POP P,A
MOVE A,INCJFN+1(A) ;GET THE PREVIOUS JFN
MOVEM A,INPJFN ;THIS IS NOW THE INPUT JFN
HLRM A,WILD ;RESTORE THE WILDCARD FLAG
TXZ F,%TTYIN ;CAN'T BE TTY INPUT NOW
HRRZS A ;KEEP ONLY THE JFN
PUSH P,A ;SAVE THE JFN
DVCHR ;SEE WHAT IT IS
ERCAL ERRPC
LDB C,[POINT 9,B,17] ;GET THE DEVICE TYPE
CAIN C,.DVTTY ;IF TTY INPUT
TXO F,%TTYIN ; THEN RESET THE FLAG
POP P,A
HRLI A,377777
TXNE F,%TTYIN
HRLS A ;SET OUTPUT JFN FOR SOURCE
MOVSM A,CSB+.CMIOJ ;PUT IN CSB
JRST NXTCMD ;GET COMMAND FROM HIGHER LEVEL
SUBTTL SECOND LEVEL ROUTINES
TFRINI:
SETZB F,PRM ;ZERO FLAG REGS.
SETZM ZER.LO ;CLEAR THE VARIABLE DATA AREA
MOVE T,[ZER.LO,,ZER.LO+1]
BLT T,ZER.HI
SETZM RECTYP ;DEFAULT TO COBOL
SETOM CSECT ;PRESET SECTION COUNTER
MOVNI T,^D16
MOVEM T,MLTRN ;PRESET THE MULTIPLE COUNTER
HRRZ T,TRMSIZ ;GET DEFAULT WIDTH
MOVEM T,MAXCOL ;AND SET MAX COLUMN
HLRZ T,TRMSIZ ;GET DEFAULT HEIGHT
MOVEM T,MAXLIN ;AND SET MAX LINE
MOVEI T,STRING ;PRESET STRING POINTER
MOVEM T,STRPTR
MOVEI T,.DATA+WD%DSC ;POINT TO DATA AREA
MOVEM T,DATA
MOVEI T,DF%SEC ;PRESET THE NUMBER OF SECTION
MOVEM T,NUMSEC
MOVEI T,.FRMLN+WD%DSC ;DEFAULT HEADER SIZE
MOVEM T,FRMLEN
MOVEI T,.FLDLN+WD%DSC ;DEFAULT FIELD DATA SIZE
MOVEM T,FLDLEN
MOVEI T,<STRING-.DATA-WD%DSC>/<.FLDLN+WD%DSC>
MOVEM T,MAXFLD ;MAX FIELD NUMBER
MOVE A,[-WD%DSC,,HDRWRD+.FRMLN] ;SET DEFAULT HIDDEN SECTION PTR
MOVEM A,HDNPTR
SETOM FILCOL ;DON'T CHECK LINE-UP YET
HRROI A,DAYTIM ;SET UP TO GET DATE AND TIME
SETO B, ; FOR LATER USE
SETZ C,
ODTIM
ERCAL ERRPC
SETZ B,
IDPB B,A ;END ON A NULL BYTE
RET
CMDERR: ;PRINT COMMAND IN ERROR
TXNN F,%TTYIN ;NO ERROR IF TTY INPUT
AOS ERRCNT ;ADD ONE ERROR
CMDWRN: ;A WARNING
TXNE F,%TTYIN ;SEE IF ON TTY
JRST [PSOUT
SKIPN T1 ;IGNORE <CR><LF> IF TOLD TO
CALL CRLF
RET] ;DONE IF TTY
MOVE T,LINENM ;GET LINE NUMBER
CAMN T,LSTMSG ;LAST MSG FOR SAME LINE ?
JRST SKIPHD ;YES-SKIP HEADER INFO
PUSH P,B
PUSH P,A ;SAVE MSG PTR
CALL CRLF
CALL TYPCMD
TMSG <on line >
MOVE B,LINENM ;GET LINE NUMBER
NUMBR
SKIPN CURFLD ;SKIP IF GOT ANY FIELDS
JRST SKIPFL ;SKIP FIELD MESSAGE
TMSG < ; field >
HRROI B,NMFLD ;NAME OF FIELD
MOVEI A,.PRIOU
SETZB C,D ;TERMINATE ON NULL
SOUT
ERCAL ERRPC
TMSG < + >
MOVE B,FLDDSP ;DISPLACEMENT
CALL NOUTB
CAIA
SKIPFL: ;SKIP FIELD MSGS
CALL CRLF
POP P,A ;RESTORE MSG PTR
POP P,B
SKIPHD: ;HERE IF SAME LINE AS LAST.
PSOUT ;PUT IT OUT
MOVE T,LINENM ;SAVE THIS LINE
MOVEM T,LSTMSG ; AS THE LAST MSG LINE.
SKIPE T1 ;IGNORE <CR><LF> IF TOLD TO
RET
REMARK FALL INTO CRLF
CRLF:
TMSG <
>
RET ;RETURN
GETINF:
MOVE A,INPJFN
GNJFN ;SEE IF THERE IS ANOTHER ONE
SKIPA ;NO - TRY TO GET A COMMAND
JRST GETIN3 ;OK - OPEN A FILE
SETZM WILD ;DON'T ASSUME WILDCARDS NOW
HRRZ A,INPJFN ;NO MORE FILES ON THIS JFN
RLJFN ;SO RELEASE IT IF WE CAN
JFCL ;BUT DON'T WORRY IF WE CAN'T
SKIPN RSCFLG ;RESCAN BUFFER EMPTY?
JRST GETIN1 ; YES - NORMAL
SKIPE INPJFN ;IF RESCANNING AND ALREADY HAD ONE
RET ; THEN DONE
MOVEI A,ICSB
MOVE B,[POINT 7,[0]] ;CLEAR THE PROMPT STRING
MOVEM B,.CMRTY(A)
MOVEI B,GETIN0
HRRM B,.CMFLG(A) ;SET THE RESCAN ADDRESS
MOVEI B,FDBINI
COMND
ERCAL ERRPC
GETIN0:
MOVEI B,FDBTFR ;GET THE TFR PART
COMND
ERCAL ERRPC
CKERR
JRST GETIN1 ;NOT PARSED - USE OLD METHOD
TXNN A,CM%EOC ;END ON <CR>?
JRST GETIN2 ; NO - JUST GET FILESPEC
GETIN1:
SETZM RSCFLG ;ASSUME IT WAS EMPTY
MOVEI A,ICSB ;INIT THE INPUT FILE CSB
MOVE B,[POINT 7,[ASCIZ !Form specification file: !]]
MOVEM B,.CMRTY(A)
MOVEI B,GETIN2
HRRM B,.CMFLG(A)
MOVEI B,FDBINI
COMND
ERCAL ERRPC
GETIN2:
MOVEI A,ICSB
MOVEI B,FDBFIL
MOVE T,[GJ%OLD+GJ%IFG+GJ%FLG]
MOVEM T,DEFINP ;SET FLAGS FOR GTJFN
MOVEI T,DEFINP ;POINT TO THE FDB
MOVEM T,.CMGJB(A)
COMND ;GET THE INPUT FILE SPEC
ERCAL ERRPC
CKERR
ERROR <Form file specification required>,<JRST GETINF>
MOVEM B,INPJFN ;SAVE THE JFN
MOVEI A,ICSB
MOVEI B,FDBCFM ;REQUIRE CONFIRMATION
COMND
ERCAL ERRPC
MOVE A,INPJFN
GETIN3:
TXNE A,GJ%DEV!GJ%UNT!GJ%DIR!GJ%NAM!GJ%EXT!GJ%VER
HLRM A,WILD ;SAVE FLAGS
CALL OPENIF
JRST GTINER ;FAILED TO OPEN FILE
TXNE F,%TTYIN ;IF TTY INPUT
CALL GETLOG ;THEN OPEN THE LOG FILE
HRROI A,NMSPEC ;PLACE TO PUT FILE NAME
HRRZ B,INPJFN
TXNE F,%TTYIN ;IF TTY INPUT
MOVE B,LOGJFN ;THEN USE LOG FILE
MOVE C,JFNSWD
JFNS ;GET THE FILE NAME
ERCAL ERRPC
AOS (P) ;SET UP SKIP RETURN NOW
SKIPN WILD ;IF NOT WILD
SKIPE RSCFLG ; OR NOT CALLED WITH RESCAN
SKIPA
RET ; THEN RETURN
HRROI A,NMSPEC
PSOUT ;TYPE THE FILESPEC STRING
TMSG <
>
RET
GTINER:
HRRZ A,INPJFN ;FAILED TO OPEN THE JFN
RLJFN ;SO RELEASE IT
ERCAL ERRPC
JRST GETINF ;AND TRY AGAIN
COMMENT *
HERE WE OPEN A FILE TO LOG COMPLETE COMMANDS
ENTERRED FROM A TERMINAL. THIS PRODUCES A
FILE WHICH CAN BE EDITTED AT A LATER TIME.
*
GETLOG:
MOVEI A,ICSB
MOVE B,[POINT 7,[ASCIZ !Log commands in file: !]]
MOVEM B,.CMRTY(A)
MOVEI B,GETLG0
HRRM B,.CMFLG(A)
MOVEI B,FDBINI ;INIT THE CSB
COMND
ERCAL ERRPC
GETLG0:
MOVEI A,ICSB
MOVEI B,FDBFIL ;GET A FILESPEC
MOVX T,GJ%FOU
MOVEM T,DEFINP+.GJGEN
MOVEI T,DEFINP
MOVEM T,.CMGJB(A)
COMND
ERCAL ERRPC
CKERR
ERROR <Log file specification required>,<JRST GETLOG>
MOVEM B,LOGJFN ;SAVE THE LOG JFN
MOVEI A,ICSB
MOVEI B,FDBCFM
COMND
ERCAL ERRPC
MOVE A,LOGJFN
MOVE B,[OF%WR+7B5] ;ASCII OUTPUT
OPENF
ERJMP [CALL ERR
JRST GETLOG]
CALL CRLF
RET
SUBTTL INPUT FILE OPEN AND CLOSE
OPENIF: ;INPUT FILE OPEN ROUTINE
TXZ F,%TTYIN ;MAY NOT BE TTY INPUT (YET)
MOVEI A,377777 ;DEFAULT OUTPUT JFN
MOVEM A,HLDJFN
HRRZ A,INPJFN ;RESTORE THE JFN
DVCHR ;SEE IF TTY
ERCAL ERRPC
LDB C,[POINT 9,B,17] ;GET DEVICE CODE
MOVE T1,[OF%RD+7B5] ;SETUP FOR OPEN
CAIE C,.DVTTY ;SKIP IF A TTY
JRST OPNIF1 ;GO OPEN FILE
TXO F,%TTYIN ;INDICATE TTY INPUT
MOVE T,INPJFN ;SAME INPUT
MOVEM T,HLDJFN ;HOLD THE JFN HERE.
ORI T1,OF%WR ; ALSO WRITE ACCESS
OPNIF1:
HRRZ A,INPJFN ;OPEN FILE
MOVE B,T1 ;GET FLAGS
OPENF
ERJMP [CALL ERRNCT ;ERROR - COUNT WHEN FILE OPEN
RET] ;NON-SKIP RETURN ON ERRORS
HRLZ T,INPJFN ;SET UP CSB
HRR T,HLDJFN
MOVEM T,CSB+.CMIOJ ;JFN'S
AOS (P) ;SKIP RETURN ON GOOD OPEN
RET
CLOSES: ;CLOSE ALL FILES
MOVE T,[-NJFN,,OUTJFN] ;SET A COUNTER ETC
MOVEI B,377777 ;NULL JFN
CLOSE1:
HRRZ A,(T) ;GET A JFN TO CLOSE
CAIN B,(A) ;IS IT WORTH DOING?
JRST CLOSE2 ; NO
CLOSF
ERCAL CLSER ;CAN'T - SEE WHY
MOVEM B,(T) ;RESET THE JFN TO NULL
CLOSE2:
AOBJN T,CLOSE1 ;ROUND FOR MORE
CLOSIF:
HRRZ A,INPJFN ;NOW DO THE INPUT FILE
SKIPE WILD ;IF IT HAD WILDCARDS
TXO A,CO%NRJ ; THEN DONT RELEASE IT (YET)
CLOSF
ERCAL ERRPC
RET
CLSER:
CAIE A,CLSX1 ;WAS IT BECAUSE FILE WASN'T OPEN
SKIPE ERRCNT ;IF ERRORS DETECTED -
SKIPA
JRST CLSER1 ;REALY FAILED
MOVE HLDJFN,(T) ;YES - RELEASE THE JFN
PJRST RELJFN
CLSER1:
CALL ERRPC ;ELSE IT IS AN ERROR
MOVEI B,377777 ;RESET B
RET
ERRPC: ;ERROR AND PC MESSAGE
TMSG <? Error at PC >
HRRZ B,(P)
SOJ B, ;CALL ADDR - 1 = PC
MOVEI A,.PRIOU
MOVEI C,^D8 ;OCTAL
NOUT
ERJMP .+1
CALL CRLF
ERR: ;REPORT ERRORS
TXNN F,%TTYIN ;NO ERR ON TTY
AOS ERRCNT ;ADD ONE ERROR
ERRNCT: ;ERROR - BUT DONT COUNT IT
MOVEI A,"?"
PBOUT
MOVEI A,.PRIOU ;ERRORS TO TERMINAL
MOVE B,[.FHSLF,,-1] ;LAST ERROR IS REPORTED
ERSTR
JFCL
JFCL
CALL CRLF
RET
ERRFIL: ;ERROR ON FILE I/O
CALL ERR ;SEND THE MESSAGE
SETOM ERRFLG ;SET A FLAG
RET ;RETURN (UP ONE LEVEL)
COMMENT *
CALLED WITH SOURCE ADDRESS IN 'C'.
ON RETURN :
C = AMOUNT OF INPUT NOT PROCESSED
D = NUMBER OF ! DATA ! CHARACTERS TRANSFERRED
*
MOVATM: ;MOVE STRING FROM ATOM BUFFER
MOVSI B,(POINT 7,0) ;DEST IN T
HRR B,T
MOVATP: ;ENTER WITH POINTER IN B
MOVEI C,ATOMLN ;LENGTH OF BUFFER
MOVE A,[POINT 7,ATOM] ;SOURCE
SETZB T,D ;TEMPS
TXZ F,%CLASS!%SIGND ;NO CHARS. SEEN YET
MOVLOP:
SKIPN C ;ANY INPUT LEFT
RET ;NO
ILDB T,A ;GET INPUT
SKIPE T ;NULL ?
CAIN T,12 ;<LF> ?
JRST MOVDON ; YES-DONE!
CAIGE T," " ;IGNORE SPACE OR CONTROL
JRST MAXX
CAIL T,"0" ;NUMERIC?
CAILE T,"9"
JRST MANN
TXO F,%NUMER ;YES
JRST MAX
MANN:
CAIL T,"A"
CAILE T,"Z"
JRST MANA
TXO F,%ALPHA
JRST MAX
MANA:
CAIL T,"a" ;SEE IF LOWER CASE
CAILE T,"z"
JRST MASG
TXO F,%ALPHA ;YES
JRST MAX
MASG:
CAIE T,"+" ;SEE IF ITS A SIGN CHARACTER
CAIN T,"-"
SKIPE D ;ONLY ALLOWED IN FIRST PLACE
JRST MAPN
TXO F,%SIGND ;YES - FLAG IT
JRST MAX
MAPN:
TXO F,%PUNCT ;MUST BE PUNCTUATION
TXZ F,%SIGND ;SIGN IS NO GOOD NOW
JRST MAX
MAXX:
WARN <Control characters are not allowed in strings - character ignored>
SOS D ;DON'T COUNT THE CHARACTER
SKIPA
MAX:
IDPB T,B ;SAVE BYTE
SOJ C, ;ONE LESS LEFT IN BUFFER
AOJA D,MOVLOP ;COUNT IT AND LOOP
MOVDON: ;OUTPUT NULL AT END OF STRING
SETZ T, ;MAKE A NULL
IDPB T,B
SOJ C, ;ONE LESS LEFT
RET ;GO BACK
MOVCMD: ;MOVE STRING FROM COMMAND BUFFER
MOVE A,T ;OUT JFN
HRROI B,TEXT ;FROM TEXT
MOVEI C,TEXTLN
MOVEI D,12 ;END ON <LF>
SOUT
RET
TYPCMD: ;TYPE COMAND LINE ON TTY
HRROI B,TEXT
MOVEI A,.PRIOU
MOVEI C,TEXTLN
SETZ D,
SOUT
ERCAL ERRPC
RET
CMDINI: ;INIT CMD LINE
MOVEI A,CSB ;INIT COMMAND
MOVEI B,FDBINI
COMND
ERCAL ERRPC ;ERRORS
RET
SUBTTL EXIT - POSTCHECK - RELATED ROUTINES
CMEXIT: ;EXIT FROM TFR
TXNN F,%SWOUT ;OUTPUT FILE ?
WARN <No output file specified
%Data file will not be created>
TXNE F,%SWFLD ;REQD COMMANDS GIVEN ?
ERROR <Command ignored; POSITION and LENGTH required>,<TXNE F,%TTYIN
RET
JRST .+1>
TXNN F,%SWFRM ;FORM NAME SEEN ?
ERROR <Form name must be specified>,<TXNE F,%TTYIN
RET
JRST .+1>
SETOM EXITCM ;FLAG REAL EXIT COMMAND
SKIPL EOF ;IF END-OF-FILE
CALL CMDEND ;LOG IT IF TTY
CALL POSTCK ;POST CHECK FOR ERRORS
SKIPG T,ERRCNT ;GET THE ERROR COUNT
RET ;ALL OK
CALL CRLF
NUMBR ,T
TMSG < errors detected
>
RET
SUBTTLE FORM COMMANDS
;
;THE FOLLOWING COMMAND ROUTINES ARE ALL FOR THE PREAMBLE PART OF THE
;FORM FILE - AND NOT FOR INDIVIDUAL FIELDS. THESE ROUTINES SHOULD BE
;KEPT IN ALPHABETICAL ORDER. THE EXIT ROUTINE IS ABOVE.
;
CMALG: ;SET WORD ALIGNED MODE
CALL CMDEND
CMALG1:
SETOM ALIGN ;FORCE WORD ALIGNED DATA
MOVEI T,%ALIGN
ORM T,FATTR ;SET THE BIT IN FIELD ATTRIBUTES
RET
CMCHAR: ;CHARACTER SET
MOVEI A,CSB
MOVEI B,FDBCHR
COMND ;GET CHAR SET TYPE
ERCAL ERRPC
CKERR
ERROR <Invalid CHARACTER-SET identifier>,RET
CALL CMDEND
HRRZ B,(B) ;GET TABLE DATA
MOVEM B,CHRSET ;SAVE THE VALUE
RET
CMERAT: ;GET ERROR LINE ATTRIBUTES
SETZ PRM, ;AND CLEAR THEM
CALL VDOSET ;READ THE ATTRIBUTE BITS
TXNE PRM,%TALL!%WIDE!%GRAPH ;WIDE AND TALL CANNOT HAPPEN
ERROR <Invalid ERROR-LINE attribute>,RET
ASH PRM,-^D27 ;MOVE DOWN A BIT
ORM PRM,EATTR ;SAVE THEM
CALL LOGTTY
RET
CMERRM: ;ERROR MESSAGE LINE NUMBER
MOVEI A,CSB
MOVEI B,FDBERL ;GET A LINE NUMBER
COMND
ERCAL ERRPC
CKERR
ERROR <Invalid argument for ERROR-LINE command>,RET
HRLI C,0 ;SEE IF SPECIAL COMMAND
CAIE C,FDBERX ;SKIP IF NUMBER
JRST [HRRZ B,(B) ;GET EQUIVALENT NUMBER
CAMLE B,MAXLIN ;USE MAXLIN IF SMALLER
MOVE B,MAXLIN
JRST .+1]
CALL CMDEND
CAMLE B,MAXLIN ;IF VALUE WAS TOO BIG...
JRST [CALL ERMXLN ;THEN TELL HIM
WARN <ERROR-LINE moved to bottom of screen.>
SETZ B,
JRST .+1]
TXOE F,%SWERL ;SAW ERR-LINE
WARN <ERROR-LINE redefined>
MOVEM B,ERRLIN ;AND SAVE IT AWAY
RET
CMFRAT: ;FORM ATTRIBUTES
SETZ PRM, ;AND CLEAR THEM
CALL VDOSET ;READ THE ATTRIBUTE BITS
TXNE PRM,%REND&^-%RVRS ;ONLY REVERSE IS ALLOWED
ERROR <Invalid form attribute>,RET
ASH PRM,-^D27 ;MOVE DOWN A BIT
ORM PRM,FATTR ;SAVE THEM
CALL LOGTTY
RET
;PARSE A FORM COMMAND. THE FORM NAME MUST FOLLOW THE SYNTAX OF A COBOL
;VARIABLE NAME, SO CALL CMCOB FOR IT. IF THE USER ALREADY GAVE A FORM NAME,
;PRINT A WARNING AND USE THE NEW NAME.
CMFORM: ;PARSE A FORM NAME
MOVEI A,CSB ;READ THE FORM NAME
MOVEI B,FDBFRM ;..
CALL CMCOB ;IN COBOL VARIABLE NAME FORMAT
RET ;BAD ID--CMCOB PRINTED MESSAGE
CALL CMDEND ;FINISH THE LINE AND LOG IT
TXOE F,%SWFRM ;REMEMBER THAT WE SAW THE NAME
WARN <Form name redefined> ;BUT ALSO CHECK IF REDEFINING
MOVEI T,NMFORM ;FORM NAME PTR
CALL MOVATM ;SAVE NAME
RET
CMHSN: ;HIGH SECTION NUMBER
MOVEI A,CSB
MOVEI B,FDBN.C
COMND
ERCAL ERRPC
CKERR
ERROR <Section number required>,RET
CAIG B,MX%SEC ;IS IT IN CORRECT RANGE
CAIG B,0
ERROR <Section number outside the range >,JRST CMHERR,X
MOVEM B,NUMSEC ; AND HERE
ADDI B,^D35 ;COMPUTE NUMBER OF WORDS
IDIVI B,^D36 ; OF SECTIONS WILL REQUIRE.
MOVNI A,(B) ;MAKE AN AOBJN POINTER
MOVSI A,(A)
HRRI A,HDRWRD
ADDI A,.FRMLN
MOVEM A,HDNPTR ;AND SAVE IT
MOVEI A,.DATA ;GENERATE POINTER TO DATA AREA
ADDI A,(B) ;AND OFFSET IT
MOVEM A,DATA
ADDI B,.FRMLN ;LENGTH OF HEADER DATA
MOVEM B,FRMLEN
ADDI B,.FLDLN-.FRMLN ;CONVERT LENGTH TO FIELD DATA
MOVEM B,FLDLEN ;SAVE FIELD DATA SIZE
MOVEI A,STRING ;CALCULATE THE MAXIMUM NUMBER
SUB A,DATA ; OF FIELDS ALLOWED IN THE FORM.
IDIVI A,(B) ; = (STRING - DATA) / FLDLEN
MOVEM A,MAXFLD
CALL CMDEND
RET
CMHERR: ;ERROR HANDLING FOR PRINTING RANGE.
MOVEI B,MX%SEC
PJRST NOUTB
CMOUTF: ;OUTPUT FILE JFN GETTER
MOVE HLDJFN,OUTJFN
MOVEI T,DEFOUT
MOVEM T,CSB+.CMGJB ;SET UP FOR OUTPUT FILE SPEC
MOVEI A,CSB
MOVEI B,FDBFIL
COMND
ERCAL ERRPC
CKERR ;O.K. ?
JERROR <File name required in OUTPUT command>,RET
CALL CMDEND
MOVEM B,OUTJFN
MOVEI T,NMOUTF ;SAVE NAME
CALL MOVATM
TXON F,%SWOUT ;SAW OUTPUT FILE
RET
WARN <Output file redefined>
CALL RELJFN
RET
CMREC: ;RECORD DESC. FILE SPEC
MOVE HLDJFN,RECJFN
MOVEI T,DEFREC
MOVEM T,CSB+.CMGJB
MOVEI A,CSB
MOVEI B,FDBFIL
COMND
ERCAL ERRPC
CKERR
JERROR <File name required in RECORD-DESCRIPTION-FILE command>,RET
CALL CMDEND
MOVEM B,RECJFN
MOVE A,[POINT 7,TEXTBF] ;POINT TO TEMP BUFFER
MOVSI C,(JS%TYP) ;ONLY WANT TYPE
SETZ D,
SETZM TEXTBF ;CLEAR BUFFER READY FOR COMPARE
MOVE T1,[TEXTBF,,TEXTBF+1]
BLT T1,TEXTBF+<<TEXTLN+2>/5>-1
JFNS ;GET JFN INFO
ERCAL ERRPC
SETZB T1,T2
CMR.1:
MOVEI A,3 ;LENGTH OF STANDARD STRINGS
MOVEI D,^D30 ;MAX LENGTH OF TYPE FIELD
MOVE T,[POINT 7,TEXTBF] ;SET A POINTER
SKIPN B,EXTNS(T2) ;GET POINTER TO NEXT TYPE
JRST [SETZ T2, ;ASSUME DEFAULT
JRST CMR.2]
EXTEND A,[CMPSE
0
0]
AOJA T2,CMR.1 ;NOT FOUND YET
AOJ T2, ;OFFSET IT
CMR.2:
MOVEM T2,RECTYP ;SAVE THE LANGUAGE TYPE
CAIN T2,2
CALL CMALG1 ;SET THE ALIGN FLAGS IF FORTRAN
MOVEI T,NMRECF
CALL MOVATM
TXON F,%SWREC
RET
WARN <Record description file redefined>
CALL RELJFN
RET
;
;TABLE OF VALID EXTENSIONS WHICH LEAD TO A SPECIFIC LANGUAGE IN
;THE RECORD DESCRIPTION FILE. THE DEFAULT IS COBOL.
;
EXTNS:
POINT 7,[ASCIZ /CBL/]
POINT 7,[ASCIZ /FOR/]
POINT 7,[ASCIZ /MAC/]
0
CMSIZE: ;SET SIZE OF SCREEN
MOVEI A,CSB
MOVEI B,FDBMXL
COMND
ERCAL ERRPC
CKERR
ERROR <Line number required in SIZE command>,RET
CAIG B,^D63
CAIG B,0
ERROR <Range for line number is 1 to 63>,RET
MOVE ARG,B ;SAVE LINE NUMBER
MOVEI A,CSB
MOVEI B,FDBMXC
COMND
ERCAL ERRPC
CKERR
ERROR <Column number required for SIZE command>,RET
CAIG B,^D255
CAIG B,0
ERROR <Range for column number is 1 to 255>,RET
CALL CMDEND
MOVEM ARG,MAXLIN ;SAVE MAX LINES
MOVEM B,MAXCOL ;SAVE MAX COLUMNS
TXNN F,%SWERL ;IF ERROR-LINE SET
RET ; NOT
CAMLE B,ERRLIN ;IF GTR THAN ERROR-LINE NUMBER
RET ;OK
MOVEM B,ERRLIN ;ELSE FORCE BOTTOM OF SCREEN
WARN <ERROR-LINE moved to bottom of screen.>
RET
CMSUMM: ;SUMMARY-FILE SPEC
MOVE HLDJFN,SUMJFN
MOVEI T,DEFSUM
MOVEM T,CSB+.CMGJB
MOVEI A,CSB
MOVEI B,FDBFIL
COMND
ERCAL ERRPC
CKERR
JERROR <File name required in SUMMARY-FILE command>,RET
CALL CMDEND
MOVEM B,SUMJFN
MOVEI T,NMSUMF
CALL MOVATM
TXON F,%SWSUM
JRST CMSM1
WARN <Summary file redefined>
CALL RELJFN
CMSM1:
MOVE A,SUMJFN ;GET SUMMARY FILE JFN
MOVE B,[OF%WR+7B5] ;OUTPUT, ASCII
OPENF ;DO OPEN
JERROR <SUMMARY-FILE will not be written>,<JRST ERRFIL>
FMSG SUMJFN,<************************************************************>,,,CR
FMSG SUMJFN,<*>,,,CR
FMSG SUMJFN,<* Record description of form: >,NMFORM,,CR
FMSG SUMJFN,<*>,,,CR
FMSG SUMJFN,<* Specification file: >,NMSPEC,,CR
FMSG SUMJFN,<*>,,,CR
FMSG SUMJFN,<* Date of compilation: >,DAYTIM,,CR
FMSG SUMJFN,<*>,,,CR
FMSG SUMJFN,<************************************************************>,,,CR
FMSG SUMJFN,,,,CR
RET
CMTERM: ;TERMINALS ALLOWED
MOVEI A,CSB
MOVEI B,FDBTRM
COMND
ERCAL ERRPC
CKERR
ERROR <Invalid terminal type specified in TERMINAL command>,RET
HRLI C,0
CAIN C,FDBCFM ;IF DONE
PJRST LOGTTY ; THEN RETURN
HRRZ B,(B) ;GET THE TYPE
MOVEI A,1
ASH A,(B) ;GET BIT EQUIVALENT TO TERMINAL
ORM A,TERMS
SKIPN B ;IF IT WAS "ALL"
SETOM TERMS ;THEN DEFAULT TO ALL
HRRZ A,TRMSIZ(B) ;GET THE TERMINAL'S WIDTH
CAMG A,MAXCOL ;IF SMALLER
MOVEM A,MAXCOL ; THEN USE THIS SIZE
HLRZ A,TRMSIZ(B) ;GET TERMINAL'S HEIGHT
CAMG A,MAXLIN ;IF SMALLER
MOVEM A,MAXLIN ; THEN USE THIS SIZE
JRST CMTERM ;SEE IF MORE
SUBTTLE FIELD COMMANDS
;THE FOLLOWING ROUTINES ARE FOR COMMANDS WHICH CAN BE SPECIFIED IN A
;FIELD DEFINITION. THEY ARE KEPT IN ALPHABETICAL ORDER.
CMALLC: ;ALLOW LOWER CASE
CALL CMDEND
TXO PRM,%LOWER
RET
CMALPH: ;ALPH TYP FIELD
TXNE PRM,%DATE
ERROR <DATE field cannot be ALPHABETIC>,RET
TXNE PRM,%MONEY
ERROR <MONEY field cannot be ALPHABETIC>,RET
TXNE F,%MSSN
ERROR <SOCIAL-SECURITY-NUMBER field cannot be ALPHABETIC>,RET
TXNE F,%MTIM
ERROR <TIME field cannot be ALPHABETIC>,RET
CALL CMDEND
ICMALP: ;INTERNAL CALL TO COMMAND
TXZ PRM,%CLASS
TXO PRM,%ALPHA
CALL CKSTNG
RET
CMAN: ;ALPHA-NUMERIC
CALL CMDEND
ICMAN:
TXZ PRM,%CLASS
TXO PRM,%ALPHA+%NUMER ;SET ALPHA-NUMERIC
CALL CKSTNG
RET
CMANP: ;ALPHA-NUMERIC-PUNCTUATION
CALL CMDEND
TXO PRM,%CLASS
RET
CMATO: ;AUTO-TAB
CALL CMDEND
TXZ PRM,%NAUTO
RET
CMBLNK: ;BLINKING RENDITION
CALL CMDEND
TXO PRM,%BLNK
RET
CMBOLD: ;BOLD RENDITION
CALL CMDEND
TXO PRM,%BOLD
RET
CMDATE: ;DATE FIELD
TXNN PRM,%TYPE+%SFDEF ;IF KNOWN TYPE OR SUBFIELD
TXNE F,%MTYPE ;INCLUDING SSN
ERROR <Field type cannot be redefined>,RET
MOVEI A,CSB
MOVEI B,FDBDAT ;GET TYPE OF DATE
COMND
ERCAL ERRPC
CKERR
ERROR <Invalid date format specified>,RET
CALL CMDEND
TXO PRM,%DATE ;SET DATE TYPE
HRRZ B,(B) ;GET DATE NUMBER
MOVEM B,DATTYP ;SAVE THE TYPE OF DATE FIELD.
LDB B,DATLNG ;GET LENGTH OF THE DATA FIELD
SKIPE LONGDT ;IF LONG FORMAT
ADDI B,2 ; THEN INCREASE THE LENGTH
CALL ICMLEN ; AND SET THE LENGTH
MOVE B,DATTYP ;RESTORING THE TYPE OF DATE,
LDB B,DATCLS ; GET THE TYPE OF DATE
JRST .+1(B) ; AND SELECT:
JRST [CALL ICMNUM ; SET NUMERIC
RET]
JRST [CALL ICMAN ; SET ANPHA-NUMERIC
RET]
CMDESC: ;SUBFIELD DESCRIPTOR
TXNN PRM,%TYPE+%SFDEF ;CANNOT REDEFINE THE DESCRIPTOR
TXNE F,%MTYPE
ERROR <Field type cannot be redefined>,RET
MOVEI A,CSB
MOVEI B,FDBQST ;STRING
COMND
ERCAL ERRPC
CKERR
ERROR <String required in DESCRIPTOR command>,RET
CALL CMDEND
MOVEI T,NMDES
CALL MOVATM ;MOVE STRING
MOVE B,[POINT 7,NMDES] ;POINTER TO STRING
MOVE E,[POINT 9,NMSFD] ;POINTER TO DESCRIPTOR
TXZ PRM,%CLASS ;NO CLASS TYPE
SETZM SFCNT ;CLEAR BYTE COUNTER
SETZM SFLEN ;NO LENGTH
SETZM SFSEP ;NO SEPARATORS
SETZM LASTSP ;NO SEPARATORS SEEN
SETZM NUMBSP ;NO SEPARATORS SEEN
SETZM LASTTC ;NO TYPE CHARACTER
SETZM NUMBTC ;NO TYPE CHARACTERS SEEN
SETO T1, ;MAKE NON-NULL
CALL DESC10 ;CREATE THE DESCRIPTOR
SETZ T1, ;APPEND A NULL BYTE
IDPB T1,E ; TO END OF THE STRING
TXO PRM,%SFDEF ;INDICATE WE GOT ONE
MOVE B,SFLEN
CALL ICMLEN ;UPDATE THE LENGTH
RET
DESC10:
SKIPN T1 ;IF CURRENTLY NULL
RET ; THEN WE ARE DONE
ILDB T1,B ;GET NEXT STRING BYTE
SKIPN T1 ;IF NULL
JRST [CALL DESC80 ; THEN CLEAN UP
CALL DESC90
RET] ; AND FINISH UP.
CAIL T1,140 ;IF LOWER CASE
SUBI T1,40 ;THEN CONVERT FOR SIMPLICITY
CAIN T1,"[" ;IF STARTING A SEPARATOR
JRST DESC60 ; THEN PROCESS SEPARATORS
; CAIN T1,"<" ;IF SETTING VIDEO ATTRIBUTES
; JRST DESC50 ; THEN SET THEM.
CAIN T1,"^" ;IF IT IS A "OVERRIDE"
JRST DESC40 ; THEN NEXT CHARACTER IS SEP.
MOVE T2,[-DSCTLN,,DSCTBL] ;SET UP AOBJN POINTER TO TABLE
DESC11:
HRRZ T3,(T2) ;GET A BYTE
CAIN T3,(T1)
JRST DESC30 ;ITS A GOODIE
AOBJN T2,DESC11 ;NOPE - TRY NEXT ONE
DESC20: ;PROCESS A SEPARATOR
CALL DESC25 ;PROCESS THIS SEPARATOR
JRST DESC10 ;GET NEXT CHARACTER
DESC25:
SKIPN T2,NUMBSP ;IF NO SEPARATORS YET
JRST [CALL DESC80 ; PROCESS ANY TYPE CHARACTERS
MOVEM T1,LASTSP ; SAVE THIS SEPARATOR
AOS NUMBSP ; SET COUNT TO 1.
RET]
CAME T1,LASTSP ;IF IT IS NOT THE SAME SEPARATOR
CALL DESC90 ; THEN OUTPUT CURRENT ONE
MOVEM T1,LASTSP ;MAKE SURE IT IS SAVED.
AOS NUMBSP ;COUNT THIS
RET
DESC30: ;PROCESS A TYPE CHARACTER
HLL T1,(T2) ;COPY THE DISPATCH ADDRESS
CALL DESC35 ;PROCESS THE CHARACTER
JRST DESC10 ;GET THE NEXT ONE.
DESC35:
SKIPN T2,NUMBTC ;IF DO NOT HAVE ONE SAVED.
JRST [MOVEM T1,LASTTC ; THEN SAVE THIS ONE
CALL DESC90 ;PROCESS ANY SEPARATORS SAVED
AOS NUMBTC ;MAKE THE COUNT 1.
RET]
CAME T1,LASTTC ;IF NOT THE SAME TYPE CHARACTER
ERROR <Subfield type can only change at a separator>
AOS NUMBTC ;COUNT THE NUMBER
RET
DESC40: ;PROCESS THE "^" OVERRIDE MARKER
CALL DESC45 ;OVER RIDE NEXT CHARACTER
JRST DESC10 ; AND THEN LOOP.
DESC45:
ILDB T1,B ;GET THE NEXT CHARACTER
SKIPN T1 ;IF IT IS NULL
RET ; THEN WE ARE DONE
CALL DESC25 ;PROCESS AS A SEPARATOR
RET
DESC60: ;PROCESS THE "[" START SEPARATOR INDICATOR
CALL DESC65 ;PROCESS THE STRING (TO "]")
JRST DESC10 ;AND THEN LOOP.
DESC65:
ILDB T1,B ;GET THE NEXT CHARACTER
SKIPE T1 ;IF NULL
CAIN T1,"]" ;IF END OF SEPARATOR STRING
RET ; THEN DONE.
CALL DESC25 ;PROCESS CHARACTER AS SEPARATOR
DESC67: ;IGNORE ALL OTHER SEPARATORS IN HERE
ILDB T1,B
CAIE T1,"]"
SKIPN T1
RET
JRST DESC67
DESC80: ;FINAL PROCESSING OF A TYPE CHARACTER STRING
SKIPN T3,NUMBTC ;IF NO TYPE CHARACTERS SAVED
RET ; THEN DONE
ADDM T3,SFLEN ;UPDATE LENGTH WITH THIS MANY.
CAIE T3,1 ;IF LENGTH GREATER THAN ONE
CALL [ORI T3,%SFLEN ; THEN FORM LENGTH INDICATOR
JRST DESC95] ;STORE BYTE AND FINISH
HLRZ T3,LASTTC ;AND DISPATCH ADDRESS
JRST (T3) ;GO TO IT
DSC100:
MOVEI T3,%T.ALP ;A - ALPHABETIC
TXO PRM,%ALPHA
JRST DESC85
DSC101:
MOVEI T3,%T.ALP+%T.SPC ;S - ALPHABETIC WITH SPACES
TXO PRM,%ALPHA+%SPACE
JRST DESC85
DSC102:
MOVEI T3,%T.X ;X - ALPHANUMERIC
TXO PRM,%ALPHA+%NUMER
JRST DESC85
DSC103:
MOVEI T3,%T.DIG ;Z - NUMBER
TXO PRM,%NUMER
JRST DESC85
DSC104:
MOVEI T3,%T.ZER ;9 - NUMBER WITH LEADING ZERO
TXO PRM,%NUMER+%ZERO
; JRST DESC85
DESC85:
SETZM LASTTC ;INITIALIZE STATE INDICATORS
SETZM NUMBTC
JRST DESC95 ;STORE BYTE AND FINISH
DESC90: ;PROCESS THE SEPARATOR
SKIPN T3,NUMBSP ;IF NO SEPARATORS
RET ; THEN WE ARE DONE
ADDM T3,SFSEP ;UPDATE COUNT OF SEPARATORS
CAIE T3,1 ;IF MORE THAN ONE SEPARATOR
CALL [ORI T3,%SFLEN ; THEN OUTPUT A LENGTH INDICATOR
JRST DESC95] ;STORE BYTE AND FINISH
MOVE T3,LASTSP ;GET THE SEPARATOR
ORI T3,%SFSEP ; LABEL AS SEPARATOR
SETZM LASTSP ;INITIALIZE STATE INDICATORS
SETZM NUMBSP
DESC95:
AOS SFCNT ;COUNT A BYTE
IDPB T3,E ;PUT INTO DESCRIPTOR
RET
DSCTBL: ;TABLE OF VALID CHARACTERS
DSC100,,"A" ;ALPHABETIC
DSC101,,"S" ;ALPHABETIC WITH SPACE
DSC102,,"X" ;ALPHANUMERIC
DSC103,,"Z" ;NUMERIC
DSC104,,"9" ;NUMERIC WITH LEADING ZEROS
DSCTLN=.-DSCTBL
CMDVET: ;DATA-VET NUMBER
MOVEI A,CSB ;GET NUMBER PART OF CMD
MOVEI B,FDBNUM
COMND
ERCAL ERRPC
CKERR
ERROR <DATA-VET routine number missing>,RET
CAIG B,^D511 ;MUST BE IN RANGE 1 - 511
CAIG B,0
ERROR <VET-NUMBER not in range 1 to 511>,RET
TXOE F,%SWVET ;SEEN VET NOW
WARN <VET-NUMBER redefined>
PUTBYT B,.VETNO
ADJBP B,[POINT 1,VETTAB] ;POINT TO RELEVANT BIT
MOVEI A,1
DPB A,B ;SET IT
AOS VETFLG ;COUNT IT
CALL CMDEND
RET
CMECHO: ;ALLOW ECHOING
CALL CMDEND
TXZ PRM,%NEKO
RET
CMFILL: ;GET FILL CHARACTER
MOVEI A,CSB
MOVEI B,FDBQST ;GET TEXT
COMND
ERCAL ERRPC
CALL CMDEND
LDB T1,[POINT 7,ATOM,6]
MOVEM T1,FILLER
RET
;PARSE A FIELD COMMAND. FIRST, VERIFY THAT REQUIRED FIELDS WERE TYPED
;FOR THE CURRENT FIELD. THEN BUILD A DEFAULT FIELD NAME AND PARSE THE
;COMMAND. ONLY IF THE COMMAND PARSES OK DO WE FINISH UP THE CURRENT FIELD,
;SINCE THIS GIVES THE USER A CHANCE TO CHANGE HIS/HER MIND ON AN ERROR.
;FINALLY, INITIALIZE THE NEW FIELD.
CMFLD:
TXNE F,%SWFLD ;ALL REQUIRED COMMANDS GIVEN?
ERROR <POSITION or LENGTH missing for current field>,<TXNN F,%TTYIN
JRST .+1
WARN <Command ignored>>
MOVE A,RECTYP ;IF THIS IS FORTRAN OR MACRO
CAIGE A,2
JRST CMFD.1 ; IT MUST BE COBOL
MOVE E,[POINT 7,DEFFNM] ;POINT TO THE DEFAULT NAME
MOVEI A,"F" ;AND BUILD 'FDNNN'
IDPB A,E
MOVEI A,"D"
IDPB A,E
MOVEI D,CIDCLN-2 ;LENGTH OF MACRO ID - "FD"
JRST CMFD.2
CMFD.1:
DMOVE A,[6 ;MOVE "FIELD-"
POINT 7,[ASCII /FIELD-/]]
DMOVE D,[6
POINT 7,DEFFNM]
EXTEND A,[MOVSLJ] ; TO DEFAULT FIELD NAME
JFCL ;SHOULD NEVER FAIL
MOVEI D,CIDCLN-6 ;LEN OF ID - LEN OF "FIELD-"
CMFD.2:
SETZ A, ;APPEND NEXT FIELD NUMBER TO NAME
MOVE B,CURFLD ;..
ADDI B,1 ;NEXT FIELD #, NOT THIS ONE
EXTEND A,[CVTBDO "0"] ;THE REAL WORK
JFCL ;SHOULD NEVER FAIL
SETZ A, ;DEPOSIT A NUL TERMINATOR FOR COMND
IDPB A,T ;..
MOVEI A,CSB ;PARSE THE FIELD NAME
MOVEI B,FDBFLD ;..
CALL CMCOB ;WITH SPECIAL-PURPOSE ROUTINE
RET ;BAD ID--CMCOB PRINTED THE MESSAGE
CALL CMDEND ;PARSE THE END-OF-LINE AND LOG LINE
MOVEI T,FDBCM2 ;SEEN AT LEAST 1 FIELD COMMAND SO
MOVEM T,CMDPTR ;SHOW FIELD STUFF FIRST ON "?"
;NOW FIELD COMMAND HAS PARSED OK, SO WE CAN FINISH UP THE LAST FIELD.
CALL POSTCK ;POST-CHECK
SETZB PRM,FLDDSP ;ZERO PRMS AND RELETIVE DISPLACE
TXZ F,%FLBTS ;ZERO FIELD BITS
TXO F,%SWFLD ;SAW A FIELD CMD
MOVEI T,NRFLDS ;SET # REQD CMDS
MOVEM T,NUMREQ
SETZM LNUPR
SETZM LNHELP ;NO HELP MESSAGE NOW
SETZM LNLWR
SETZM LNVAL
SETZM LNFLD
SETZM MAXLEN
SETZM NMVAL ;CLEAR VALUE
SETZM FILLER
SETZM SAMEAS ;NOT COPIED (YET)
;WE'RE NOW READY TO INITIALIZE THE NEW FIELD.
AOS T,CURFLD ;ADVANCE TO THE NEXT FIELD NUMBER
CAMLE T,MAXFLD ;BUT NOT TOO FAR
ERROR <Too many fields specified - maximum is >,<MOVE B,MAXFLD
PJRST NOUTB>,X
CAIN CFLD,DEFFLD ;@DEFAULT FIELD ?
SKIPA CFLD,DATA ;POINT TO DATA AREA
ADD CFLD,FLDLEN ;GO TO NEXT FLD
SETZM 5(CFLD)
MOVEI T,NMFLD ;FIELD NAME PTR
CALL MOVATM
MOVEM D,LNFLD ;SAVE LENGTH
IFN DEFAULT,< ;COPY DEFAULT FIELD PARAMS
MOVE A,CFLD ;COPY TO THE CURRENT FIELD AREA
HRLI A,DEFFLD ;FROM THE DEFAULT FIELD SPECS
MOVEI B,.FLDLN-1(A) ;UNTIL CURRENT FIELD AREA IS FULL
BLT A,(B) ;..
>
RET
CMFULL: ;FULL FIELD REQUIRED
CALL CMDEND
TXO PRM,%FULL ;FULL FIELD NOT IMPLICITLY REQUIRED.
RET
CMGRPH: ;GRAPHIC CHARACTER SET
CALL CMDEND
TXO PRM,%GRAPH
RET
CMHELP: ;HELP MESSAGE
CAIN CFLD,DEFFLD ;IF AT DEFAULTS
ERROR <HELP not allowed in default fields>,RET
MOVEI A,CSB ;GET THE MESSAGE
MOVEI B,FDBQST
COMND
ERCAL ERRPC ;SHOULD BE OK!!
CKERR
ERROR <String required in HELP command>
CALL CMDEND
MOVEI T,NMHELP ;COPY STRING TO HERE
CALL MOVATM
MOVEM D,LNHELP ;SAVE LENGTH OF IT
TXOE F,%SWHLP ;FLAG THIS
WARN <HELP message redefined>
TXO PRM,%HELP ;SET BIT IN PRM
RET
CMHIDE: ;HIDDEN SECTION
CALL CMDEND
TXO PRM,%HIDE
SETOM HIDDEN ;AT LEAST ON IS HIDDEN
RET
CMINCL: ;CREATE A NEW INPUT FILE AND PUSH THE OLD ONE.
MOVEI T,DFINCL ;PROTOTYPE GTJFN BLOCK
MOVEM T,CSB+.CMGJB
MOVEI A,CSB
MOVEI B,FDBFIL ;FILE SPEC
COMND
ERCAL ERRPC
CKERR
ERROR <File name required or file not found in INCLUDE command>,RET
CALL CMDEND
MOVE A,NMINCL ;IF THE NUMBER OF NESTED INCLS
CAILE A,MX%INCL ; IS GREATER THAN WE CAN TAKE
ERROR <Too many nested INCLUDE commands>,RET
AOS A,NMINCL ;INCREMENT
MOVE Z,INPJFN ;GET CURRENT INPUT JFN
HRL Z,WILD ;SAVE THE CURRENT WILDCARD STATUS
SETZM WILD ;AND CLEAR IT
MOVEM Z,INCJFN(A) ;AND SAVE IT IN THE PUSHED JFN TABLE.
MOVEM B,INPJFN ; AND SAVE NEW JFN AS INPUT
CALL OPENIF ;OPEN THE INPUT FILE
JRST [MOVE A,INPJFN ;COULD NOT OPEN THE FILE, SO
RLJFN ; RELEASE THE JFN
ERCAL ERRPC ; AND
SOS A,NMINCL ; POP BACK THE PREVIOUS JFN.
MOVE A,INCJFN+1(A)
MOVEM A,INPJFN
RET] ;RETURN
MOVE A,SUMJFN ;IF WE HAVE A SUMMARY FILE OPEN,
CAIN A,377777 ; PUT FILE NAME IN IT
RET ; ELSE WE ARE DONE
SKIPE INCHDR ;HAS A HEADER BEEN PRINTED?
JRST CMIN02 ; YES
FMSG SUMJFN,<The following INCLUDE files were used:>,,,CR
SETOM INCHDR
CMIN02:
AOS B,NINCOT ;COUNT OF NUMBER OF NAMES WRITTEN
MOVE A,SUMJFN ;INTO SUMMARY FILE.
MOVEI C,^D10
HRLI C,5 ;SIZE OF OUTPUT FIELD.
NOUT ;WRITE NUMBER OF THE INCLUDE FILE
ERCAL ERRPC
MOVE A,NMINCL ;NUMBER OF LAST JFN IN TABLE
CMIN05:
SOSLE A ;PREFIX A + FOR EACH NESTING LEVEL
JRST [PUSH P,A
FMSG SUMJFN,<+>
POP P,A
JRST CMIN05]
HRROI A,NAMINC ;LOCATION OF WHERE TO PUT INCLUDE NAME
MOVE B,INPJFN ;NEW INCLUDE JFN
MOVE C,JFNSWD
JFNS
ERCAL ERRPC
FMSG SUMJFN,,NAMINC,,CR
RET
CMINDX: ;INDEX FIELD
CALL CMLT8 ;SHOULD BE NO MORE - COUNT IT
TXOE F,%SWIDX ;SAY WE'VE SEEN IT
ERROR <Only one INDEX field allowed>,RET
TXO PRM,%ZERO+%PROT+%NUMER+%INDEX
MOVEI B,2 ;LENGTH
TXON F,%SWLEN ;IF WE HAVE LENGTH
JRST CMIDX1
CAME B,MAXLEN ;AND IT IS DIFFERENT, THEN..
WARN <LENGTH redefined>
CMIDX1:
MOVEM B,MAXLEN ;SET IT UP
TXOE F,%SWVAL ;IF WE HAVE VALUE, THEN..
WARN <VALUE redefined>
MOVE T,[ASCIZ /00/]
MOVEM T,NMVAL ;PROPPER VALUE
MOVEM B,LNVAL ;AND ITS LENGTH
JRST DCRRQD ;DECREMENT #REQD FIELDS
CMLENG: ;GET FIELD LENGTH
TXNE PRM,%TYPE^!%MONEY ;TYPE BUT NOT MONEY ?
WARN <Command ignored - length is already set>,RET
MOVEI A,CSB
MOVEI B,FDBFLN ;LENGTH
COMND
ERCAL ERRPC
CKERR
ERROR <Number required in LENGTH command>,RET
CAIG B,^D127
CAIGE B,0
ERROR <Range for LENGTH command is 0 to 127>,RET
CALL CMDEND
SKIPA ;SKIP TELLEN IF LENGTH COMMAND
ICMLEN:
CALL TELLEN
SKIPN MAXLEN ;LENGTH ALREADY DONE?
CALL DCRRQD ;ONE LESS NEEDED
TXON F,%SWLEN ;SAW LENGTH ?
JRST ICMLN1 ;NO - SKIP THIS CHECK
CAME B,MAXLEN ;NEW LENGTH ?
WARN <LENGTH redefined>
ICMLN1: ;HERE TO SKIP LENGTH REDEF TEST.
MOVEM B,MAXLEN ;SAVE LENGTH
CAMGE B,LNVAL
WARN <VALUE truncated>
CAMGE B,LNLWR
WARN <LOWER-RANGE truncated>
CAMGE B,LNUPR
WARN <UPPER-RANGE truncated>
TXNN PRM,%VERT
TXNN F,%SWPOS ;POSITION SEEN YET?
RET
LOADC A,.COLM ;YES - GET COLUMN NUMBER
ADD A,MAXLEN ; AND SEE WHERE THE END IS
CAMLE A,MAXCOL ;WARN HIM IF OFF THE END
WARN <Field may be truncated at run time>
RET
CMLONG: ;LONG FORMAT DATE
SETOM LONGDT
JRST CMDATE ;CONTINUE AS NORMAL DATE
CMLOWR: ;LOWER RANGE
CAIN CFLD,DEFFLD ;AT DEF FLD
ERROR <LOWER-RANGE illegal in default fields>,RET
MOVEI A,CSB
MOVEI B,FDBQST ;STRING
COMND
ERCAL ERRPC
CKERR
ERROR <Value required for LOWER-RANGE>,RET
CALL CMDEND
TXO PRM,%RANGL ;SET L RANGE
TXOE F,%SWLRN
WARN <LOWER-RANGE redefined>
MOVEI T,NMLWR ;STR PTR
CALL MOVATM ;SAVE RANGE
MOVEM D,LNLWR ;SAVE LENGTH
MOVEI T,LWRFLG
CALL CKCLAS ;CLASS CONFLICTS ?
TXNE F,%SWLEN
RET
MOVE B,D ;GET LENGTH OF ITEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
CMMAST: ;MASTER-DUPE ATTRIBUTE
CALL CMDEND
TXZE PRM,%PRDUP ;SEE IF PR-DUPPED
WARN <Redefined from PREVIOUS-DUPE to MASTER-DUPE>
TXO PRM,%MSDUP ;SET MASTER-DUPE
RET
CMMONY: ;MONEY FIELD
TXNN F,%SWLEN ;IF LENGTH UNKNOWN, ERROR
ERROR <LENGTH of field must be set prior to MONEY command>,RET
TXNN PRM,%TYPE+%SFDEF ;IF KNOWN TYPE OR SUBFIELD
TXNE F,%MTYPE ;INCLUDING SSN
ERROR <Field type cannot be redefined>,RET
MOVEI A,CSB
MOVEI B,FDBN2C
COMND
ERCAL ERRPC
CKERR ;UNPARSABLE
ERROR <Number required in MONEY command>,RET
HRLI C,0
CAIN C,FDBCFM ;IF NO VALUE GIVEN
MOVEI B,2 ; THEN THE USE DEFAULT OF 2.
CAIG B,7 ;RANGE CHECK
CAIGE B,0
ERROR <Limit is 0 to 7 decimal places>,RET
CAMLE B,MAXLEN ;ERROR IF FIELD NOT LONG ENOUGH
ERROR <Number of decimal places greater than length>,RET
PUTBYT B,.TYPE ;SUBTYPE HAS NUMBER OF DECIMAL DIGITS.
CAIE C,FDBCFM ;ALREADY CONFIRMED ?
CALL CMDEND ;NO - END OF COMMAND
TXO PRM,%MONEY+%SIGND ;INDICATE MONEY AND SIGNED.
CAMN B,MAXLEN ;IF ONLY DECIMAL PLACES
TXZ PRM,%SIGND ; THEN NO SIGN.
CALL ICMNUM ;INDICATE NUMERIC
RET
CMMULT: ;MULTIPLE FIELDS
MOVEI A,CSB ;SET UP FOR NUMBER
MOVEI B,FDBNUM
COMND
ERCAL ERRPC
CKERR
JRST CMLT1 ;NO VALUES - TRY DEFAULT
SKIPE MSLEN ;SKIP IF NOT GOT IT
JRST CMLT2 ;CHECK PREVIOUS
CMLT6:
CAILE B,0 ;RANGE IS 1...
CAIL B,^D100 ;...TO 99
ERROR <Number of elements must be in the range 1 to 99>,RET
MOVEM B,MSLEN ;SAVE NO. OF ELEMENTS
CMLT3:
MOVEI A,CSB ;FOR NEXT NUMBER
MOVEI B,FDBNUM
COMND
ERCAL ERRPC
CKERR
JRST CMLT4 ;NO VALUE - TRY DEFAULT
SKIPE MSCNT
JRST CMLT5 ;CHECK PREVIOUS
CMLT7:
CAILE B,0 ;RANGE IS 1...
CAMLE B,MAXLIN ;...TO MAXLIN
ERROR <Number of display lines must be 1 to >,<PJRST ERMXL1>,X
MOVEM B,MSCNT ;SAVE DISPLY COUNT
CMLT8:
CALL CMDEND ;LOOK FOR END
TXOE PRM,%MULT ;FLAG THIS
RET ;DON'T COUNT IF ALREADY SET
AOSLE MLTRN ;COUNT FIELDS
ERROR <Too many MULTIPLE fields - maximum is 16>
RET
CMLT1:
SKIPN MSLEN ;OK IF NON-ZERO
ERROR <MULTIPLE command requires parameters>,RET
CMLT4:
SKIPN MSCNT ;AGAIN
JRST [MOVE B,MSLEN
JRST CMLT7]
JRST CMLT8
CMLT2:
CAME B,MSLEN ;REDEFINED?
JRST [WARN <MULTIPLE parameters redefined>
JRST CMLT6]
JRST CMLT3
CMLT5:
CAME B,MSCNT ;AGAIN
JRST [WARN <MULTIPLE parameters redefined>
JRST CMLT7]
JRST CMLT8 ;DONE
CMNATO: ;NO-AUTO-TAB
CALL CMDEND
TXO PRM,%NAUTO
RET
CMNEKO: ;NO-ECHO
CALL CMDEND
TXO PRM,%NEKO
RET
CMNODP: ;UNDUPPED
CALL CMDEND
TXZ PRM,%DUPE
RET
CMNORM: ;NORMAL RENDITION
CALL CMDEND
TXZE PRM,%REND
WARN <Rendition status cleared>
RET
CMNHID: ;NOT HIDDEN (FOR SAME-AS USE)
CALL CMDEND
TXZ PRM,%HIDE
RET
CMNUMR: ;NUMERIC FIELD
TXNN PRM,%DATE
JRST CMNU2
LOADC T,.TYPE ;DATE SUB-TYPE
TXZ T,%LONGD ;LEAVE ONLY THE RIGHT BITS
JRST .+1(T) ;BR TABLE
JRST ICMNUM ;CANADA
JRST ICMNUM ;COBOL
JRST ICMNUM ;DASH
JRST CMNU1 ;DEC
JRST ICMNUM ;JULIAN
JRST CMNU1 ;MILITARY
JRST ICMNUM ;SLASH
CMNU1:
ERROR <This type of field cannot be NUMERIC>,RET
CMNU2:
TXNE PRM,%YN
ERROR <YES-NO field cannot be NUMERIC>,RET
CALL CMDEND
ICMNUM: ;INTERNAL CALL TO COMMAND
TXZE PRM,%ALPHA!%PUNCT ;SEE IF ALPHA
WARN <Redefined to NUMERIC>
TXO PRM,%NUMER
TXNN PRM,%SFDEF ;IF THIS HAS NO SUBFIELDS
TXO PRM,%SIGND ; THEN IT CAN BE SIGNED
CALL CKSTNG
RET
CMNSPC: ;DO NOT ALLOW SPACES IN ALPHABETICS
CALL CMDEND
TXZ PRM,%SPACE
RET
CMNZRO: ;REWRITE NUMERICS WITH BLANK FILL
CALL CMDEND
TXZ PRM,%ZERO
RET
CMOPTN: ;OPTIONAL
CALL CMDEND
TXZ PRM,%REQD
RET
CMPOSI: ;POSITION OF FIELD ON SCREEN
CALL GETPOS ;GET POSITION
CALL CMDEND
TXNN F,%SWPOS
CALL DCRRQD
TXOE F,%SWPOS
SKIPE SAMEAS ;NO ERROR IF WE COPIED THE FIELD
SKIPA
WARN <POSITION redefined>
PUTBYT B,.COLM
PUTBYT ARG,.LINE
TXNN PRM,%VERT
TXNN F,%SWLEN ;LENGTH SEEN YET?
RET
ADD B,MAXLEN ; SEE WHERE THE END IS
CAMLE B,MAXCOL ;WARN HIM IF OFF THE END
WARN <Field may be truncated at run time>
RET
CMPREV: ;PREVIOUS-DUPE ATTRIB.
CALL CMDEND
CMPRVA:
TXZE PRM,%MSDUP ;SEE IF MAST-DUPE
WARN <Redefined from MASTER-DUPE to PREVIOUS-DUPE>
TXO PRM,%PRDUP ;SET PREV-DUPE
RET
CMPROT: ;PROTECTED ATTRIB.
CALL CMDEND
TXO PRM,%PROT
RET
CMREQU: ;REQUIRED PARAM.
CALL CMDEND
TXO PRM,%REQD
RET
CMREVS: ;REVERSE-VIDEO
CALL CMDEND
TXO PRM,%RVRS
RET
CMRSLC: ;RAISE-LOWERCASE
CALL CMDEND
TXZ PRM,%LOWER
RET
;THE "SAME-AS" COMMAND CAUSES THE ATTRIBUTES FROM A PREVIOUSLY
;DEFINED FIELD TO BE COPIED TO THE CURRENT FIELD. BECAUSE
;THIS WILL OVERWRITE DATA, IT IS NORMALLY THE FIRST COMMAND
;AFTER THE FIELD COMMAND.
CMSAME:
MOVEI A,CSB
MOVEI B,FDBSAM
CALL CMCOB ;GET A COBOL FIELD NAME.
RET ;NOT A LEGAL ONE.
CALL CMDEND
MOVE D,[ASCII/ /] ;5 BLANKS
MOVEM D,SAMNAM
MOVE D,[SAMNAM,,SAMNAM+1]
BLT D,SAMNAM+^D15 ;PUT BLANKS THRU WHOLE AREA.
MOVEI T,SAMNAM ;ADDRESS FOR NAME STRING
CALL MOVATM ; FOR MOVE-TO ROUTINE
MOVEM D,SAMLEN ; WHICH RETURNS LENGTH
MOVEI D," " ;REPLACE LAST CHARACTER WITH BLANK.
DPB D,B ;
CALL FNDFLD ;GET FIELDS NUMBER.
ERROR <Field name does not exist>,RET
MOVS T,FFLD ;THIS FIELDS LOCATION IN FIELD TABLE.
HRR T,CFLD ;CURRENT FIELDS LOCATION.
HRRZ A,T ;DUPLICATE IT.
ADDI A,.FLDLN ;UPDATE TO FIELD LENGTH (WITHOUT SECTIONS)
BLT T,-1(A) ;AND COPY ALL ENTRIES OVER.
;SET UP LOCAL PARAMETERS FOR PROCESSING REST OF THE FIELD
SETOM SAMEAS ;SET A FLAG
LOADC PRM,.SPARM ;SET UP PRM
LOADC A,.LENG
MOVEM A,MAXLEN ;AND LENGTH
LOADC A,.FILLR ;COPY THE FILLER
MOVEM A,FILLER
LOADC B,.LRANG
JUMPE B,CMSA20 ;WAS NO LOWER RANGE
SETZ C,
DPB C,T ;NO LOWER RANGE YET.
HRLI B,(POINT 7,0)
MOVE A,MAXLEN
MOVEM A,LNLWR
MOVE D,A
MOVE E,[POINT 7,NMLWR]
CALL MOVELJ ;MOVE IT.
TXO F,%SWLRN
CMSA20:
LOADC B,.URANG
JUMPE B,CMSA30 ;WAS NO UPPER RANGE
SETZ C,
DPB C,T ;NO UPPER RANGE YET.
HRLI B,(POINT 7,0)
MOVE A,MAXLEN
MOVEM A,LNUPR
MOVE D,A
MOVE E,[POINT 7,NMUPR]
CALL MOVELJ ;MOVE IT.
TXO F,%SWURN
CMSA30:
LOADC B,.VALUE
JUMPE B,CMSA40 ;WAS NO VALUE
SETZ C,
DPB C,T ;NO VALUE YET.
HRLI B,(POINT 7,0)
MOVE A,MAXLEN
MOVE D,A
MOVE E,[POINT 7,NMVAL]
CALL MOVELJ ;MOVE IT.
TXO F,%SWVAL
LOADC A,.NUMRD,A ;GET NUMBER OF REAL CHARS IN VALUE
MOVEM A,LNVAL ; AND SAVE IT.
CMSA40:
LOADC B,.TXTPT ;GET POINTER TO TEXT
JUMPE B,CMSA50 ;IF NO TEXT, THEN NOTHING TO MOVE.
SETZ C,
DPB C,T ;INSURE THIS IS ZERO NOW.
HRLI B,(POINT 7,0)
MOVE A,.TLENG ;GET LENGTH OF THE STRING
ADD A,FFLD
LDB A,A
MOVE D,A
MOVEM D,LNTVAL ;UPDATE LENGTH
MOVE E,[POINT 7,NMTVAL]
CALL MOVELJ ;MOVE IT.
IDPB C,E ;TERMINATE THE TEXT STRING
CMSA50: ;COPY HELP MESSAGE AND SUBTYPE
LOADC A,.TYPE ;COPY THE FIELD SUBTYPE
TXZE A,%LONGD ;IF LONG FORMAT
SETOM LONGDT ; THEN FLAG IT
MOVEM A,DATTYP ;IN CASE IT IS MONEY OR DATE
LOADC B,.HELP ;GET ADDRESS OF HELP TEXT
JUMPE B,CMSA60
SETZ C,
DPB C,T ;AND CLEAR IT
HRLI B,(POINT 7,0) ;MAKE A BYTE POINTER
LOADC A,.LNHLP ;GET LENGTH OF HELP TEXT
MOVE D,A
MOVEM A,LNHELP
MOVE E,[POINT 7,NMHELP]
CALL MOVELJ ;COPY THE STRING
TXO F,%SWHLP
CMSA60: ;MOVE THE SUBFIELD DESCRIPTOR AND SEPARATOR COUNT
LOADC B,.SFDES ;GET CURRENT VALUE
JUMPE B,CMSA70 ;IF NONE, THEN NO PROCESSING
SETZ C,
DPB C,T ;CLEAR THIS ADDRESS
CAIGE B,DD%LNG ;IF THIS IS ONE OF THE SPECIAL FIELDS
JRST [TXZ PRM,%SFDEF ; THEN DO NOT INDICATE AS SUBFIELD
CAIN B,DD.SSN-DD.CAN ; AND IF A SSN, THEN
TXO F,%MSSN ; BE SURE TO FLAG IT
CAIN B,DD.TM4-DD.CAN ;TIME ?
TXO F,%MTIM
CAIN B,DD.TM4-DD.CAN
TXO F,%MTIM
JRST CMSA70]
HRLI B,(POINT 9,0) ; STORAGE.
MOVE E,[POINT 9,NMSFD]
MOVEI A,TEXTLN
MOVE D,A ;MOVE TOTAL LENGTH
CALL MOVTNL ;MOVE TO NULL.
TXO F,%SWSFD ;INDICATE WE SAW ONE OF THESE
LOADC B,.SFSEP ;GET NUMBER OF SEPARATORS
SETZ C,
DPB C,T ;CLEARING CURRENT VALUE
MOVEM B,SFSEP
MOVE A,MAXLEN ;GET SIZE OF FIELD
MOVEM A,SFLEN ; AND UPDATE THIS COUNT TOO.
CMSA70:
SETZ C,
PUTBYT C,.OFFST ;CLEAR THE FIELD OFFSET
PUTBYT C,.FIELD ;CLEAR THE FIELD NAME
SETZM NUMREQ ;NOW HAVE ALL REQUIRED FIELDS ENTERED.
TXZ F,%SWFLD ;NO REQUIRED FIELDS LEFT
TXO F,%SWPOS+%SWLEN ;POSITION AND LENGTH SEEN
RET ;DONE.
FNDFLD: ;GIVEN A FIELD NAME, FIND ITS LOCATION IN THE
;TABLE OF ENTERED FIELDS AND RETURN LOCATION
;IN (D).
MOVE A,DATA ;BEGINNING ADDRESS
MOVEM A,FFLD
FIND10:
CAML A,CFLD ;PAST CURRENT FIELD ?
RET ;NOT HERE.
MOVE B,[ASCII/ /] ;5 BLANKS
MOVEM B,SAMNAM+8 ;CLEARED OUT
MOVE B,[SAMNAM+8,,SAMNAM+9]
BLT B,SAMNAM+^D15 ;BLANK OUT THE TARGET
MOVE B,.FIELD ;POINTER TO FIELD NAME
ADD B,FFLD ;CURRENT POSITION.
LDB B,B
HRLI B,(POINT 7,0) ; AND FORM BYTE POINTER
MOVEI A,^D30 ;LENGTH.
DMOVE D,[^D30
POINT 7,SAMNAM+8]
CALL MOVTNL ;MOVE TO NULL.
DMOVE A,[^D30
POINT 7,SAMNAM]
DMOVE D,[^D30
POINT 7,SAMNAM+8]
CALL XTCMP ;COMPARE STRINGS
JRST [AOS (P) ; THEY DO COMPARE EQUAL
RET]
MOVE A,FLDLEN ;PREPARE TO LOOK AT NEXT FIELD.
ADDB A,FFLD
JRST FIND10
CMSECT: ;MEMBER OF SECTION
MOVE T,CFLD ;GET ADRS OF FIRST WORD
ADD T,.SECTN
MOVEI A,CSB
MOVEI B,FDBN.C
COMND
ERCAL ERRPC
CKERR ;NOT-NUMERIC?
ERROR <Number required for SECTION command>,RET
HRLI C,0 ;ZERO LEFT HALF
CAIN C,FDBCFM ;CONFIRM
PJRST CMDLOG ;DONE
CAMG B,NUMSEC ;RANGE CHECK
CAIG B,0
ERROR <SECTION numbers must be in the range 1 to >,<MOVE B,NUMSEC
PJRST NOUTB>,X
AOS CSECT ;COUNT NUMBER OF SECTION SPECS
HRLM B,CSECT ;TEMP SAVE FOR MULTIPLE
MOVE T1,B ;COPY THE SECTION NUMBER
CALL SETSEC ;AND SET THE RIGHT BIT
JRST CMSECT
CMSIGN: ;ALLOW SIGN IN NUMERIC FIELDS
CALL CMDEND
MOVE A,PRM ;MAKE SURE THE FIELD IS NUMERIC
ANDI A,%ALPHA!%NUMER!%PUNCT
CAIE A,%NUMER
SKIPN A
SKIPA
WARN <Signed fields must be NUMERIC>,RET
TXO PRM,%SIGND ;OK TO SET IT
RET
CMSPC: ;ALLOW SPACES IN ALPHABETICS
CALL CMDEND
MOVE A,PRM
ANDI A,%CLASS
CAIN A,%NUMER
ERROR <SPACES command is invalid in numeric fields>,RET
TXO PRM,%SPACE
RET
CMSOCI: ;SOCIAL SECURITY NUMBER
CALL CMDEND
TXNN PRM,%TYPE+%SFDEF
TXNE F,%MTYPE
ERROR <Field type cannot be redefined>,RET
TXO F,%MSSN
MOVEI B,DATSSN-DATTBL ;USE OFFSET POINTER LATER
MOVEM B,DATTYP
LDB B,DATLNG ;FIELD LENGTH
CALL ICMLEN
CALL SETN
RET
CMTALL: ;TALL CHARACTERS
CALL CMDEND
TXO PRM,%TALL
RET
CMTATR: ;TEXT ATTRIBUTES
PUSH P,PRM ;SAVE FIELD PARAMETERS
SETZ PRM, ;AND CLEAR THEM
CALL VDOSET ;READ THE ATTRIBUTE BITS
ASH PRM,-^D27 ;MOVE DOWN A BIT
PUTBYT PRM,.TPARM ;SAVE THEM
POP P,PRM
CALL LOGTTY
RET
CMTPOS: ;TEXT POSITION
CALL GETPOS ;GET POSITION
CALL CMDEND
PUTBYT B,.TCOLM
PUTBYT ARG,.TLINE
RET
CMTVAL: ;TEXT STRING
CAIN CFLD,DEFFLD ;@DEFAULT FIELDS ?
ERROR <TEXT is not allowed in default fields>,RET
MOVEI A,CSB
MOVEI B,FDBQST ;STRING
COMND
ERCAL ERRPC
CKERR
ERROR <String required in TEXT-VALUE command>,RET
CALL CMDEND
SKIPN B,TXTPTR ;USE OLD POINTER IF NOT FIRST VALUE
JRST [MOVE B,[POINT 7,NMTVAL]
SETZM LNTVAL ;CLEAR LENGTH COUNTER
JRST CMTV1]
MOVEI A,15 ;INSERT <CR> AS A MARKER
DPB A,B
AOS LNTVAL ;COUNT THE MARKER
CMTV1:
CALL MOVATP ;MOVE STRING
ADDM D,LNTVAL ;SAVE LENGTH
MOVEM B,TXTPTR ;STORE FOR NEXT PASS
TXO PRM,%TEXT ;INDICATE TEXT IS HERE.
SKIPN D ;IF LENGTH IS ZERO
TXZ PRM,%TEXT ; THEN CLEAR TEXT FLAG.
RET
CMTIME: ;TIME FORMAT OF SUBFIELDS
TXNN PRM,%TYPE+%SFDEF
TXNE F,%MTYPE ;IF ALREADY KNOWN SUBFIELD TYPE
ERROR <Field type cannot be redefined>,RET
MOVEI A,CSB
MOVEI B,FDBN2C
COMND
ERCAL ERRPC
CKERR
ERROR <Number required in TIME command>,RET
HRLI C,0
CAIN C,FDBCFM ;WAS THERE A NUMBER
MOVEI B,4 ;NO - ASSUME HH:MM ONLY
CAIE B,4 ;ONLY 4 AND 6 ALLOWED
CAIN B,6
SKIPA
ERROR <Only 4 or 6 places allowed in TIME command>,RET
TXO F,%MTIM
MOVEI A,DATTIM-DATTBL ;SET UP THE OFFSET POINTER
CAIN B,6
AOS A ;TIME 6
MOVEM A,DATTYP
CALL ICMLEN
CALL ICMNUM
RET
CMUNDR: ;UNDERSCORE
CALL CMDEND
TXO PRM,%UNDR
RET
CMUPRR: ;UPPER RANGE
CAIN CFLD,DEFFLD ;AT DEF FLD
ERROR <UPPER-RANGE illegal in default fields>,RET
MOVEI A,CSB
MOVEI B,FDBQST ;STRING
COMND
ERCAL ERRPC
CKERR
ERROR <Value required for UPPER-RANGE>,RET
CALL CMDEND
TXO PRM,%RANGU ;SET U RANGE
TXOE F,%SWURN
WARN <UPPER-RANGE redefined>
MOVEI T,NMUPR
CALL MOVATM ;SAVE RANGE
MOVEM D,LNUPR ; AND LENGH
MOVEI T,UPRFLG
CALL CKCLAS ;CLASS CONFLICTS ?
TXNE F,%SWLEN
RET
MOVE B,D ;GET LENGTH OF ITEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
CMUPT: ;NOT PROTECTED
CALL CMDEND
TXZ PRM,%PROT
RET
CMUNSN: ;UNSIGNED
CALL CMDEND
TXZ PRM,%SIGND
RET
CMVALU: ;FIELD VALUE
CAIN CFLD,DEFFLD ;@DEFAULT FIELDS
ERROR <VALUE not allowed in default fields>,RET
MOVEI A,CSB
MOVEI B,FDBQST ;STRING
COMND
ERCAL ERRPC
CKERR
ERROR <Value required in VALUE command>,RET
CALL CMDEND
TXNE PRM,%DATE ;SPECIAL CHECK HERE
JRST DVALU ;FOR 'TODAY'
CMVAL1:
MOVEI T,NMVAL
CALL MOVATM ;MOVE STRING
MOVEM D,LNVAL ;SAVE LENGTH
TXOE F,%SWVAL
WARN <VALUE redefined>
MOVEI T,VALFLG
TXNE F,%SWLEN
JRST [CAMLE D,MAXLEN ;IF VALUE IS LARGER THAN FIELD LENGTH
MOVE D,MAXLEN ;THEN MAKE IT MAX LENGTH.
MOVEM D,LNVAL ;INSURE THIS IS SET UP RIGHT.
RET] ;RETURN
MOVE B,LNVAL ;GET LENGTH OF ITEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
DVALU: ;LOOK FOR DEFAULT DATE VALUE
MOVEI A,5 ;SET UP FOR COMPARE
MOVE B,[POINT 7,ATOM]
MOVEI D,5
MOVE T,[POINT 7,[ASCII /TODAY/]]
EXTEND A,[CMPSE
0
0]
JRST [MOVEI A,5 ;TRY AGAIN IN LOWER CASE
MOVE B,[POINT 7,ATOM]
MOVEI D,5
MOVE T,[POINT 7,[ASCII /today/]]
EXTEND A,[CMPSE
0
0]
JRST CMVAL1 ;NOT 'TODAY' SO NORMAL
JRST .+1] ;IT WAS LOWER CASE
TXO PRM,%DFDT ;SET FLAG FOR TFRCOB
TXZE F,%SWVAL ;NO VALUE REALY!!
WARN <DATE value now defaulted>
JRST CMPRVA ;FORCE PREV DUPE
CMVATR: ;SET THE VIDEO ATTRIBUTES FOR FIELD
CALL VDOSET ;GET THEM
CALL LOGTTY ;WRITE TO LOG FILE IF INPUT FROM TTY
RET
CMVERT: ;VERTICAL FIELD
CALL CMDEND
TXO PRM,%VERT+%PROT
RET
CMYN: ;YES-NO FIELD
CALL CMDEND
TXNN PRM,%TYPE+%SFDEF
TXNE F,%MTYPE ;MAKE SURE ITS NOT SSN
ERROR <Field type cannot be redefined>,RET
TXO PRM,%YN
MOVEI B,^D1
CALL ICMLEN
CALL SETA
RET
CMWIDE: ;WIDE FIELD
CALL CMDEND
TXO PRM,%WIDE
RET
CMZERO: ;REWRITE NUMERICS WITH ZERO FILL
CALL CMDEND
TXNE PRM,%ALPHA+%PUNCT
ERROR <LEADING-ZEROS command is invalid in alphabetic fields>,RET
TXO PRM,%ZERO
RET
SUBTTLE SERVICE ROUTINES FOR COMMAND FUNCTIONS
VDOSET:
MOVEI A,CSB
MOVEI B,FDBATR ;ATTRIBUTES
COMND
ERCAL ERRPC
CKERR
ERROR <Invalid video attribute>,RET
HRLI C,0 ;TEST FOR END OF LINE
CAIN C,FDBCFM
RET ;MERELY RETURN
HRRZ B,(B) ;GET VALUE FROM TABLE.
SKIPN B ;IF NORMAL VIDEO - CLEAR THE BITS
TXZ PRM,%RVRS+%BLNK+%BOLD+%UNDR+%GRAPH
TDO PRM,[0 ;SET THE BITS -
%RVRS ;REVERSE
%BLNK ;BLINKING
%UNDR ;UNDERSCORE
%BOLD ;BOLD
%WIDE ;WIDE
%TALL ;TALL
%VERT ;VERTICAL
%GRAPH](B) ;GRAPHIC
JRST VDOSET ;GET NEXT ATTRIBUTE
;THE FOLLOWING ROUTINES REPORT A NUMBER (LINE OR COLUMN)
ERMXCM:
MOVE B,MAXCOL ;REPORT MAX COLUMN
JRST NOUTB
ERMXLN:
WARN <Maximum line number is >,,X
ERMXL1:
MOVE B,MAXLIN
NOUTB:
MOVEI A,.PRIOU
MOVEI C,^D10
NOUT ;OUPUT THE NUMBER
ERCAL ERRPC
CALL CRLF
RET
;GETPOS GETS THE POSITION INFORMATION FOR THE "POSITION", "TEXT-POSITION" AND
;"BOX" COMMANDS. THE VALUES MAY BE PRECEDED BY A PLUS OR MINUS SIGN, THE
;RESULTING POSITION IS THEN CALCULATED FROM THE CURRENT BASE.
GETPOS:
SETZM OFSFLG ;CLEAR THE FLAG
MOVEI A,CSB
MOVEI B,FDBLIN
GTP.1:
COMND
ERCAL ERRPC
CKERR
ERROR <Line number required in POSITION commands>,RET
HRRZS C
CAIN C,FDBLIN ;WAS IT "+"
JRST [MOVEI C,1
MOVEM C,OFSFLG ;YES - SET A FLAG
JRST GTP.2]
CAIE C,FDBLN1 ;WAS IT "-"
JRST GTP.3 ; NO - MUST BE NUMBER
SETOM OFSFLG ;YES - FLAG IT
GTP.2:
MOVEI B,FDBLN2 ;NOW PARSE A NUMBER
JRST GTP.1
GTP.3:
SKIPGE OFSFLG ;IF "-"
MOVNS B ; THEN NEGATE THE NUMBER
SKIPE OFSFLG
ADD B,BASLIN ;ADD THE CURRENT BASE IF FLAG IS SET
CAMG B,MAXLIN ;RANGE CHECK
CAIG B,0
ERROR <Line number range in POSITION commands is 1 to >,<PJRST ERMXL1>,X
MOVE ARG,B ;SAVE LINE NUMBER
SKIPN OFSFLG ;IF FLAG NOT SET
MOVEM B,BASLIN ; THEN SAVE NEW BASE
;GET THE COLUMN NUMBER
SETZM OFSFLG ;CLEAR THE FLAG AGAIN
MOVEI B,FDBCOL
GTP.4:
COMND
ERCAL ERRPC
CKERR
ERROR <Column number required in POSITION commands>,RET
HRRZS C
CAIN C,FDBCOL ;WAS IT "+"
JRST [MOVEI C,1
MOVEM C,OFSFLG ;YES - SET A FLAG
JRST GTP.5]
CAIE C,FDBCL1 ;WAS IT "-"
JRST GTP.6 ;NO - MUST BE A NUMBER
SETOM OFSFLG ;SET A FLAG
GTP.5:
MOVEI B,FDBCL2 ;PARSE A NUMBER
JRST GTP.4
GTP.6:
SKIPGE OFSFLG ;IF "-"
MOVNS B ; THEN NEGATE THE NUMBER
SKIPE OFSFLG
ADD B,BASCOL ;ADD TO CURRENT BASE IF REQUIRED
CAMG B,MAXCOL
CAIG B,0
ERROR <Column number range in POSITON commands is 1 to >,<PJRST ERMXCM>,X
SKIPN OFSFLG ;IF FLAG NOT SET
MOVEM B,BASCOL ; THEN SET NEW BASE
RET
;SETSEC - SET A SECTION MASK BIT
;ON ENTRY - T HAS THE SECTION NUMBER
; T1 HAS THE ADDRESS OF THE FIRST WORD OF THE MASKS
;ON EXIT - RETURN TO .+1 IF THE SECTION NUMBER WAS TOO LARGE
; RETURN TO .+2 IF ALL OK
SETSEC: ;SET A SECTION BIT IN A MASK
CAMLE T1,NUMSEC ;IS IT A VALID SECTION NUMBER
RET ; NO
PUSH P,T1
PUSH P,T
IDIVI T1,^D36 ;YES - DIVIDE BY 36
SKIPE T2 ;IF WORD BOUNDARY
JRST SSC.1
MOVEI T2,^D36 ;THEN MAKE SURE IT IS IN THE
SOS T1 ;CORRECT WORD
SSC.1:
ADDI T,(T1) ;OFFSET THE POINTER
PUSH P,T1 ;SAVE FOR LATER
MOVEI T1,1 ;SET A BIT
LSH T1,-1(T2) ;MOVE THE BIT TO THE RIGHT PLACE
ORM T1,(T) ;AND SET IT
POP P,T ;GET BACK OFFSET
ORM T1,ALLSEC(T) ;FLAG IT IN ALLSEC
POP P,T
POP P,T1
RET
SUBTTLE POSTCK PROCESSING AFTER A FIELD (MAIN ROUTINE)
; THE INFORMATION FOR A FIELD IS KEPT IN TEMPORARY VARIABLES UNTIL
; THE END OF THE FIELD DEFINITION IS IDENTIFIED AND THEN IT IS
; MOVED INTO THE DATA AND STRING TABLE WHICH WILL ULTIMATELY BE
; OUTPUT AS THE BINARY FILE.
;
; THE END IF A FIELD IS IDENTIFIED BY THE BEGINNING OF THE NEXT
; FIELD.
POSTCK: ;POST-CHECK LAST FIELD
TXNN PRM,%CLASS ;IF FIELD TYPE NOT DEFINED
TXO PRM,%ALPHA+%NUMER+%PUNCT ; THEN SET TO ANY-CHARACTER
CALL PROCSF ;PROCESS SUBFIELDS
CALL POST00 ;COMPUTE RECORD OFFSET
CALL POST05 ;MOVE FIELD NAME
CALL POST10 ;MOVE LOWER RANGE
CALL POST15 ;MOVE UPPER RANGE
CALL POST20 ;MOVE THE VALUE STRING
CALL POST25 ;MOVE THE TEXT STRING AND LENGTH
CALL POST30 ;MOVE HELP STRING
CALL POST35 ;DO MULTIPLE SECTION WORK
CALL POST40 ;DO HIDDEN SECTION WORK
CALL POST50 ;UPDATE THE TOTAL SECTION TABLE
CALL POST60 ;DO MISCELLANEOUS DATA
RET ;ALL MOVEMENT DONE
SUBTTLE POSTCK ROUTINES POST00-POST30
POST00: ;COMPUTE THE FIELDS RECORD OFFSET
TXNE PRM,%MULT ;IF ALREADY MULTIPLE
JRST PST001 ; THEN DON'T CHECK IT HERE
HRRE T,CSECT ;GET SECTION COUNT
JUMPN T,PST001 ; IF NOT 0 (IE 1) THEN DON'T CHECK
HLRZ T,CSECT ;GET THE SECTION NUMBER
CAME T,MSECT ;IF SAME AS MULTIPLE SECTION NUMBER
JRST PST001
TXO PRM,%MULT ; THEN FIELD IS MULTIPLE
AOSLE MLTRN ;COUNT FIELDS
ERROR <Too many MULTIPLE fields - maximum is 16>
PST001:
MOVE T1,OFFSET ;GET CURRENT OFFSET
TXNE PRM,%MULT ;IF MULTIPLE FIELD THEN
MOVE T1,OFFSTA ;ALTERNATIVE
PUTBYT T1,.OFFST ;SAVE IT
MOVE T1,MAXLEN ;GET FIELD LENGTH
PUTBYT T1,.LENG ;SAVE FIELD LENGTH
SKIPE T1 ;IGNORE DEFAULT FIELD
SKIPN ALIGN ;IF WORD ALIGNED
JRST PST002
ADDI T1,5 ;THEN MAKE SURE IT IS ALIGNED
IDIVI T1,5
TXNE PRM,%MULT ;IF MULTIPLE THEN
ADDM T1,MULTX ;UPDATE THE MULTIPLE SECTION LENGTH
IMULI T1,5 ;MAKE BYTES AGAIN
PST002:
ADDM T1,OFFSET ;ADD TO TOTAL OFFSET
ADDM T1,OFFSTA ;UPDATE ALTERNATIVE
SETZM LONGDT ;RESET FOR NEXT FIELD
RET
POST05: ;MOVE FIELD NAME TO STRINGS TABLE
CAIN CFLD,DEFFLD ;IF DEFAULT FIELD DEFINITIONS
RET ; THEN NO NAME TO OUTPUT
MOVE B,.FIELD ;LOCATION FOR FIELD NAME POINTER
MOVEI C,NMFLD ;LOCATION OF FIELD NAME.
SETO A, ;MOVE TO NULL
CALL MOVSTR ;MOVE IT.
RET
POST10: ; MOVE LOWER RANGE (IF ANY)
TXNN F,%SWLRN ;LOWER RANGE ?
RET
MOVE B,.LRANG ;POINTER TO LOWER RANGE STRING ADDRESS.
MOVE A,LNLWR ;LENGTH OF LOWER RANGE STRING.
CAMLE A,MAXLEN ;IF LONGER THAN FIELD'S LENGTH
MOVE A,MAXLEN ; THEN TRIM IT.
MOVEI C,NMLWR ;ADDRESS OF STRING.
CALL MOVSTR ;MOVE IT.
RET
POST15: ; MOVE UPPER RANGE (IF ANY)
TXNN F,%SWURN ;UPPER RANGE ?
RET ;NO
MOVE B,.URANG ;POINTER TO ADDRESS LOCATION FOR STRING.
MOVE A,LNUPR ;LENGTH OF UPPER RANGE STRING.
CAMLE A,MAXLEN ;IF LONGER THAN FIELD' LENGTH
MOVE A,MAXLEN ; THEN TRIM IT.
MOVEI C,NMUPR ;ADDRESS OF UPPER RANGE STRING.
CALL MOVSTR ;MOVE IT.
RET
POST20: ;DO VALUE WORK
MOVEI T,1 ;ASSUME 1 COPY
TXNE PRM,%MULT ;UNLESS IT'S A MULTIPLE FIELD
MOVE T,MSLEN ;SET A COUNT
MOVEM T,TCOUNT ;=0 IF NOT MULTIPLE SECTION
MOVE T1,STRPTR ;NEXT STRING WILL GO HERE.
PUTBYT T1,.VALUE ;SAVE THE VALUE POINTER
PST201:
MOVEI B,NMVAL ;ADDRESS OF VALUE STRING
HRLI B,(POINT 7,) ; AND MAKE IT A BYTE POINTER
MOVE A,LNVAL ;SET UP THE LENGTH.
CAMLE A,MAXLEN ;IF LENGTH GREATER THAN FIELD LENGTH
MOVE A,MAXLEN ; THEN USE FIELD LENGTH
PUSH P,A ;SAVE VALUE FOR MOVE IN CASE OF CHANGE
TXNN PRM,%DFDT ;IF DEFAULT DATE THEN SET LENGTH
TXNE PRM,%NUMER ;IF THIS FIELD IS NUMERIC
MOVE A,MAXLEN ; THEN IT WILL GET MAX LENGTH TREATMENT
PUTBYT A,.NUMRD ;SAVE IT
POP P,A ;RESTORE VALUE FOR MOVE
CALL XTENDX ;MOVE THE STRING.
SOSLE TCOUNT ;CHECK IF DONE ALL
JRST PST201 ;NOT YET
RET
POST25: ;MOVE THE TEXT STRING AND LENGTH
TXNN PRM,%TEXT ; OR THIS FIELD HAS NO TEXT
RET ; THEN WE ARE DONE.
MOVE A,LNTVAL ;SET UP THE LENGTH.
PUTBYT A,.TLENG ;STORE THE LENGTH
MOVE B,.TXTPT ;GET THE POINTER
MOVEI C,NMTVAL ;ADDRESS OF TEXT STRING.
SETO A, ;MOVE TO NULL.
CALL MOVSTR ;DO IT.
SETZM LNTVAL ;CLEAR THE LENGTH ACCUMULATOR
SETZM TXTPTR ;CLEAR THE POINTER NOW
RET
POST30: ;COPY HELP STRING
TXNN F,%SWHLP ;DID WE SEE HELP TEXT
RET ;NO
MOVE A,LNHELP
PUTBYT A,.LNHLP
MOVE B,[POINT 7,NMHELP] ;POINT TO SOURCE
MOVE D,A
MOVE E,STRPTR ;DESTINATION
PUTBYT E,.HELP,T1
HRLI E,(POINT 7,0)
CALL MOVELJ ;MOVE THE STRING
CALL UPDSTR
RET
POST35: ;DO MULTIPLE SECTION WORK
TXNN PRM,%MULT ;CHECK FOR MULT FIELD
RET ;NO
MOVE T,MAXLEN ;FIELD LENGTH
ADD T,MSTOT ;WIDTH SO FAR
MOVEM T,MSTOT ;REPLACE IT
CAMLE T,MAXCOL ;TELL HIM IF ITS TOO BIG
WARN <Total MULTIPLE field widths exceed screen width>
SKIPE MSTOP ;GET TOP LINE INFO
JRST PST351
LOADC T1,.LINE
MOVEM T1,MSTOP ;SAVE IT
PST351:
MOVE T,MSTOP ;CHECK SIZES
ADD T,MSCNT
CAIL T,^D24
WARN <MULTIPLE section too long for screen>
HLRZ T,CSECT ;IF NO SECTION - TRY DEFAULT
JUMPE T,PST353
SKIPN T1,MSECT ;AS ABOVE
JRST PST352
CAME T,T1 ;MUST BE EQUAL OR ELSE
ERROR <Bad section specification for MULTIPLE field>,RET
PST352:
MOVEM T,MSECT ;SAVE IT ANYWAY
JRST PST354 ;CONTINUE WITH REMAINDER
PST353:
SKIPN T1,MSECT ;FAILS IF NONE SET
ERROR <No section information for MULTIPLE field>,RET
MOVE T,CFLD ;POINT TO THE SECTION MASK WORDS
ADD T,.SECTN
CALL SETSEC ;AND SET THE RIGHT BIT
PST354:
MOVE T1,MAXLEN ;GET FIELD LENGTH
SKIPN ALIGN
JRST PST355
ADDI T1,5 ;AND ROUND UP IF NECCESSARY
IDIVI T1,5
IMULI T1,5
PST355:
MOVE T,MSLEN ;NUMBER OF ELEMENTS
SOJ T, ;ALREADY ACCOUNTED FOR ONE
IMUL T,T1 ;TIMES SIZE
ADD T,OFFSET ;UPDATE TOTAL OFFSET
CAIL T,^D8192 ;BEWARE OF SIZE BEING TOO BIG
ERROR <Data area has exceeded 8K characters>,RET
MOVEM T,OFFSET ;SAVE IT
RET
POST40: ;DO HIDDEN SECTION WORK
TXNN PRM,%HIDE ;IF NOT HIDDEN -
RET ;THEN RETURN
MOVE A,HDNPTR ;POINT TO THE HIDDEN SECTION DATA
MOVE B,.SECTN ;POINT TO THE SECTION INFO
ADD B,CFLD ;UPDATE IT FOR THIS FIELD
PST401:
MOVE T,(B) ;COPY THE SECTION MASK
ORM T,(A) ;TO THE HIDDEN SECTION MASK
AOS B
AOBJN A,PST401
RET
POST50: ; UPDATE THE ALLSEC TABLE WITH THIS FIELD'S SECTION BITS.
MOVE A,CFLD ;COMPUTE THIS FIELD'S SECTION
ADD A,.SECTN ; WORD (FIRST) ADDRESS.
ADD A,NEWOST
MOVEI B,1 ;STARTING IN WORD ONE.
PST501: ;LOOP
MOVE Z,(A) ;GET THE NEXT WORD OF SECTION BITS
ORM Z,ALLSEC-1(B) ; AND UPDATE RESPECTIVE WORD IN
AOS B ; ALLSEC TABLE.
AOS A ;
CAILE B,WD%MSC ;IF ALL WORDS ARE DONE
RET ; THEN FINISHED
JRST PST501 ; ELSE DO NEXT WORD.
POST60: ;MISCELLANEOUS DATA
PUTBYT PRM,.SPARM ;SAVE PARAMETERS
SKIPN A,FILLER ;SAVE THE FILL CHARACTER
MOVEI A," " ; OR SPACE IF NOT SET
PUTBYT A,.FILLR
SETOM CSECT ;RESET SECTION COUNTER
RET
SUBTTL POSTCK ROUTINE FOR SUBFIELD PROCESSING
PROCSF: ;PROCESS SUBFIELDS (DATES, MONEY, SSN)
; EXPECTS PRM AND F TO BE SET CORRECTLY
CAIN CFLD,DEFFLD ;IF A DEFAULT
RET ; THEN NO POSSIBLE
TXNE PRM,%DATE ;IF FIELD IS A DATE
JRST PROC40 ; THEN PROCESS IT.
TXNE F,%MTIM ;IF TIME DESCRIPTOR
JRST PROC50 ; THEN PROCESS IT
TXNE PRM,%SFDEF ;IF DESCRIPTOR SET UP
JRST PROC90 ; THEN PROCESS IT
TXNE F,%MSSN ;IF FIELD IS A SOCIAL SECURITY NUMBER
JRST PROC80 ; THEN PROCESS IT.
TXNE PRM,%MONEY ;IF FIELD IS A MONEY FIELD
JRST PROC60 ; THEN PROCESS IT.
RET ;NOT A SPECIAL FIELD.
PROC40: ;PROCESS DATE SUBFIELDS
MOVEI A,%LONGD
SKIPE LONGDT ;IF LONG FORMAT DATE
ADDM A,DATTYP ; THEN FLAG IT FOR TFRCOB
CALL MOVDES ;COPY THE DESCRIPTOR
TXZ PRM,%YN+%SIGND+%RJUST ;CLEAR UNNECESSARY BITS
TXO PRM,%ZERO
RET ;ALL DONE
PROC50: ;PROCESS TIME FIELDS
;L=4, HH:MM
;L=6, HH:MM:SS
CALL MOVDES
TXZ PRM,%YN+%SIGND+%RJUST ;CLEAR UNNECESSARY BITS
TXO PRM,%ZERO
RET
PROC60: ;PROCESS MONEY FIELDS
;L=2, D=2 .99
;L=3, D=2 9.99 OR -.99
;L=4, D=2 -9.99
;L=5, D=2 --9.99
MOVE T1,[POINT 9,NMSFD] ;BUILD A POINTER TO THE SUBFIELD
MOVE T2,MAXLEN ;LENGTH OF FIELD
LOADC T3,.TYPE,E ;ISOLATE NUMBER OF DECIMAL POINTS.
SUB T2,T3 ;AND COMPUTE NUMBER OF INTEGERS
CAMLE T2,1 ;IF NOT MORE THAN ONE INTEGER DIGIT
JRST PROC62 ; THEN SKIP THIS PART
ORI T2,%SFLEN ;FLAG AS LENGTH BYTE
IDPB T2,T1 ;STORE IN DESCRIPTOR
MOVEI T4,%T.DIG ;INDICATE BLANKABLE HIGH ORDER DIGITS
TXNE PRM,%ZERO ;IF ZERO FILL,
MOVEI T4,%T.ZER ; THEN INDICATE THAT
IDPB T4,T1 ;STORE TYPE IN DESCRIPTOR
PROC62:
MOVEI T4,"."+%SFSEP ;PUT A SEPARATOR IN
IDPB T4,T1 ; INTO THE STRING.
JUMPLE T3,PROC65 ;JUMP IF NO DECIMAL PLACES
ORI T3,%SFLEN ;THIS IS THE LENGTH
IDPB T3,T1 ;PUT IN LENGTH
MOVEI T4,%T.ZER ; AND
IDPB T4,T1 ; FIELD TYPE
PROC65:
MOVEI T1,5 ;SET THE NUMBER OF BYTES
MOVEM T1,SFCNT
MOVEI T1,1
MOVEM T1,SFSEP ;SET NUMBER OF SEPARATORS
JRST PROC90
PROC80: ;SOCIAL SECURITY NUMBER
CALL MOVDES ;COPY THE DESCRIPTOR
TXO PRM,%RJUST
TXZ PRM,%SIGND
RET
PROC90: ;PROCESS SUBFIELDS
MOVE E,STRPTR
HRLI E,(POINT 9,) ;MAKE IT A 9-BIT POINTER
PUTBYT E,.SFDES,T1 ;SAVE ADDRESS OF DESCRIPTOR
MOVE B,[POINT 9,NMSFD] ;POINT AT STRING.
MOVE A,SFCNT ;GET THE NUMBER OF BYTES
MOVE D,A
CALL MOVLJZ ;MOVE LEFT JUSTIFIED AND STORE NULL.
CALL UPDSTR ;UPDATE THE STRPTR REFERENCE.
MOVE T1,SFSEP ;GET THE NUMBER OF SEPARATORS
PUTBYT T1,.SFSEP,T2
TXO PRM,%SFDEF ; INDICATE SUBFIELD
RET
SUBTTL FINAL PROCESSING OF DATA FILE BEFORE OUTPUT
DATOUT: ;MAP OUTPUT PAGES
SKIPE CURFLD ;IF NO FIELDS, OR,
TXNN F,%SWOUT ; IF NO OUTPUT COMMAND?
RET ; NO
SETZM MULTSC ;CLEAR IT ANYWAY
SKIPN T,MSECT ;DO IT IF THERE IS ONE
JRST NOML ;- THERE ISNT
DPB T,.MLSEC ;SAVE SECTION NO.
MOVE T,MLTRN ;NUMBER OF FIELDS
ADDI T,^D15 ;RANGE IS 0-15
DPB T,.MLFCT ;STORE IT
TXNN F,%SWIDX ;MUST HAVE INDEX FIELD BY NOW
ERROR <No INDEX field found in MULTIPLE section>,RET
MOVE T,MSLEN ;NO. OF ELEMENTS
DPB T,.MLTRC
MOVE T,MSCNT ;DISPLAYED FIELDS
DPB T,.MLTDC
MOVE T,MSTOP ;TOP LINE NO.
DPB T,.MLLOR ;LOWEST LINE NO.!!!
ADD T,MSCNT ;LAST+1
SOJ T, ;LAST LINE
DPB T,.MLHIR ;HIGHEST LINE NO.!!!
NOML:
MOVE B,NUMSEC ;SAVE THE NUMBER OF SECTIONS
DPB B,.MXSEC
MOVE B,FRMLEN ;SAVE THE SIZE OF THE HEADER DATA
DPB B,.HDSIZ
MOVE B,FLDLEN ;AVE THE LENGTH OF FIELD DATA
DPB B,.FDSIZ
MOVE T,CHRSET ;GET CHAR SET
DPB T,.CSET ;SAVE IT
MOVE T,FATTR ;STORE THE FORM ATTRIBUTES
DPB T,.FPARM
MOVE T,EATTR ;AND THE ERROR LINE ATTRIBUTES
DPB T,.EPARM
MOVE T,MAXLIN ;SAVE THE MAXIMUM LINE NUMBER
DPB T,.MAXLN
MOVE T,MAXCOL ;AND THE MAXIMUM COLUMN NUMBER
DPB T,.MAXCL
MOVE T,ERRLIN ;SAVE THE ERROR LINE NUMBER
DPB T,.ERRLN
SKIPN T,TERMS
MOVEI T,-1 ;DEFAULT TO ALL
DPB T,.TERMS ;STORE THE TERMINALS ALLOWED
MOVEI A,DECVER ;TFR VERSION NUMBER
DPB A,.VERSN
MOVEI C,NMFORM ;LOCATION OF FORM NAME
MOVE B,.FORMN ;ADDRESS OF POINTER.
SETZM CFLD ;NO OFFSET--A FORM FIELD
SETO A, ;MOVE TO NULL AND ADJUST
CALL MOVSTR ;MOVE IT.
SKIPG A,CURFLD ;ANY FIELDS?
RET ;NONE
DPB A,.NMFLD ;SAVE IN HEADER WORD
MOVE A,OUTJFN ;OPEN FILE
MOVE B,[^D36B5+OF%WR] ;WRITE ACCESS, 36 BIT BYTES
OPENF
ERJMP [CALL ERR
RET] ;GIVE UP ON ERROR
MOVE C,CURFLD ;NUMBER OF FIELDS
IMUL C,FLDLEN ;#WORDS USED
ADD C,DATA ; PLUS HEADER WORDS
DPB C,.STRPT ;SAVE AS OFFSET TO STRINGS
PUSH P,C ;SAVE FOR CLEAR
SUBI C,HDRWRD ;MINUS OFFSET
MOVNS C ;WORD COUNT
MOVE B,[POINT 36,HDRWRD] ;POINT TO THE DATA
SOUT ;WRITE THE DATA AREA
ERCAL ERRPC
HRR C,STRPTR ;LAST STRING ADDRESS
PUSH P,C ;SAVE FOR CLEAR
SUBI C,STRING ;WORD COUNT
MOVNS C
MOVE B,[POINT 36,STRING] ;POINT TO THE STRING DATA
SOUT ;AND WRITE IT
ERCAL ERRPC
HRRI A,STRING+1 ;CLEAR STRING ARE FOR NEXT RUN
HRLI A,STRING
POP P,C
SETZM STRING
BLT A,-1(C)
HRRI A,HDRWRD+1 ;CLEAR DATA ARE FOR NEXT RUN
HRLI A,HDRWRD
POP P,C
SETZM HDRWRD
BLT A,-1(C)
RET
LOGTTY: ;LOG CMD ON TTY
PUSH P,T ;SAVE THIS JUST IN CASE
MOVE T,[POINT 7,TEXTBF] ;TO TEMP BUFFER
CALL MOVCMD
MOVE A,LOGJFN
HRROI B,TEXTBF
MOVEI C,TEXTLN ;TEXTBF LENGTH
MOVEI D,12 ;END ON <LF>
SOUT
ERCAL ERRPC ;NOTE ERRORS
POP P,T
RET
CMDEND: ;LOG CMD IF TTY
PUSH P,B ;SAVE COMND DATA
MOVEI A,CSB
MOVEI B,FDBCFM ;CONFIRM
COMND
ERCAL ERRPC
CKERR ;JUST IN CASE
ERROR <Not confirmed>,<JRST .+1>
CAIA
CMDLOG:
PUSH P,B
TXNE F,%TTYIN
CALL LOGTTY ;LOG CMD IF TTY
POP P,B ;RESTORE COMND DATA
RET
SUBTTL MOVSTR -- MOVES STRINGS TO THE FORM STRING AREA
MOVSTR:
;CALLED WITH:
; A = LENGTH OF STRING OR -1 TO STOP ON NULL.
; B = PROTOTYPE BYTE POINTER FOR STRING ADDRESS ENTRY IN FORM.
; C = ADDRESS OF THE FROM FIELD
PUSH P,D ;SAVE SOME REGISTERS
PUSH P,E
PUSH P,T1
MOVE E,STRPTR ;NEXT LOCATION IN STRING AREA.
ADD B,CFLD ;ADD FIELD ADDRESS TO PROTOTYPE POINTER.
DPB E,B ;STORE ADDRESS OF LOCATION IN STRING.
MOVE B,C ;BUILD A BYTE POINTER TO
HRLI B,(POINT 7,) ; TO THE FROM FIELD.
HRLI E,(POINT 7,) ;BUILD POINTER TO STRING AREA.
MOVEI T1,MVS.1 ;ASSUME MOVE SPECIFIED LENGTH
SKIPGE A ;IF MOVING TO NULL,
MOVEI T1,MOVTNL ; THEN MOVE UNTIL NULL FOUND
CALL (T1) ;EXECUTE THE TASK.
SETZ T1, ;END WITH NULL BYTE IN THE STRING
IDPB T1,E
CALL UPDSTR ;UPDATE THE STRPTR REFERENCE.
POP P,T1
POP P,E
POP P,D
RET
MVS.1: ;MOVE STRING OF LENGTH SPECIFIED IN AC-A
LOADC D,.LENG,D ;GET LENGTH OF ACTUAL FIELD
MOVEI T1,MOVELJ ;ASSUME A LEFT JUSTIFIED MOVE
TXNN PRM,%RJUST ; AND IF A RIGHT JUSTIFIED FIELD
TXNN PRM,%ALPHA!%PUNCT ; (OR NUMERIC)
MOVEI T1,MVS.2 ; USE RIGHT JUSTIFIED ROUTINE.
CALL (T1) ;EXECUTE THE ROUTINE
RET
MVS.2: ;MOVE THE STRING INTO A RIGHT JUSTIFIED POSITION.
SKIPE A ;IF ZERO LENGTH INPUT FIELD
TXNN PRM,%SIGND ;OR IF UNSIGNED
JRST MVS.3 ; THEN NO SIGNS TO WORK WITH.
MOVE C,B ;ELSE MAKE SURE SIGN IS IN
ILDB Z,C ; MOST SIGNIFICANT POSITION
CAIE Z,"-" ;IF IT IS MINUS
CAIN Z,"+" ; OR PLUS,
JRST [IBP B ; THEN PUT SIGN IN
CAIN Z,"+" ; POSITION UNLESS +
MOVEI Z,"0" ; (USE ZERO).
IDPB Z,E
SOJ D, ; INDICATING 1 LESS DIGIT.
SOJA A,.+1]
MVS.3:
EXTEND A,[MOVSRJ ;DO RIGHT JUSTIFIED MOVE OF FIELD.
"0"] ;USE 0 FILL.
JFCL
RET
MOVELJ: ;DO A LEFT JUSTIFIED MOVE
;THE AC'S ARE SET FOR THE MOVSLJ INSTRUCTION
EXTEND A,[MOVSLJ
" "] ;USE SPACE AS FILL.
JFCL
RET
MOVLJZ: ;DO A LEFT JUSTIFIED MOVE AND FOLLOW WITH NULL BYTE.
CALL MOVELJ
SETZ Z,
IDPB Z,E
RET
MOVTNL: ;MOVE STRING CHARACTER BY CHARACTER UNTIL NUL SEEN.
ILDB Z,B ;GET NEXT CHARACTER
SKIPN Z ;IF IT IS A NULL,
RET ; THEN DONE.
IDPB Z,E ;ELSE
JRST MOVTNL ; KEEP GOING.
;ON RETURN A IDPB Z,E WILL PLACE NULL AT END OF STRING.
XTCMP: ;COMPARE TWO STRINGS
EXTEND A,[CMPSE
" "
" "]
AOS (P) ;NO COMPARISON -- SKIP RETURN
RET
UPDSTR:
AOS E ;ADVANCE TO
MOVEM E,STRPTR ; THE NEXT WORD
RET
MOVDES: ;MOVE A 9-BIT DESCRIPTOR
MOVE B,DATTYP ;GET THE OFFSET POINTER
PUTBYT B,.TYPE,T2 ;SAVE IT FOR TFRCOB
TXZ B,%LONGD ;LOSE THE LONG BIT
LDB A,DATLEN ;GET NUMBER OF BYTES
MOVEI D,(A) ;ALLOW SOME ROOM
LDB E,DATSEP ;GET NUMBER OF SEPARATORS
PUTBYT E,.SFSEP,T2
LDB B,DATDES ;POINT TO DESCRIPTOR
HRLI B,(POINT 9,0)
MOVE E,STRPTR ;POINT TO DESCRIPTOR STRING
PUTBYT E,.SFDES,T2 ;BUILD THE DESCRIPTOR
HRLI E,(POINT 9,0)
CALL MOVLJZ ;COPY WITH TRAILING NULL
CALL UPDSTR
TXO PRM,%SFDEF ;INDICATE SUBFIELDS
RET
SUBTTL XTENDX - EXTEND A RANGE FIELD AND FILL WITH RIGHT THING
XTENDX:
LOADC D,.LENG ;GET FIELD LENGTH
MOVE T,STRPTR ;STRING PTR
HRLI T,(POINT 7,0)
TXNN PRM,%ALPHA!%PUNCT ;IF ALPHA
TXNN PRM,%NUMER ; OR NOT NUMERIC ?
JRST XTENDA ; THEN DO ALPHA WORK
TXNN PRM,%DATE ;IF DATE OR SSN THEN
TXNE F,%MSSN
JRST XTENDE ; THEN MOVE WHOLE FIELD.
MOVE C,B ; ELSE MAKE SURE SIGN IS IN
ILDB Z,C ; FIRST POSITION.
CAIE Z,"-" ;IF FIRST DIGIT IS A MINUS
CAIN Z,"+" ; OR A PLUS
JRST [IBP B ; THEN INCREMENT THE BYTE POINTER
CAIN Z,"+" ; IF THIS IS A PLUS
MOVEI Z,"0" ; THEN MAKE IT A 0
IDPB Z,E ; DEPOSIT IT IN THE FIRST POSITION.
SOJ D, ; INDICATE MOVE 1 CHARACTER LESS
SOJA A,.+1] ; AND JUMP BACK IN LINE.
XTENDE:
EXTEND A,[MOVSRJ
"0"] ;RIGHT JUSTIFY, ZERO FILL
JFCL
JRST XTENDC ;GO TO COMMON STUFF
XTENDA:
EXTEND A,[MOVSLJ
" "] ;LEFT JUST., SPACE FILL
JFCL
XTENDC: ;COMMON CLEAN-UP
MOVE B,T ;GET FINAL PTR
CALL NULBYT ;PUT A NULL BYTE
CALL ADJB ;ADJUST STRPTR PTR
RET ;AND RETURN
SUBTTL PARSE A COBOL VARIABLE NAME
;THIS ROUTINE READS IN AND VERIFIES A VARIABLE NAME. TO BE VALID,
;IT MUST CONSIST OF ONLY "A".."Z", "0".."9", OR, IF IT IS A COBOL NAME, "-".
;IT MUST NOT BEGIN OR END WITH "-", MUST NOT CONSIST OF JUST DIGITS,
;AND MUST BE AT MOST 30 CHARACTERS LONG FOR COBOL, 6 FOR FORTRAN, OR 5 FOR MACRO.
;THIS IS DONE BY KEEPING SEVERAL STATUS BITS AND COUNTS WHILE ADVANCING THROUGH
;THE STRING AFTER IT IS READ IN BY COMND. LEADING AND TRAILING SPACES OR TABS
;IGNORED, AND LOWER CASE IS CONVERTED TO UPPER CASE. HOWEVER, COMMENTS ACT HERE
;AS TERMINATORS, SO "!COMMENT! NAME" IS ILLEGAL.
;
;FLAGS IN D:
; 1B0 LAST CHARACTER WAS "-"
; 1B1 WE'VE SEEN A LEGAL NON-DIGIT
; RH COUNT OF CHARACTERS SEEN IN ID
;
;ON ENTRY, A AND B MUST CONTAIN COMND JSYS ARGUMENTS FOR THE .CMTXT FUNCTION.
;THIS ALLOWS THE CALLER TO FILL IN A DEFAULT NAME.
CMCOB: COMND ;READ IN THE TEXT LINE
ERCAL ERRPC ;GO PRINT WHICH ERROR CAUSED THIS
MOVE B,[POINT 7,ATOM] ;BEGIN SCANNING AT THE STRING
MOVX C,<-ATOMLN,,0> ;MAKING SURE NOT TO GO TOO FAR
SETZ D, ;CLEAR FLAGS AND COUNT OF GOOD CHARS
CMCOB1: ILDB T,B ;READ NEXT CHARACTER
CAIL T,"a" ;CHECK FOR LEGAL LOWER CASE
CAILE T,"z" ;..
JRST .+2 ;NOT--CHECK FURTHER
JRST [SUBI T,"a"-"A" ;YES--CONVERT TO UPPER CASE
DPB T,B ;AND STORE BACK
TXZ D,1B0 ;LAST CHAR NOT "-"
TXO D,1B1 ;LEGAL NON-DIGIT, LEGAL CHAR
ADDI D,1 ;COUNT TOWARD MAX
JRST CMCOB2] ;CONTINUE LOOPING FOR CHARS
CAIL T,"A" ;CHECK FOR LEGAL UPPER CASE
CAILE T,"Z" ;..
JRST .+2 ;NOT--CHECK FURTHER
JRST [TXZ D,1B0 ;YES--LAST CHAR NOT "-"
TXO D,1B1 ;LEGAL NON-DIGIT, LEGAL CHAR
ADDI D,1 ;COUNT TOWARD MAX
JRST CMCOB2] ;CONTINUE LOOPING FOR CHARS
CAIL T,"0" ;CHECK FOR LEGAL DIGIT
CAILE T,"9" ;..
JRST .+2 ;NOT--CHECK FURTHER
JRST [TXZ D,1B0 ;YES--LAST CHAR NOT "-"
CALL CMCOB4 ;CHECK FOR LEADING DIGIT
JRST CMCER3 ;YES - ERROR IN MACRO OR FORTRAN
ADDI D,1 ;COUNT TOWARD MAX
JRST CMCOB2] ;CONTINUE LOOPING FOR CHARS
CAIN T,"-" ;CHECK FOR HYPHEN
JRST [TXNN D,777777 ;YES--CHECK FOR FIRST CHAR OF ID
JRST CMCER1 ;FIRST CHAR--ID IS BAD
TXO D,1B0!1B1 ;LAST CHAR WAS "-", LEGAL NON-DIGIT
ADDI D,1 ;COUNT TOWARD MAX
JRST CMCOB2] ;CONTINUE LOOPING FOR CHARS
CAIE T," " ;CHECK FOR SPACES AND TABS
CAIN T," " ;..
JRST [TXNE D,777777 ;YES--ID SEEN YET?
JRST CMCOB3 ;YES - CHECK RESULTS
JRST CMCOB2] ;NO--SKIP THESE 'TIL WE HIT THE ID
CAIE T,"!" ;NOW CHECK FOR VALID TERMINATORS
CAIN T,";" ;..
JRST CMCOB3 ;AND GO CHECK RESULTS IF SO
JUMPE T,CMCOB3 ;..
JRST CMCER2 ;ALL THE REST IS JUNK
CMCOB2: AOBJN C,CMCOB1 ;LOOP FOR NEXT CHAR 'TIL NO MORE
IBP B
CMCOB3:
SETZ T,
DPB T,B
TXNE D,1B0 ;ID ENDED WITH "-"?
ERROR <COBOL variable may not end with '-'.>,RET
TXNN D,1B1 ;ALL DIGITS?
ERROR <Variable may not contain all digits.>,RET
TXNN D,777777 ;ANYTHING AT ALL?!
ERROR <No variable name specified.>,RET
MOVEI D,(D) ;NOW GET COUNT OF CHARACTERS IN ID
GOTYPE CM3.1,CM3.2,CM3.3
CM3.1:
CAILE D,^D27 ;MAXIMUM COBOL NAME LENGTH IS 27
ERROR <COBOL variable may not be longer than 27 characters.>,RET
JRST CM3.4
CM3.2:
CAILE D,^D6 ;MAXIMUM FORTRAN NAME LENGTH IS 6
ERROR <FORTRAN variable may not be longer than 6 characters.>,RET
JRST CM3.4
CM3.3:
CAILE D,^D5 ;MAXIMUM MACRO NAME LENGTH IS 5
ERROR <MACRO variable may not be longer than 5 characters.>,RET
CM3.4:
AOS (P) ;AT LAST! A GOOD IDENTIFIER!
RET ;SO GIVE SKIP RETURN
CMCOB4:
GOTYPE CM4.1,CM4.2,CM4.2 ;SEE IF LEADING DIGIT IS LEGAL
CM4.2:
TRNE D,777777
CM4.1:
AOS (P)
RET
CMCER1: ERROR <COBOL variable may not begin with '-'.>,RET
CMCER2: ERROR <COBOL variable may contain only letters, digits, or '-'.>,RET
CMCER3: ERROR <Illegal MACRO or FORTRAN name>,RET
SUBTTL MORE COMMAND ROUTINES
SETA: ;SET ALPHABETIC
CALL ICMALP
JRST SETDV ;LOOK FOR DEFAULT
SETN: ;SET NUMERIC ATTRIB
CALL ICMNUM
JRST SETDV ;LOOK FOR DEFAULT
SETAN: ;SET ALPHA-NUMER
CALL ICMAN
SETDV: ;CHECK FOR DEFAULT DATE
MOVEI B,NMVAL ;POINT TO VALUE
HRLI B,(POINT 7,0)
MOVE A,LNVAL ;LENGTH FOR COMPARE
MOVEI D,5
MOVE T,[POINT 7,[ASCII /TODAY/]]
EXTEND A,[CMPSE
0
0]
JRST [MOVEI B,NMVAL ;TRY IT AGAIN IN LOWER CASE
HRLI B,(POINT 7,0)
MOVE A,LNVAL
MOVEI D,5
MOVE T,[POINT 7,[ASCII /today/]]
EXTEND A,[CMPSE
0
0]
JRST CKSTNG ;NOT THE SAME
JRST .+1] ;IT WAS LOWER CASE
TXO PRM,%DFDT
TXZ F,%SWVAL
MOVE T,[ASCII / /]
MOVEM T,NMVAL
MOVEM T,NMVAL+1
MOVE T,MAXLEN
MOVEM T,LNVAL
JRST CMPRVA
TELLEN:
TXNN F,%TTYIN
JRST TELL.1
PUSH P,B ;SAVE NUMBER
MOVEI A,.PRIOU
HRROI B,[ASCIZ /Length set to /]
MOVNI C,^D15
SOUT
ERCAL ERRPC
POP P,B ;GET NUMBER
NUMBR
PUSH P,B ;AGAIN
MOVEI A,.PRIOU
HRROI B,[ASCIZ /
/]
MOVNI C,3
SOUT
ERCAL ERRPC
POP P,B
TELL.1:
RET
ADJB: ;ADJUST PTR IN 'B'
TLZ B,770000 ;SET BYTES LEFT TO 0
TLO B,440000
AOJ B, ;ALL NEXT WORD IS AVAIL
MOVEM B,STRPTR
RET
RELJFN: ;RELEASE JFN IN 'HLDJFN'
MOVE A,HLDJFN ;PUT IN RIGHT PLACE
RLJFN
ERCAL ERRPC
RET
XTENDN: ;EXTEND WITH NULLS
SETZ T,
XTEND: ;EXTEND A FIELD WITH VALUE IN T
JUMPE C,XTEND0 ;XTEND FOR 1 BYTE MAXIMUM
DPB T,B ;DPB TERMINATOR (NULL)
XTENDL:
IDPB T,B ;LOOP (C) TIMES
SOJG C,XTENDL
JRST NULBYT ;END WITH A NULL BYTE
XTEND0:
SETZ T1, ;GET TERM CHARACTER
LDB T1,B
SKIPN T1 ;SKIP IF NOT NULL
DPB T,B
NULBYT: ;OUTPUT LAST NULL BYTE
SETZ T,
IDPB T,B
RET
DCRRQD: ;DECREMENT NUMBER OF REQUIRED FIELDS
SOSN NUMREQ ;ONE LESS REQIRED
TXZ F,%SWFLD ;NO MORE LEFT
RET ;DONE
; CHECK INPUT VALUES FOR CONFLICTS WITH EXISTING CLASS DEFINITIONS.
CKCLAS: ;STRING VALUE -- DOES IT CONFLICT WITH CLASS
SETZ T1, ;INITIALIZE BIT COLLECTOR
MOVE T1,F ;COPY THE RELEVANT BITS
ANDI T1,%CLASS!%SIGND
MOVEM T1,@T ;STORE TRANSLATED BITS FOR CALLER
MOVE T2,PRM ;ISOLATE CURRENT CLASS BITS
ANDX T2,%CLASS
JUMPE T2,[TDO PRM,T1 ;IF NO ATTRIBUTE SET YET, THEN
RET] ; DEFAULT TO VALUE ATTRIBUTES
ANDX T1,%CLASS ;ONLY COMPARE CLASS BITS
OR T1,T2 ;SEE IF THIS IS A SUBSET OF THE
CAMN T2,T1 ;FIELDS CHARACTER SET
RET ; THEN ALL IS OK.
CAIN T2,%CLASS ;IF ALL CHARACTERS OK
RET ; THEN NO PROBLEM EITHER
ERROR <Some characters illegal for field's defined class>,RET
CKSTNG: ;NEW CLASS--DOES IT CONFLICT WITH ANY STRINGS
MOVE T1,PRM ;ISOLATE THE CURRENT CLASS BITS
ANDX T1,%CLASS
CAIN T1,%CLASS ;IF ALL CHARACTERS ARE LEGAL
RET ; THEN NO CONFLICT
JUMPE T1,[ERROR <No data class set - internal error>,RET]
TXNN F,%SWVAL ;IF NO VALUE FIELD YET
JRST CKST10 ; THEN BYPASS.
MOVE T2,VALFLG ;GET TYPE OF CHARACTERS IN VALUE
OR T2,T1 ; AND SEE IF A SUBSET
CAME T1,T2 ; BY THIS METHOD
ERROR <Value contains characters which do not match field's class>,RET
CKST10:
TXNN F,%SWLRN ;IF NO LOWER RANGE YET
JRST CKST20 ; THEN BYPASS.
MOVE T2,LWRFLG ;GET TYPE OF CHARACTERS IN LOWER RANGE
OR T2,T1 ; AND SEE IF A SUBSET
CAME T1,T2 ; BY THIS METHOD
ERROR <Lower range contains characters which do not match field's class>,RET
CKST20:
TXNN F,%SWURN ;IF NO UPPER RANGE
RET ;THEN BYPASS
MOVE T2,UPRFLG ;GET TYPE OF CHARACTERS IN UPPER RANGE
OR T2,T1 ; AND SEE IF A SUBSET
CAME T1,T2 ; BY THIS METHOD
ERROR <Upper range contains characters which do not match field's class>,RET
RET
SUBTTL CREATE RECORD DESCRIPTION FILE
SALL
PUTREC: ;RECORD DESCRIPTION
SETZM ERRFLG ;CLEAR ERROR FLAG
SKIPE CURFLD ;IF NO FIELDS, OR,
TXNN F,%SWREC ; IF NO RECORD FILE
RET ; THEN RETURN
MOVE A,RECTYP ;GET RECORD TYPE
MOVE A,[30 ;GET MAX LENGTH OF FORM NAME - DEFAULT
30 ;COBOL
6 ;FORTRAN
5](A) ;MACRO
MOVE B,[POINT 7,NMFORM] ;COPY THE FORM NAME SO THAT WE DONT
MOVE D,A ; UPSET MACRO OR FORTRAN
MOVE T,[POINT 7,TEXTBF]
EXTEND A,[MOVSLJ
0]
JFCL
SETZ A, ;END ON NULL
IDPB A,T
REMARK SETUP FILE
MOVE A,RECJFN
MOVE B,[OF%WR+7B5]
OPENF
JERROR <RECORD-DESCRIPTION-FILE will not be created>,<JRST ERRFIL>
REMARK MAKE A HEADING
GOTYPE PR.CBL,PR.FOR,PR.MAC
PR.CBL:
FMSG RECJFN,<************************************************************>,,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* RECORD DESCRIPTION OF FORM: >,NMFORM,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* SPECIFICATION FILE: >,NMSPEC,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* DATE OF COMPILATION: >,DAYTIM,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<************************************************************>,,,CR
FMSG RECJFN,<01 FM->,NMFORM
FMSG RECJFN,< USAGE IS DISPLAY-7.>,,,CR
REMARK SET UP TO DO EACH FIELD
SETZB ARG,T
MOVE T2,DATA
MOVEM F,TEMP ;SAVE FLAGS FOR LATER
SETZ F, ;SET OUR OWN FLAG
REMARK DO THE FIELD BY FIELD STUFF
CBLLUP:
CAML ARG,CURFLD ;DONE YET
JRST CBLFNM ;OUTPUT THE FIELD NUMBERS
CALL FIELD ;GET FIELD INFO
TXNN PRM,%MULT
JRST CBLL.2
JUMPN F,CBLL.1 ;DONE HEADER?
AOJ F, ;NO - DO IT NOW
FMSG RECJFN,< 10 MULTIPLE-RECORD OCCURS >
NUMBR RECJFN,MSLEN
FMSG RECJFN,< TIMES.>,,,CR
CBLL.1:
FMSG RECJFN,< 12 >,T
JRST CBLL.3
CBLL.2:
FMSG RECJFN,< 10 >,T
CBLL.3:
CALL CBLPIC ;DO PICTURE
SKIPN ALIGN ;ARE WE WORD ALIGNED?
JRST CBLL.6
LOAD T,.LENG ;GET FIELD LENGTH
MOVE B,T
ADDI T,5
IDIVI T,5 ;CONVERT TO WORDS
IMULI T,5 ;BACK TO BYTES
SUB T,B ;AND KEEP THE DIFFERENCE
JUMPE T,CBLL.6 ;NOTHING TO DO
TXNN PRM,%MULT ;IS IT A MULTIPLE FIELD?
JRST CBLL.4 ;NO
FMSG RECJFN,< 12 >
JRST CBLL.5
CBLL.4:
FMSG RECJFN,< 10 >
CBLL.5:
FMSG RECJFN,<FILLER
PICTURE X(>
NUMBR RECJFN,T
FMSG RECJFN,<).>,,,CR
CBLL.6:
SKIPE ERRFLG ;IF ERROR -
RET ;THEN GO AWAY
ADD T2,FLDLEN
AOJA ARG,CBLLUP
FIELD: ;OBTAIN FIELD INFORMATION
LOAD T,.FIELD
LOAD PRM,.SPARM
LOAD T1,.LENG
RET
;OUTPUT A TABLE OF FIELD NUMBERS WHICH CAN BE REFERENCED BY
; THE FIELD NAME. THUS
;
; FIELD SALARY
;
; BECOMES
;
; 10 FN-SALARY PIC S9(6) COMP VALUE IS 24.
;
CBLFNM:
MOVE F,TEMP ;RECOVER FLAGS
FMSG RECJFN,,,,CR
FMSG RECJFN,<************************************************************>,,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* FIELD NUMBER TABLE OF FORM: >,NMFORM,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* SPECIFICATION FILE: >,NMSPEC,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<* DATE OF COMPILATION: >,DAYTIM,,CR
FMSG RECJFN,<*>,,,CR
FMSG RECJFN,<************************************************************>,,,CR
SETZB ARG,T ;INITIALIZE TABLE INDEXES
MOVE T2,DATA
FMSG RECJFN,<01 FN->,NMFORM
FMSG RECJFN,< USAGE IS COMPUTATIONAL.>,,,CR
;FOR EACH FIELD IN THE FORM
FNMLP: CAML ARG,CURFLD ;IF PASSED ALL FIELDS THEN
RET ; WE ARE DONE
LOAD T,.FIELD
FMSG RECJFN,< 10 FN->,T,,CR
FMSG RECJFN,< PICTURE S9(6) VALUE IS >
MOVEI B,1(ARG)
NUMBR RECJFN
FMSG RECJFN,<.>,,,CR
ADD T2,FLDLEN ;GO TO NEXT ENTRY IN THE TABLE
AOJA ARG,FNMLP ;AND CONTINUE
;CBLPIC - THIS DOES THE PICTURE OF THE FIELD.
CBLPIC:
LOAD T,.LENG
MOVE T1,T ;GET CORRECT SIZE
TXNE PRM,%MULT ;IF MULTIPLE
IMUL T1,MSLEN
LOAD PRM,.SPARM ;GET PARAMS FOR FIELD
REMARK OUTPUT PICTURE OF ITEM.
FMSG RECJFN,<
PICTURE >
REMARK TEST FOR DATE. THESE GET SPECIAL PICTURES.
TXNN PRM,%DATE
JRST NPICDT
SETZ T,
LOAD T,.TYPE ;SUB-TYPE OF DATE
TXZE T,%LONGD ;IF LONG DATE
JRST PIC3 ; THEN DIFFERENT PICTURES
JRST @[PIC0
PIC0
PIC0
PIC1
PIC2
PIC1
PIC0](T)
PIC0:
FMSG RECJFN,<9(6>
JRST CBL.7
PIC1:
FMSG RECJFN,<X(7>
JRST CBL.7
PIC2:
FMSG RECJFN,<9(5>
JRST CBL.7
PIC3:
JRST @[PIC4
PIC5
PIC6
PIC5
PIC4
PIC4
PIC4](T)
PIC4:
FMSG RECJFN,<9(8>
JRST CBL.7
PIC5:
FMSG RECJFN,<X(9>
JRST CBL.7
PIC6:
FMSG RECJFN,<9(7>
JRST CBL.7
NPICDT: ;NOT A DATE
REMARK SPECIAL CASE OF MONEY FIELDS
TXNN PRM,%MONEY
JRST NPICMN ;NOT MONEY
REMARK DO MONEY SPECIFIC STUFF
X=HLDJFN ;TEMP. REG. DEFINITION
SETZB T,X
LOAD X,.TYPE ;NUMBER CENTS PLACES
MOVE T1,.LENG
ADD T1,T2
LDB T,T1 ;TOTAL LENGTH OF FIELD
CAMN T,X ;EQUAL
JRST NODOLR ;YES - NO ROOM FOR DOLLARS
FMSG RECJFN,<S9(> ;DOLLARS FIELD
MOVE B,T
SUB B,X ;TOTAL-1-CENTS
NUMBR RECJFN
FMSG RECJFN,<)>
NODOLR:
JUMPE X,[FMSG RECJFN,<.>,,,CR
RET] ;ANY CENTS ?
FMSG RECJFN,<V> ;IMPLIED DECIMAL POINT
FMSG RECJFN,<9(>
NUMBR RECJFN,X
FMSG RECJFN,<).>,,,CR
RET
NPICMN:
SETZ A,
ORCAM PRM,A
TXNN A,%NUMER
JRST CBL.4
FMSG RECJFN,<A(>
JRST CBL.6
CBL.4:
TXNN A,%ALPHA
JRST CBL.5
FMSG RECJFN,<S9(>
JRST CBL.6
CBL.5:
FMSG RECJFN,<X(>
CBL.6:
REMARK DECIDE ON A LENGTH AND PUT IT IN PICTURE CLAUSE
LOAD T,.LENG ;GET FIELD LENGTH
NUMBR RECJFN,T
REMARK DO DISPLAY-7 CONSTANT.
CBL.7:
FMSG RECJFN,<).>,,,CR
RET
;END--
;
;COME HERE TO CREATE A MACRO SPECIFIC RECORD DESCRIPTION FILE.
;WE ENTER BYTE POINTERS, FIELD NUMBERS AND FIELD LENGTHS AND
;ALSO A DATA AREA FOR THE FORM.
;
PR.MAC:
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; BYTE POINTERS FOR FORM: >,NMFORM,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; SPECIFICATION FILE: >,NMSPEC,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; DATE OF COMPILATION: >,DAYTIM,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
FMSG RECJFN,,,,CR
SETZB ARG,T ;SET UP FOR THE LOOP
MOVE T2,DATA
FMSG RECJFN,,TEXTBF
FMSG RECJFN,<$:>,,,CR
MACLUP:
CAML ARG,CURFLD ;DONE?
JRST MACFNM ;YES - DO FIELD NUMBERS
CALL FIELD ;GET FIELD INFO
;
;BYTE POINTERS FOR EACH FIELD ARE OF THE FORM:
;
;NAME$: POINT 7,FORM$+OFFSET,BIT
;
FMSG RECJFN,,T ;FIELD NAME
FMSG RECJFN,<$: POINT 7,>,TEXTBF
LOAD T,.OFFST
FMSG RECJFN,<.+^D>
IDIVI T,5 ;WORDS
NUMBR RECJFN,T
FMSG RECJFN,<,>
IMULI T1,7 ;BITS INTO THE WORD
NUMBR RECJFN,T1
TXNN PRM,%MULT
JRST MAC.2
FMSG RECJFN,< ;MULTIPLE>
MAC.2:
FMSG RECJFN,,,,X
SKIPE ERRFLG
RET
ADD T2,FLDLEN ;POINT TO NEXT FIELD
AOJA ARG,MACLUP
;
;NOW GENERATE THE FIELD NUMBER AND LENGTH SYMBOLS.
;THE LENGTH OF A FIELD IS GIVEN BY THE SYMBOL 'NAME%'
;AND THE NUMBER IS GIVEN BY 'NAME.'
;
MACFNM:
FMSG RECJFN,,,,CR
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; FIELD NUMBERS AND LENGTHS FOR FORM: >,NMFORM,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; FIELD LENGTHS ARE OF THE FORM "NAME%">,,,CR
FMSG RECJFN,<; FIELD NUMBERS ARE OF THE FORM "NAME.">,,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
SETZB ARG,T ;SET UP FOR THE LOOP
MOVE T2,DATA
MACFNL:
CAML ARG,CURFLD ;DONE?
JRST MACBLK ;YES - DO THE BLOCK DATA
LOAD T,.FIELD
FMSG RECJFN,<
>,T
FMSG RECJFN,<%=^D>
LOAD B,.LENG
NUMBR RECJFN
FMSG RECJFN,<
>,T
FMSG RECJFN,<.=^D>
MOVEI B,1(ARG)
NUMBR RECJFN
ADD T2,FLDLEN ;LOOP ROUND
AOJA ARG,MACFNL
;
;FINALY GENERATE THE DATA BLOCK FOR THE FORM
;
MACBLK:
FMSG RECJFN,,,,CR
FMSG RECJFN,,,,CR
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<; FORM DATA AREA FOR FORM: >,NMFORM,,CR
FMSG RECJFN,<;>,,,CR
FMSG RECJFN,<;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;>,,,CR
FMSG RECJFN,,,,CR
FMSG RECJFN,,TEXTBF
FMSG RECJFN,<.: BLOCK ^D>
MOVE B,OFFSET
ADDI B,4 ;ROUND UP IF NECESSARY
IDIVI B,5
NUMBR RECJFN
FMSG RECJFN,,,,CR
RET
;
;THE FOLLOWING CODE CREATES THE FORTRAN SPECIFIC RECORD DESCRIPTION
;FILE FOR THE FORM. FORTRAN MODE ASSUMES WORD ALIGNMENT.
;
PR.FOR:
FMSG RECJFN,<CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC>,,,CR
FMSG RECJFN,<C>,,,CR
FMSG RECJFN,<C DATA AREA FOR FORM: >,NMFORM,,CR
FMSG RECJFN,<C>,,,CR
FMSG RECJFN,<C SPECIFICATION FILE: >,NMSPEC,,CR
FMSG RECJFN,<C>,,,CR
FMSG RECJFN,<C DATE OF COMPILATION: >,DAYTIM,,CR
FMSG RECJFN,<C>,,,CR
FMSG RECJFN,<CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC>,,,CR
FMSG RECJFN,<C
C FORM DATA AREA
C
DIMENSION >,TEXTBF
FMSG RECJFN,<(>
MOVE B,OFFSET
IDIVI B,5
NUMBR RECJFN
FMSG RECJFN,<)>,,,CR
SETZB ARG,T ;SET UP THE LOOP
MOVE T2,DATA
MOVEM F,TEMP ;SAVE F FOR NOW
SETZ F,
FORLUP:
CAML ARG,CURFLD ;DONE?
JRST FOR.5 ; YES
CALL FIELD ;GET FIELD INFO
TXNN PRM,%MULT
JRST FOR.2
SKIPE F ;MULTIPLE - DONE HEADER?
JRST FOR.1 ;YES
;
;IF THERE IS A MULTIPLE SECTION, WE GENERATE A LARGE ARRAY TO TAKE
;ALL THE DATA FOR IT AND USE THE FIELD NAME AS AN INDEX TO IT. THE
;NAME OF THE ARRAY IS ALWAYS "MULTPL".
;
FMSG RECJFN,<
C
C MULTIPLE SECTION DATA AREA - FIELD NAMES ARE USED AS AN INDEX
C
>
FMSG RECJFN,<
DIMENSION MULTPL(>
NUMBR RECJFN,MULTX
FMSG RECJFN,<,>
NUMBR RECJFN,MSLEN
FMSG RECJFN,<)
EQUIVALENCE (MULTPL(1,1),>,TEXTBF
FMSG RECJFN,<(>
LOAD B,.OFFST
IDIVI B,5
MOVEM B,MULTX ;SAVE THE INITIAL OFFSET
AOJ B,
NUMBR RECJFN
FMSG RECJFN,<))>,,,CR
SETO F, ;DONE MULTIPLE HEADER
FOR.1:
;
;SET UP AN INTEGER PARAMETER FOR EACH MULTIPLE FIELD NAME. THE
;PARAMETER IS USED AS AN INDEX INTO THE ARRAY, IE MULTPL(FIELD,ELEM).
;
FMSG RECJFN,<
PARAMETER >,T
FMSG RECJFN,<=>
LOAD B,.OFFST
IDIVI B,5
SUB B,MULTX ;CORRECT FOR INITIAL OFFSET
AOJ B,
NUMBR RECJFN
JRST FOR.4
FOR.2:
;
;EACH FIELD OCCUPIES AN INTEGRAL NUMBER OF WORDS SO WE SIMPLY
;USE DIMENSION TO ALLOCATE SPACE FOR THE FIELDS.
;
CAIGE T1,5 ;ONLY DO DIMENSION IF BIG ENOUGH
JRST FOR.3
FMSG RECJFN,<
DIMENSION >,T
FMSG RECJFN,<(>
PUSH P,T1
ADDI T1,5
PUSH P,T2
IDIVI T1,5 ;ROUND AND CONVERT TO WORDS
POP P,T2
NUMBR RECJFN,T1
POP P,T1
FMSG RECJFN,<)>
FOR.3:
FMSG RECJFN,<
EQUIVALENCE (>,T
CAIL T1,5 ;IF ONLY ONE WORD THEN SKIP
JRST [FMSG RECJFN,<(1)>
JRST .+1]
FMSG RECJFN,<,>,TEXTBF
FMSG RECJFN,<(>
LOAD B,.OFFST
IDIVI B,5
AOJ B,
NUMBR RECJFN
FMSG RECJFN,<))>
FOR.4:
ADD T2,FLDLEN ;ROUND FOR MORE
AOJA ARG,FORLUP
FOR.5:
FMSG RECJFN,,,,CR
MOVE F,TEMP
RET
SUBTTL CREATE OUTPUT ORL FILE
PUTREL:
SKIPN VETFLG ;WERE THERE ANY VET ROUTINES
RET ;NO
SETZM ERRFLG ;CLEAR ERROR FLAG
TXNN F,%SWOUT ;ANYTHING TO DO?
RET ;NO
MOVEI A,DEFREL
MOVE B,[POINT 7,NMFORM]
GTJFN ;CREATE THE FILE
ERJMP ERR ;ERR RETURNS TO CALLER
MOVEM A,ORLJFN ;SAVE THE JFN
MOVE B,[OF%WR+44B5]
OPENF
JERROR <Unable to open the .REL file>,<JRST ERRFIL>
MOVE A,ORLJFN
MOVE B,[POINT 36,RELSTB]
MOVNI C,5
SOUT ;OUTPUT THE START BLOCK
ERJMP ERRFIL
MOVEI D,1
MOVE T,[POINT 1,VETTAB]
PTRL1: ILDB T1,T ;GET A BIT FROM TABLE
JUMPE T1,PTRL4 ;SKIP THIS IF NOT SET
PUSH P,T ;SAVE POINTER
MOVEI T2,20 ;A SIXBIT ZERO
MOVE T,D ;COPY IT
CAIGE T,^D100 ;DONT DIVIDE IF <100
JRST PTRL2
IDIVI T,^D100
ADD T2,T ;COPY TO T2
MOVE T,T1 ;GET REMAINDER
PTRL2: LSH T2,6 ;LINE IT UP
ADDI T2,20 ;SIXBIT
CAIGE T,^D10 ;DONT DIVIDE IF <10
JRST PTRL3
IDIVI T,^D10
ADD T2,T ;ADD TO RESULT
MOVE T,T1 ;REMAINDER
PTRL3: LSH T2,6 ;LINE IT UP
ADDI T,20
ADD T,T2 ;RESULT
HLL T,[SIXBIT /VET /]
MOVEM T,RELDAT+2 ;SAVE THE ROUTINE NAME
POP P,T ;RESTORE POINTER
MOVE A,ORLJFN
MOVE B,[POINT 36,RELDAT]
MOVNI C,5
SOUT ;WRITE IT TO FILE
ERJMP ERRFIL
PTRL4: AOJ D, ;INCREMENT IT
CAIGE D,^D512 ;DONE?
JRST PTRL1 ;NO
MOVE A,ORLJFN
MOVE B,[POINT 36,RELEND]
MOVNI C,4
SOUT ;WRITE END BLOCK
ERJMP ERRFIL
RET
SUBTTL CREATE SUMMARY FILE
SALL
PUTSUM: ;SUMMARY FILE
SETZM ERRFLG ;CLEAR ERROR FLAG
SKIPE CURFLD ;IF NO FIELDS, OR,
TXNN F,%SWSUM ; IF NO SUMMARY FILE
RET ; THEN DON'T DO IT
REMARK WRITE OUT FORM HEADER INFO TO FILE
MOVE T,FATTR ;SEE IF REVERSE VIDEO
TXNN T,%FRVRS
JRST SUM1 ;NO
FMSG SUMJFN,<Form is displayed in REVERSE-VIDEO>,,,CR
SUM1:
TXNN F,%SWOUT ;SAW OUTPUT FILE ?
JRST SUM2 ;NO
HRROI A,NMOUTF
MOVE B,OUTJFN
SETZ C,
JFNS
FMSG SUMJFN,<Output-file: >,NMOUTF,,CR
SUM2:
TXNN F,%SWSUM ;SAW SUMMARY FILE ?
JRST SUM3
HRROI A,NMSUMF
MOVE B,SUMJFN
SETZ C,
JFNS
FMSG SUMJFN,<Summary-file: >,NMSUMF,,CR
SUM3:
TXNN F,%SWREC ;SAW RECORD-DESC FILE ?
JRST SUM4
HRROI A,NMRECF
MOVE B,RECJFN
SETZ C,
JFNS
MOVE T,RECTYP ;GET THE LANGUAGE
MOVE T,[[ASCIZ /COBOL/]
[ASCIZ /COBOL/]
[ASCIZ /FORTRAN/]
[ASCIZ /MACRO/]](T)
FMSG SUMJFN,<Record-description-file: >,NMRECF
FMSG SUMJFN,< Assumed language is >,T,,CR
SUM4:
TXNN F,%SWERL ;SAW ERROR-LINE ?
JRST SUM7 ;NO
FMSG SUMJFN,<Error-line: >
MOVE B,ERRLIN
JUMPE B,SUM5 ;0 = BOTTOM
NUMBR SUMJFN
JRST SUM6
SUM5:
FMSG SUMJFN,<BOTTOM>
SUM6:
FMSG SUMJFN,< Displayed in >
MOVE PRM,EATTR ;GET THE ERROR-LINE ATTRIBUTES
ASH PRM,^D27 ;LINE THE BITS UP
CALL SUMATR ;AND REPORT THEM
SUM7:
SKIPN ALIGN ;IF ALIGNED - REPORT IT
JRST SUM8
FMSG SUMJFN,<Field data is word aligned>,,,CR
SUM8:
MOVE T,CHRSET ;TELL THEM ABOUT THE CHARACTER SET
MOVE T,[[ASCIZ /US/]
[ASCIZ /UK/]
[ASCIZ /GRAPHIC/]
[ASCIZ /ALTERNATE/]](T)
FMSG SUMJFN,<Assumed character set is: >,T,,CR
SKIPG T,TERMS ;SEE IF ANY RESTRICTIONS HERE
JRST SUM9 ;NO - SKIP IT
FMSG SUMJFN,<Terminal types allowed are: >
TXNN T,1B<^D36-%VT05>
JRST SUM81
FMSG SUMJFN,<VT05 >
SUM81:
TXNN T,1B<^D36-%VT50H>
JRST SUM82
FMSG SUMJFN,<VT50H >
SUM82:
TXNN T,1B<^D36-%VT52>
JRST SUM83
FMSG SUMJFN,<VT52 >
SUM83:
TXNN T,1B<^D36-%VT100>
JRST SUM84
FMSG SUMJFN,<VT100 >
SUM84:
TXNN T,1B<^D36-%VT132>
JRST SUM85
FMSG SUMJFN,<VT132>
SUM85:
FMSG SUMJFN,,,,CR
SUM9:
FMSG SUMJFN,<Maximum useable screen area is: >
MOVE B,MAXLIN
NUMBR SUMJFN
FMSG SUMJFN,< lines by >
MOVE B,MAXCOL
NUMBR SUMJFN
FMSG SUMJFN,< columns.
Highest useable section number is: >
SKIPN B,NUMSEC
MOVEI B,DF%SEC ;IF ZERO - USE DEFAULT
NUMBR SUMJFN
FMSG SUMJFN,<
>
;PRINT A FEW MORE THINGS IN THE GENERAL SECTION
FMSG SUMJFN,<Sections in use: >
MOVEI T,ALLSEC
CALL SECOUT
SKIPE ERRFLG ;IF ERROR -
RET ;THEN GO AWAY
SKIPN HIDDEN ;ANY HIDDEN SECTIONS?
JRST SUM10
FMSG SUMJFN,<Hidden sections: >
MOVE T,HDNPTR ;POINT TO HIDDEN MASKS
CALL SECOUT ;LIST THEM
SKIPE ERRFLG ;IF ERROR -
RET ;THEN GO AWAY
SUM10:
SKIPN T,MSECT ;SKIP IF NO MULTIPLES
JRST SUM11 ;NO
FMSG SUMJFN,<Multiple section: >
NUMBR SUMJFN,MSECT ;SECTION NUMBER
FMSG SUMJFN,<
Top line: >
NUMBR SUMJFN,MSTOP ;TOP LINE NO.
FMSG SUMJFN,<
Section length: >
NUMBR SUMJFN,MSLEN ;COUNT OF ENTRIES
FMSG SUMJFN,<
Vertical count: >
NUMBR SUMJFN,MSCNT ;ELEMENTS DISPLAYED
FMSG SUMJFN,,,,CR
SUM11:
FMSG SUMJFN,<Total record size: >
MOVE B,OFFSET ;CONVERT OFFSET TO WORDS
ADDI B,4
IDIVI B,5
NUMBR SUMJFN
FMSG SUMJFN,< words.
Last field number: >
NUMBR SUMJFN,CURFLD
FMSG SUMJFN,<
>
REMARK DO SUMMARY FOR EACH FIELD DEFINED.
SETZ ARG,T ;ARG=COUNTER; T=WORK AREA
MOVE T2,DATA ;T2 => DATA FIELDS
FLDLUP:
CAML ARG,CURFLD ;DONE ALL FIELDS YET ?
JRST PRT3 ;DO THE SECTION-FIELD OUTPUT.
LOAD T,.FIELD
FMSG SUMJFN,<
Field: >,T ;OUTPUT FIELD NAME
FMSG SUMJFN,< Field number: >
MOVEI B,1(ARG)
NUMBR SUMJFN
SETZ T,
LOAD T,.LINE
FMSG SUMJFN,<
Position: line >
NUMBR SUMJFN,T
FMSG SUMJFN,<, column >
SETZ T,
LOAD T,.COLM
NUMBR SUMJFN,T
FMSG SUMJFN,< Length: >
SETZ T,
LOAD T,.LENG
MOVEM T,MAXLEN ;SAVE LENGTH THIS FIELD
NUMBR SUMJFN,T
SKIPE T,FILLER ;NULL OR SPACE ARE DEFAULT
CAIN T," "
JRST SUM12
FMSG SUMJFN,< Filler: ">
MOVE A,SUMJFN
MOVE B,T
BOUT
ERJMP ERRFIL
FMSG SUMJFN,<">
SUM12:
FMSG SUMJFN,,,,CR
REMARK DO VALUE - ATTRIBUTES - LOWER / UPPER RANGE
TXNN PRM,%DFDT ;SEE IF DEFAULT DATE
JRST SUM12A
FMSG SUMJFN,<Value: Preset to current date>,,,CR
JRST SUM13
SUM12A:
SETZB T,A
LOAD T,.VALUE
MOVE A,(T) ; IN A
TLNN A,774000 ;FIRST BYTE = NULL ?
JRST SUM13 ;YES - NO VALUE
FMSG SUMJFN,<Value: ">,T,,,MAXLEN
FMSG SUMJFN,<">,,,CR
SUM13:
REMARK DO ATTRIBUTES
SETZM FILCOL ;WANT COLUMN CHECKING
FMSG SUMJFN,<Attributes: >
SETZB T,PRM
LOAD PRM,.SPARM
JUMPE PRM,SKPATT ;NULL ? THEN SKIP IT.
TXNN PRM,%PROT
JRST SUM13A
FMSG SUMJFN,< PROTECTED>
JRST SUM23 ;SKIP SOME IF PROTECTED
SUM13A:
FMSG SUMJFN,< UNPROTECTED>
MOVE T1,PRM ;SEE IF A-N-P
ANDX T1,%CLASS
CAIE T1,%CLASS
JRST SUM14 ;NO
FMSG SUMJFN,< ALPHA-NUMERIC-PUNCTUATION>
JRST SUM15A
SUM14:
CAIE T1,%ALPHA+%NUMER ;ALPHA-NUMERIC?
JRST SUM14A ; NO
FMSG SUMJFN,< ALPHA-NUMERIC>
JRST SUM15A
SUM14A:
TXNN PRM,%NUMER ;NUMERIC
JRST SUM15
FMSG SUMJFN,< NUMERIC>
TXNN PRM,%ZERO ;IF NOT ZERO FILLED
JRST SUM17 ; THEN GO ON
FMSG SUMJFN,< ZERO-FILLED>
JRST SUM17
SUM15:
TXNN PRM,%ALPHA ;ALPHA
JRST SUM17
FMSG SUMJFN,< ALPHABETIC>
SUM15A:
TXNN PRM,%SPACE ;IF SPACES ARE NOT ALLOWED
JRST SUM16 ; THEN GO ON
FMSG SUMJFN,< ALLOW-SPACES>
JRST SUM17
SUM16:
FMSG SUMJFN,< NO-SPACES>
SUM17:
TXNN PRM,%LOWER
JRST SUM18
FMSG SUMJFN,< LOWERCASE>
SUM18:
TXNN PRM,%NAUTO
JRST SUM19
FMSG SUMJFN,< NOT-AUTO-TAB>
SUM19:
TXNN PRM,%REQD
JRST SUM20
FMSG SUMJFN,< REQUIRED>
JRST SUM21
SUM20:
FMSG SUMJFN,< OPTIONAL>
SUM21:
TXNN PRM,%FULL
JRST SUM22
FMSG SUMJFN,< FULL-FIELD>
JRST SUM23
SUM22:
FMSG SUMJFN,< NOT-FULL-FIELD>
SUM23:
TXNN PRM,%YN
JRST SUM26
FMSG SUMJFN,< YES-NO>
SUM26:
TXNN PRM,%MONEY
JRST SKPMNY
FMSG SUMJFN,< MONEY (>
LOAD B,.TYPE ;=NUMBER OF PLACES
NUMBR SUMJFN
FMSG SUMJFN,< decimal positions)>
SKPMNY:
REMARK DO DATE STUFF
TXNN PRM,%DATE
JRST SKPDAT
LOAD B,.TYPE
TXZE B,%LONGD
JRST [PUSH P,B
FMSG SUMJFN,< LONG-DATE - >
JRST SUM26A]
PUSH P,B
FMSG SUMJFN,< DATE - >
SUM26A:
POP P,B
JRST @[PD0
PD1
PD2
PD3
PD4
PD5
PD6](B)
PD0:
FMSG SUMJFN,<CANADA>
JRST SKPDAT
PD1:
FMSG SUMJFN,<COBOL>
JRST SKPDAT
PD2:
FMSG SUMJFN,<DASH>
JRST SKPDAT
PD3:
FMSG SUMJFN,<DEC>
JRST SKPDAT
PD4:
FMSG SUMJFN,<JULIAN>
JRST SKPDAT
PD5:
FMSG SUMJFN,<MILITARY>
JRST SKPDAT
PD6:
FMSG SUMJFN,<SLASH>
SKPDAT:
TXNN PRM,%MSDUP
JRST SUM27
FMSG SUMJFN,< MASTER-DUPE>
JRST SUM29
SUM27:
TXNN PRM,%PRDUP
JRST SUM28
FMSG SUMJFN,< PREVIOUS-DUPE>
JRST SUM29
SUM28:
FMSG SUMJFN,< NO-DUPE>
SUM29:
TXNN PRM,%HIDE
JRST SUM30
FMSG SUMJFN,< HIDDEN>
SUM30:
TXNN PRM,%MULT
JRST SUM31
FMSG SUMJFN,< MULTIPLE>
SUM31:
TXNN PRM,%INDEX
JRST SUM32
FMSG SUMJFN,< (INDEX-FIELD)>
SUM32:
TXNN PRM,%NEKO
JRST SUM33
FMSG SUMJFN,< NO-ECHO>
SUM33:
FMSG SUMJFN,,,,CR
JRST SUM34
SKPATT:
FMSG SUMJFN,< NONE SET>,,,CR
SUM34:
SETOM FILCOL ;DONT CHECK NOW
TXNE PRM,%SFDEF ;SUBFIELDS?
CALL SUMDSC ;YES
LOAD T,.VETNO
SKIPN T ;MUST BE >0
JRST SUM35
FMSG SUMJFN,<Vet routine: VET>
MOVE A,SUMJFN
MOVEI B,(T)
MOVE C,[NO%LFL+NO%ZRO+3B17+^D10]
NOUT
ERJMP ERRPC
FMSG SUMJFN,,,,CR
SUM35:
FMSG SUMJFN,<Rendition: >
CALL SUMATR ;DO THE VIDEO ATTRIBUTES
TXNN PRM,%HELP ;DO HELP MESSAGE
JRST SUM36
LOAD T,.HELP
LOAD T3,.LNHLP
FMSG SUMJFN,<Help text: ">,T,,,T3
FMSG SUMJFN,<">,,,CR
SUM36:
TXNN PRM,%TEXT ;ANY TEXT
JRST SUM37 ;NO
LOAD T,.TLENG
MOVEM T,LNTVAL
FMSG SUMJFN,<Text value: ">
MOVE A,SUMJFN
LOAD T,.TXTPT
HRLI T,(POINT 7,)
SUM36A:
ILDB B,T ;GET A BYTE
CAIN B,15
JRST [FMSG SUMJFN,<">,,,CR
FMSG SUMJFN,< ">
MOVE A,SUMJFN
JRST SUM36A] ;NEW LINE AND KEEP LOOPING
SKIPE B
JRST [BOUT
ERCAL ERRPC
JRST SUM36A] ;ORDINARY CHARACTER
FMSG SUMJFN,<">,,,CR
FMSG SUMJFN,<Text length: >
NUMBR SUMJFN,LNTVAL
FMSG SUMJFN,< Position: line >
LOAD B,.TLINE
NUMBR SUMJFN
FMSG SUMJFN,<, column >
LOAD B,.TCOLM
NUMBR SUMJFN
FMSG SUMJFN,<
Text rendition: >
LOAD PRM,.TPARM
ASH PRM,^D27
CALL SUMATR
SUM37: ;DO SECTION STUFF
FMSG SUMJFN,<Sections: >
MOVE T,T2
ADD T,.SECTN ;POINT TO SECTION MASKS
CALL SECOUT ;OUTPUT THE SECTION
SKIPE ERRFLG ;IF ERROR -
RET ;THEN GO AWAY
REMARK DO RANGES
SETZ T, ;VITAL !
LOAD T,.LRANG
SKIPN T
JRST SUM38
FMSG SUMJFN,<Lower range: ">,T,,,MAXLEN
FMSG SUMJFN,<">,,,CR
SUM38:
LOAD T,.URANG
SKIPN T
JRST SUM39
FMSG SUMJFN,<Upper range: ">,T,,,MAXLEN
FMSG SUMJFN,<">,,,CR
SUM39:
ADD T2,FLDLEN ;TO NEXT FLD
AOJA ARG,FLDLUP
PRT3:
RET
SUMATR: ;DO VIDEO ATTRIBUTES
TXNN PRM,%REND ;DO RENDITION STUFF
JRST SMA6 ;NONE
TXNN PRM,%RVRS ;REVERSE
JRST SMA1
FMSG SUMJFN,<REVERSE-VIDEO >
SMA1: TXNN PRM,%BLNK ;BLINKING
JRST SMA2
FMSG SUMJFN,<BLINKING >
SMA2: TXNN PRM,%BOLD ;BOLD
JRST SMA3
FMSG SUMJFN,<BOLD >
SMA3: TXNN PRM,%UNDR ;UNDERSCORE
JRST SMA4
FMSG SUMJFN,<UNDERSCORE >
SMA4: TXNN PRM,%TALL ;IF TALL
JRST SMA5
FMSG SUMJFN,<TALL >
SMA5:
TXNN PRM,%WIDE
JRST SMA7
FMSG SUMJFN,<WIDE >
JRST SMA7
SMA6:
FMSG SUMJFN,<NORMAL-VIDEO>
SMA7:
FMSG SUMJFN,,,,CR
RET
SECOUT: ;OUTPUT SECTION NUMBERS
PUSH P,T2
MOVE A,SUMJFN ;SET UP THE NOUT AND BOUT
MOVE C,[5,,^D10]
HLL T,HDNPTR ;COPY THE COUNT FROM HDNPTR
SETZB T1,T2
SECOT1:
MOVEI T3,1 ;A BIT
SKIPN T4,(T) ;GET THE MASK WORD
JRST [ADDI T1,^D36 ;UP THE COUNTER
JRST SECOT3]
SKIPA ;DON'T SHIFT FIRST TIME
SECOT2:
LSH T3,1 ;SHIFT UP ONE
SKIPN T3 ;IF DONE WITH THIS WORD
JRST SECOT3 ; THEN TRY THE NEXT
AOS T1 ;UPDATE THE COUNTER
TDNN T4,T3 ;IS THE BIT SET?
JRST SECOT2 ; NO - NEXT
SETO T2, ;SET A FLAG
MOVE B,T1 ;COPY THE COUNT
NOUT ;AND TYPE IT OUT
ERJMP ERRPC
JRST SECOT2 ;NEXT BIT
SECOT3:
AOBJN T,SECOT1 ;LOOP FOR MORE WORDS
SKIPN T2
JRST [FMSG SUMJFN,<none
>
POP P,T2
RET]
FMSG SUMJFN,<
>
POP P,T2
RET
SUMDSC: ;SUMMARY OF DESCRIPTOR
TXNE PRM,%DATE+%MONEY ;DATE OR MONEY HAVE BEEN DONE
RET
PUSH P,T2 ;SAVE FOR CALLER
FMSG SUMJFN,<Descriptor string: ">
MOVE A,SUMJFN
LOAD T,.SFDES ;POINT TO THE DESCRIPTOR
HRLI T,(POINT 9,0)
SETZB T2,T3 ;CLEAR COUNTER AND FLAG
SMDS10:
ILDB T1,T ;GET A BYTE
JUMPE T1,SMDS60 ;DONE ON NULL
TXNE T1,%SFLEN ;LENGTH?
JRST [MOVE T2,T1 ; YES - COPY IT
ANDI T2,177
JRST SMDS10]
TXNE T1,%SFSEP ;SEPARATOR?
JRST SMDS50 ; YES
JUMPE T2,SMDS30 ;ZERO => TIME (DATE HAS BEEN DONE)
SMDS15:
TXNE T1,%SFTYP ;IS IT A SPECIFIC TYPE?
JRST SMDS20 ; YES
TXNE T1,%T.PUN ;PUNCTUATION ALLOWED?
JRST [MOVEI B,"X" ; YES
JRST SMDS40]
TXNE T1,%T.ALP ;ALPHABETIC?
JRST [MOVEI B,"A" ; YES
TXNE T1,%T.DIG ; OR MAY BE ALPHANUMERIC
MOVEI B,"X" ; IT IS
JRST SMDS40]
MOVEI B,"Z" ;ASSUME NUMERIC ONLY
TXNE T1,%T.SPC ;WITH LEADING ZEROS?
MOVEI B,"9" ; YES
JRST SMDS40
SMDS20:
ANDI T1,%SFTYP ;SPECIAL TYPE
MOVE B,["S" ;SO GET RELEVENT CHARACTER
"H"
"D"
"M"
"Y"]-1(T1)
JRST SMDS40
SMDS30:
CAIN T1,%T.H ;IS IT HOURS?
JRST [MOVEI T2,2 ; YES - LENGTH IS 2
MOVEI B,"H"
JRST SMDS40]
CAIE T1,%T.MS ;MINUTES/SECONDS?
JRST [MOVEI T2,1 ; NO - ASSUME LENGTH IS 1
JRST SMDS15]
MOVEI T2,2 ;LENGTH IS 2
MOVEI B,"M" ;TRY FOR MINUTES
SKIPE T3
MOVEI B,"S" ;SECONDS REALY
SETO T3, ;SET FLAG FOR LATER
SMDS40:
BOUT
ERCAL ERRPC
SOJG T2,SMDS40
SETZ T2, ;JUST IN CASE
JRST SMDS10
SMDS50:
MOVE B,T1 ;COPY SEPARATOR
ANDI B,177
JRST SMDS40
SMDS60:
FMSG SUMJFN,<">,,,CR
POP P,T2
RET
SUBTTL DOFMSG -- GENERAL PRINT FORMATTING OUTPUT ROUTINE
FMSIZE==0 ;LH-LENGTH OF MESSAGE
FMMSG==0 ;RH-ADDRESS OF MESSAGE
FMJFN==1 ;LH-JFN TO OUTPUT TO
FMTERM==1 ;RH-TERMINATION CHARACTER
FMDATA==2 ;ADDRESS OF DATA (OR DATA)
FMCR=3 ;LH-1 IF CRLF AFTER MESSAGE, 0 OTHERWISE
FMLENG=3 ;RH-POINTER TO PADDED LENGTH OF MESSAGE
DOFMSG: ;THE ARGUMENT BLOCK IS POINTED AT BY T4
HLRZ B,FMSIZE(T4) ;GET LENGTH OF MESSAGE IN CHARACTERS
HLRZ A,FMJFN(T4) ;GET THE ADDRESS OF THE JFN
MOVE A,(A) ; AND THEN THE JFN
JUMPE B,DOMSG1 ;IF NO MESSAGE, THEN TEST DATA A CR
SKIPL FILCOL ;CHECKING COLUMNS?
CALL DOMSG3 ; YES
HRRO B,FMMSG(T4) ; AND THE MESSAGE ADDRESS.
HLRZ C,FMSIZE(T4) ;MAKE A TERMINATION LENGTH
MOVN C,C
SOUT
ERCAL ERRPC
DOMSG1:
SKIPGE B,FMDATA(T4) ;IF NO DATA
JRST DOMSG2 ; THEN NOTHING
CAIG B,17 ;IF THIS IS AN AC
MOVE B,(B) ; THEN IT IS AN ADDRESS.
HRLI B,-1 ;BUILD INTO ASCII POINTER.
HRRZ C,FMLENG(T4)
SKIPE C ;IF ZERO - HE MEANS IT
MOVE C,(C)
HRRZ D,FMTERM(T4)
SOUT
ERCAL ERRPC
DOMSG2:
HLRZ B,FMCR(T4) ;GET CARRIAGE RETURN INDICATOR
SKIPN B ;IF CRLF WANTED
RET
MOVNI C,2 ;THEN OUTPUT ONE
HRROI B,[ASCIZ /
/]
SOUT
ERCAL ERRPC
RET
DOMSG3:
ADDB B,FILCOL ;SEE WHERE WE WOULD BE
CAIGE B,^D72 ;AND SEE IF WE SHOULD DO NEW LINE
RET ; NOT YET
HRROI B,[ASCIZ /
/]
MOVNI C,^D12
SOUT
ERCAL ERRPC
MOVEI B,^D10
MOVEM B,FILCOL ;POINT TO RIGHT COLUMN
RET
SUBTTL LITERALS
XLIST
LIT
LIST
LALL
SUBTTL IMPURE DATA
LOC <.-TFRBEG+140+777>&777000 ;PAGE BOUND
IMPURE: ;IMPURE ADDR
REMARK XLIST VARS
XLIST
VAR
LIST
DEFFLD: BLOCK .FLDLN+WD%MSC
ICSB: ;FORM SPEC FILE CSB
CM%RAI+CM%XIF+GETIN0
.PRIIN,,.PRIOU
0
POINT 7,TEXT
POINT 7,TEXT
TEXTLN
0
POINT 7,ATOM
ATOMLN
0
CSB:
REPARS ;REPARSE ADDR
0 ;IN JFN,,OUT JFN
POINT 7,[ASCIZ !TFR> !] ;CONTROL-R BUFFER.
POINT 7,TEXT ;USER'S INPUT TEXT
POINT 7,TEXT ;NEXT FIELD TO PARSE
TEXTLN ;LENGTH OF TEXT LEFT
0 ;NUMBER YET TO SCAN
POINT 7,ATOM ;ATOM BUFFER POINTER
ATOMLN ;LENGTH OF ATOM BUFFER
OUTFDB ;OUTPUT FILE DATA BLOCK
STACK: BLOCK PDLEN ;STACK AREA.
FLDLEN: 0 ;FIELD DATA LENGTH
FRMLEN: 0 ;HEADER DATA LENGTH
DATA: 0 ;OFFSET TO DATA
;************
; THE FOLLOWING BLOCK OF JFN'S MUST STAY TOGETHER
;************
INPJFN: 100 ;DEFAULT TO TTY
OUTJFN: 377777 ;DEFAULT TO NUL:
LOGJFN: 377777 ;FOR TTY LOGGING
SUMJFN: 377777 ;FOR SUMMARY OF FIELDS
RECJFN: 377777 ;FOR RECORD-DESCRIPTION (COBOL)
ORLJFN: 377777 ;FOR OUTPUT REL FILE
PICJFN: 377777 ;FOR PRETTY PICTURE - DIAGRAM OF FORM
NJFN=.-OUTJFN ;NUMBER OF JFNS TO CLOSE
;************
WILD: 0 ;-1 IF WILD CARDS IN INPUT SPEC
CMDPTR: FDBCM1 ;ALL COMMANDS INITIALLY
JFNSWD: 2B2+2B5+1B8+1B11+1B14+JS%PAF
ZER.LO: ;THIS MARKS THE START OF THE DYNAMIC DATA
OUTFDB: BLOCK 16 ;FILE DATA BLOCK
TEXT: BLOCK TEXTLN/5 ;TEXT BUFFER
ATOM: BLOCK ATOMLN/5 ;ATOM BUFFER
DEFFNM: BLOCK <<<CIDCLN+6+1>+4>/5> ;ROOM FOR "FIELD-", COBOL ID, NUL
TEXTBF: BLOCK <TEXTLN+2>/5 ;TEMP BUFFER
BASLIN: 0 ;BASE LINE NUMBER
BASCOL: 0 ;BASE COLUMN NUMBER
OFSFLG: 0 ;OFFSET FLAG
FLDDSP: 0 ;DISPLACEMENT OF CMD INTO LAST FIELD
LINENM: 0 ;INPUT LINE #
LSTMSG: 0 ;LAST MSG WAS FOR THIS LINE NUMBER
INCHDR: 0 ;INCLUDE FILE HEADER
ERRCNT: 0 ;ERRORS FOUND
EOF: 0 ;FLAG FOR END-OF-FILE
EXITCM: 0 ;FLAG FOR EXIT COMMAND (OR EOF)
CURFLD: 0 ;CTR OF CURRENT FIELD ENTRY
NUMREQ: 0 ;NUMB REQD CMDS LEFT THIS FIELD
FATTR: 0 ;FORM ATTRIBUTES
EATTR: 0 ;ERROR LINE ATTRIBUTES
TERMS: 0 ;TERMINALS ALLOWED
ERRLIN: 0 ;ERROR LINE NUMBER
MAXLIN: 0 ;LIMIT OF SCREEN LINES
MAXCOL: 0 ;LIMIT OF SCREEN COLUMNS
MAXFLD: 0 ;MAXIMUM FIELD NUMBER
OFFSET: 0 ;OFFSET INTO RECORD DESCRIPTION
OFFSTA: 0 ;ALTERNATIVE OFFSET FOR MULTIPLE FIELDS
TCOUNT: 0 ;TEMP COUNT FOR MULTIPLE VALUES
SAMEAS: 0 ;FIELD WAS COPIED
FILLER: 0 ;FILLER CHARACTER FOR FIELD
COMMENT *
THE FOLLOWING AREAS HOLD ASCIZ STRINGS UNTIL THEY ARE
CONFIRMED TO BE ACCURATE (BY A NEW FIELD BEING DEFINED
OR THE END OF THE FORM).
*
NMFORM: BLOCK ^D35/5
NMSUMF: BLOCK ^D130/5+1
NAMINC: BLOCK ^D130/5+1
NMRECF: BLOCK ^D130/5+1
NMOUTF: BLOCK ^D130/5+1
NMFLD: BLOCK ^D35/5+1
LNFLD: 0
NMLWR: BLOCK ^D130/5+1
LNLWR: 0
LWRFLG: 0
NMUPR: BLOCK ^D130/5+1
LNUPR: 0
UPRFLG: 0
NMHELP: BLOCK ^D130/5+1
LNHELP: 0 ;HELP MSG
NMVAL: BLOCK ^D130/5+1
LNVAL: 0
NMTVAL: BLOCK ^D2000/5+1 ;TEXT VALUE STRING
LNTVAL: 0 ;TEXT VALUE LENGTH
TXTPTR: 0 ;POINTER INTO MNTVAL
NMSPEC: BLOCK ^D130/5+1 ;FORM SPECIFICATION FILE NAME
DAYTIM: BLOCK ^D130/5+1 ;DATE AND TIME STRING
VALFLG: 0
MAXLEN: 0
CHRSET: 0 ;CHAR SET
CSECT: 0 ;TEMP FOR SECTON NUMBER
MSECT: 0 ;MULTIPLE SECT NO.
MSTOP: 0 ;TOP LINE NO.
MSTOT: 0 ;TOTAL WIDTH SO FAR
MSLEN: 0 ;DISPLAYED LENGTH
MULTX: 0 ;WORD COUNTER FOR ALIGNED MODE
MSCNT: 0 ;TOTAL COUNT
MLTRN: -^D16 ;COUNT OF FIELDS
MLTIX: 0 ;INDEX FIELD LOCATION
RECTYP: 0 ;RECORD DESCRIPTOR FILE TYPE:
;0 = DEFAULT
;1 = COBOL
;2 = FORTRAN
;3 = MACRO
ALLSEC: BLOCK WD%MSC ;ROOM FOR MAXIMUM NUMBER OF SECTIONS
HIDDEN: 0 ;NON-ZERO IF ANY HIDDEN SECTIONS FOUND
HDNPTR: 0 ;POINTER TO HIDDEN SECTION MASKS
ERRFLG: 0 ;FLAG FILE ERRORS IF -1
TEMP: 0 ;TEMP INSTEAD OF PUSH FOR ABOVE TO WORK
VETTAB: BLOCK ^D15 ;VET NUMBER FLAG TABLE
VETFLG: 0 ;COUNT OF VET ROUTINES
ALIGN: 0 ;-1 IF WORD ALIGNED
DATTYP: 0 ;TYPE OF DATE SPECIFIED
LONGDT: 0 ;-1 FOR LONG FORMAT DATES
FFLD: 0 ;FIELD LOCATION WHEN SEARCHING
SAMNAM: BLOCK 20 ;SAME-AS NAME
SAMLEN: 0 ;SAME-AS NAME LENGTH
SAMFLD: 0 ;SAME-AS FIELD LOCATION
NUMSEC: 0 ;NUMBER OF SECTIONS
SFSEP: 0 ;NUMBER OF SEPARATORS
SFLEN: 0 ;LENGTH OF FIELD IN DESCRIPTOR
SFCNT: 0 ;NUMBER OF BYTES IN DESCRIPTOR
NMSFD: BLOCK <TEXTLN/4>+1 ;DESCRIPTOR STRING
NMDES: BLOCK <TEXTLN/4>+1 ;ASCII DESCRIPTOR STRING
LASTSP: 0 ;LAST SEPARATOR
LASTTC: 0 ;LAST TYPE CHARACTER
NUMBSP: 0 ;NUMBER OF OCCURENCES OF LAST SEPARATOR
NUMBTC: 0 ;NUMBER OF OCCURENCES OF LAST TYPE
NEWOST: 0 ;OFFSET TO SECTION WORD
NMINCL: 0 ;NUMBER OF NESTED INCLUDE COMMANDS
NINCOT: 0 ;NUMBER OF INCLUDE FILES WRITTEN
INCJFN: BLOCK MX%INC+1 ;INCLUDE FILE JFNS
STRPTR: 0 ;POINTER TO STRING AREA
FILCOL: 0 ;COLUMN NUMBER IN OUTPUT FILE
ZER.HI=.-1
;
;The following data is not cleared at startup
;
RSCFLG: 0 ;COUNT IN RESCAN BUFFER
RELDAT: 16,,3 ;REL FILE DATA RECORD
0
0
0
SIXBIT /TFR/
RELSTB: 4,,0
0
6,,1 ;REL FILE START BLOCK
0
RADIX50 0,.MAIN
RELEND: 5,,2 ;REL FILE END BLOCK
200000,,0
0
0
END TFR