Trailing-Edge
-
PDP-10 Archives
-
BB-5372C-BM
-
sources/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) 1976,1977,1978 DIGITAL EQUIPMENT CORP., MAYNARD MASS.***
SEARCH TFRUNV, MONSYM, MACSYM
SALL
CUSTVR==0 ;CUSTOMER VERSION
DECVER==2 ;DEC VERSION
DECMVR==0 ;DEC MINOR VERSION
DECEVR==110 ;DEC EDIT VERSION
V%TFR==:<CUSTVR>B2!<DECVER>B11!<DECMVR>B17!DECEVR
LOC <.JBVER==137> ;SET PROGRAM VERSION
V%TFR
RELOC
;CONDITIONAL ASSEMBLY PARAMETERS
MONITR=="1B" ;MONITOR VERSION (FOR BUGGY FIXES)
SHORTX==0 ;SHORT EXTENSIONS <== 1
;LONG EXTENSIONS <== 0
DEFAULT=0 ;ALLOW COPYING OF DEFAULTS <== 1
;DISALLOW COPYING OF DEFAULTS <== 0
SUBTTL Edit History
;VERSION 1
;1 Creation.
;2 Allow blank and stand-alone comment lines, and begin edit history.
;3 Default FIELD command properly, and check COBOL IDs for good syntax.
;VERSION 2
;66 IF THE VALUE CLAUSE IF GIVEN AFTER THE LENGTH COMMAND AND
; CONTAINS A STRING LONGER THAN THE SPECIFIED LENGTH, THE FIELD
; LENGTH IS INCREASED, BUT NEITHER THE RECORD DESCRIPTION NOR
; THE SUMMARY RECORD ARE FIXED.
;74 TFR.MAC DOES NOT LIKE THE FORM FEEDS IN EDIT FILES THAT SPAN
; MORE THAN ONE PAGE. THIS IS A PROBLEM (?) WITH USING THE
; COMMND JSYS FOR READING FILES. MAKE IT WORK BY CHECKING ON
; COMMND JSYS ERRORS FOR A FORM FEED, ERASING IT, AND REPARSING.
;75 INCLUDE IN THE RECORD DESCRIPTION FILE, A TABLE WHICH
; CORRESPONDS FIELD NAMES TO FIELD NUMBERS IN THE FOLLOWING MANNER:
; FIELD FOOBAR-THIS-IS --> 10 FN-FOOBAR-THIS-IS PIC S9(6) COMP VALUE 20.
;76 ADD THE FIELD NUMBER TO THE SUMMARY FILE OUTPUT.
;102 ADD A CANADIAN DATE DD/MM/YY.
;103 OUTPUT JSYS ERROR MESSAGE WHEN AVAILABLE SINCE TFR ERROR
; MESSAGES SOMETIMES MASK THE REAL PROBLEM
;107 INCLUDE ALL INFORMATION IN SUMMARY FILE.
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
MAXFLD==<STRING-HDRWRD>/FLDLEN ;MAX # OF FIELDS / FORM
;**;[3] Insert after MAXFLD DZN 3-Nov-77
CIDCLN==30 ;[3] COBOL ID CHARACTER LENGTH
FORMFD=14 ;[74]FORM FEED
SPACE=40 ;[74]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
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
%SWSIZ==1B15 ;SAW SIZE COMMAND
%FLBTS==-1^!<%TTYIN+%SWERL+%SWFRM> ;FIELD DEPEND. BITS
%FLBTS==%FLBTS^!<%SWOUT+%SWSUM+%SWREC+%SWSIZ>
REMARK FLAG BITS FOR F (FIELD DEPENDENT)
%SWFLD==1B6 ;CLEARED WEN REQD CMMDS GIVEN
%SWLEN==1B7 ;SAW LENGTH
%SWPOS==1B10 ;SAW POSITION.
%SWLRN==1B11 ;SAW RANGE
%SWURN==1B12 ;SAW UPPER RANGE
%SWFIL==1B13 ;FILL SEEN FOR THIS FIELD
%SWVAL==1B14 ;SAW VALUE THIS FIELD
REMARK FLAG BITS IN F USED FOR CLASS DETERMINATION
%MAALP==1B15 ;ALPHA SEEN
%MANUM==1B16 ;NUMERIC SEEN
DEFINE TAB(STR,ENT),<
IFDEF ENT,< XWD [ASCIZ !STR!],ENT>
IFNDEF ENT,< XWD [ASCIZ !STR (UNIMP)!],[HRROI A,[ASCIZ !? UNIMPLIMENTED COMMAND !]
CALL CMDERR
RET] >
>
DEFINE ERROR(MSG,INST<JRST .+1>)
< JRST [HRROI A,[ASCIZ !?MSG!]
CALL CMDERR
INST]
>
;[103] START
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]
>
;[103] END
DEFINE WARN(MSG,INST<JRST .+1>)
< JRST [HRROI A,[ASCIZ !%'MSG!]
CALL CMDWRN
INST]
>
DEFINE INFO(MSG,INST<JRST .+1>)
< JRST [HRROI A,[ASCIZ ![MSG]!]
TXNE F,%TTYIN
CALL CMDWRN
INST]
>
DEFINE CKERR
< TXNE A,CM%NOP >
DEFINE FMSG(JFN,MSG,DATA,TERM<0>,CR,LENG)
< ..N..==0
IFNB <MSG>,<
IRPC MSG,<..N..==..N..+1>
MOVE A,JFN
HRROI B,[ASCIZ \MSG\]
MOVNI C,..N..
SOUT
ERCAL ERRPC >
IFNB <DATA>,<
MOVE A,JFN
IFDEF DATA,<
IFG <DATA-17>,< HRROI B,DATA>
IFLE <DATA-17>,< HRRO B,DATA> >;END IFDEF DATA
IFNDEF DATA,< HRROI B,DATA> ;ASSUME A WORD AS YET UNSEEN
IFB <LENG>,< SETZ C,>
IFNB <LENG>,< MOVE C,LENG>
MOVEI D,TERM
SOUT
ERCAL ERRPC >
IFNB <CR>,<
MOVNI C,2
HRROI B,[ASCIZ/
/]
SOUT
ERCAL ERRPC >
>
D10==^D10
D11==^D11
D13==^D13
D15==^D15
D16==^D16
D0==0
D1==1
D2==2
D3==3
D4==4
M1==777777
OPDEF EXTEND [123000,,000000]
OPDEF MOVSLJ [016000,,000000]
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
*
;**;[2] Delete @SALL statement DZN 21-Oct-77
REMARK PTR .TAG ,LN,BT,OFFSET
PTRGEN ;GEN POINTERS
CTAB1: CTAB1E-.-1,,CTAB1E-.-1 ;LENGTH,,LENGTH
TAB <ERROR-LINE>,CMERRM
TAB <FORM>,CMFORM
TAB <OUTPUT-FILE>,CMOUTF
TAB <RECORD-DESCRIPTION-FILE>,CMREC
TAB <SUMMARY-FILE>,CMSUMM ; SUMMARY FILE SPEC.
TAB <TERMINALS-ALLOWED>,CMTERM
CTAB1E:
CTAB2: CTAB2E-.-1,,CTAB2E-.-1
TAB <A>,CMALPH ;=ALPHABETIC
TAB <A-N>,CMAN ;APHNUMERIC
TAB <ALPHABETIC>,CMALPH
TAB <ALPHANUMERIC>,CMAN ;ALPHANUMERIC
REMARK TAB <BLINKING>,CMBLNK
TAB <DATE>,CMDATE
TAB <EXIT>,CMEXIT
TAB <FIELD>,CMFLD
TAB <FILLER>,CMFILL
TAB <FULL-FIELD>,CMFULL ;FULL FIELD REQD.
TAB <LEADING-ZEROS>,CZERO ;ZERO FILL NUMERIC
TAB <LENGTH>,CMLENG
TAB <LOWER-RANGE>,CMLOWR
TAB <MASTER-DUPE>,CMMAST
TAB <MONEY>,CMMONY
TAB <NO-DUPE>,CMNODP ;UNDUPPED FIELD
TAB <NO-LEADING-ZEROS>,CBLANK ;BLANK FILLED NUMERICS.
TAB <NO-SPACES>,CNOSPACE ;SPACES ILLEGAL IN ALPHABETIC FIELD
TAB <NUMERIC>,CMNUMR
TAB <OPTIONAL>,CMOPTN ;NOT REQUIRED
TAB <POSITION>,CMPOSI
TAB <PREVIOUS-DUPE>,CMPREV
TAB <PROTECTED>,CMPROT
TAB <REQUIRED>,CMREQU
REMARK TAB <REVERSE-VIDEO>,CMREVS
TAB <SECTION>,CMSECT
REMARK TAB <SIZE>,CMSIZE ;SIZE OF SCREEN
REMARK TAB <SKIP>,CMSKIP
TAB <SOCIAL-SECURITY-NUMBER>,CMSOCI
TAB <SPACES>,CSPACE ;SPACES LEGAL INALPHABETIC FIELDS.
TAB <UNPROTECTED>,CMUPT
TAB <UPPER-RANGE>,CMUPRR
TAB <VALUE>,CMVALU
TAB <YES-NO>,CMYN
CTAB2E: ;END OF FIELD TABLE
TABLE2: TAB2ND-.-1,,TAB2ND-.-1
TAB <BOTTOM>,D0 ;0=BOTTOM
TAB <TOP>,D1 ;1=TOP OF FORM
TAB2ND:
TABLE3: TAB3ND-.-1,,TAB3ND-.-1
TAB <CANADA>,%DATCA ;[102] ADD CANADIAN DATE SPEC
;[102] WHICH IS DDMMYY
TAB <DASH>,%DATDA
TAB <DEC>,%DATDE
TAB <JULIAN>,%DATJU
TAB <MILITARY>,%DATMI
TAB <SLASH>,%DATSL
TAB3ND:
TRMTAB: TRMTBE-.-1,,TRMTBE-.-1
TAB <ALL>,M1 ; ALL TERMINAL TYPES
REMARK TAB <GT40>,D13 ; GT40
; TAB <VT05>,D10 ; VT05
TAB <VT50H>,D11 ; VT50 H (CURSOR ADDRESSING)
TAB <VT100>,D16 ; VT100 (ONLY 132 MODE FOR NOW)
TAB <VT52>,D15 ; VT52
REMARK TAB <VT61>,<UNSUPPORTED>
REMARK TAB <VT71>,<UNSUPPORTED>
TRMTBE:
TRMSIZ: ;SIZE OF TERMINAL SCREENS
REMARK [# OF LINES ,, # OF COLUMNS]
0 ;0
0 ;1
0 ;2
0 ;3
0 ;4
0 ;5
0 ;6
0 ;7
0 ;8
0 ;9
^D20,,^D72 ;10 = VT05
^D12,,^D80 ;11 = VT50H
0 ;12
^D30,,^D80 ;13 = GT40/GT42
0 ;14
^D24,,^D80 ;15 = VT52
^D24,,^D132 ;16 = VT100 IN 132 MODE
DEFINP: ;DEFAULT INPUT FILE-SPECS
GJ%OLD+GJ%CFM+GJ%MSG ;FLAGS,,GEN#
.PRIIN,,.PRIOU ;JFNS
0 ;DEVICE
0 ;DIRECTORY
0 ;FILENAME
IFN SHORTX,<
POINT 7,[ASCIZ !FRM!]
>
IFE SHORTX,<
POINT 7,[ASCIZ !FORM-SPEC!] ;EXT
>
0 ;PROTECTION
0 ;ACCOUNT
0 ;JFN
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
FDBN2C: FLDDB. .CMNUM,CM%SDH,^D10,<DECIMAL NUMBER OR>,2,FDBCFM
FDBN.C: FLDDB. .CMNUM,CM%SDH,^D10,<SECTION NUMBER (1 TO 28)>,,FDBCFM
FDBQST: FLDDB. .CMQST,,0,,,FDBTXT
FDBCFM: FLDDB. .CMCFM ;CONFIRM
FDBINI: FLDDB. .CMINI
FDBTRM: FLDDB. .CMKEY,,TRMTAB,,ALL
;**;[2] Change @FDBCM1 DZN 21-Oct-77
FDBCM1: FLDDB. (.CMKEY,,CTAB1,<form-wide command;>,,FDBCMA)
FDBCMA: FLDDB. (.CMKEY,,CTAB2,<field command;>)
FDBCMB: FLDDB. (.CMKEY,,CTAB1,<form-wide command;>)
FDBCM2: FLDDB. (.CMKEY,,CTAB2,<field command;>,,FDBCMB)
FDBNUM: FLDDB. .CMNUM,,^D10
FDBOUF: FLDDB. .CMFIL
FDBTXT: FLDDB. .CMTXT,,,<QUOTED STRING>
FDBDAT: FLDDB. .CMKEY,,TABLE3,,<SLASH>
FDBERL: FLDDB. .CMKEY,,TABLE2,<LINE TO USE FOR ERRORS OR>,BOTTOM,FDBERX
FDBERX: FLDDB. .CMNUM,CM%SDH,^D10
;**;[3] Change @FDBCOB DZN 3-Nov-77
FDBCOB: FLDDB. (.CMTXT,CM%SDH,,<COBOL variable name>)
FDBFLD: <FLD (.CMTXT,CM%FNC)>!CM%HPP!CM%DPP!CM%SDH
0
POINT 7,[ASCIZ /COBOL variable name/]
POINT 7,DEFFNM ;[3] FLDDB. ONLY TAKES TEXT, NOT A POINTER
FDBFLN: FLDDB. .CMNUM,,12,<FIELD LENGTH>
FDBLIN: FLDDB. .CMNUM,,12,<LINE NUMBER OF FIELD>
FDBCOL: FLDDB. .CMNUM,,12,<COLUMN NUMBER WHERE FIELD BEGINS>
FDBMXL: FLDDB. .CMNUM,,12,<MAX LENGTH OF SCREEN>
FDBMXC: FLDDB. .CMNUM,,12,<MAX NUMBER OF COLUMNS ON SCREEN>
SUBTTL MAIN-LINE CODE.
TFR::
RESET
ERCAL ERRPC
MOVE P,[IOWD 100,STACK] ;INIT STACK
SETZB F,PRM ;ZERO FLAG REGS.
SETZM ALLSEC ;[107]INITIALIZE THE SECTION TABLE
SETZM TOTLEN ;[107]INITIALIZE TOTAL LENGTH COMPUTATION.
MOVEI CFLD,DEFFLD ;PTR TO DEFAULTS
MOVE T,CURFLD
CALL GETINF ;GET INPUT FILE JFN
HRLZ T,INPJFN ;SET UP CSB
HRR T,OUTJFN
MOVEM T,CSB+.CMIOJ ;JFN'S
;AND OPEN FILE IF NEEDED.
NXTCMD: ;GET NXT CMD
CALL CMDINI ;INIT FUNCTION
REMARK TEST FOR END OF FILE
MOVE A,INPJFN ;INPUT JFN
GTSTS ;GET STATUS
TXNE B,GS%EOF ;EOF ?
JRST CMEOF ;FAKE EXIT CMD.
REPARS:
SETZ ARG, ;USED FOR ARGS IN COMMANDS
MOVEI A,CSB ;SETUP FOR COMND
MOVE B,CMDPTR ;CURRENT COMMAND LIST (FDBCM1/2)
MOVE P,[IOWD 100,STACK] ;INIT STACK
AOS LINENM ;UP LINE NUMBER
AOS FLDDSP ;ADD 1 TO FLD DISPLACEMENT
COMND
ERCAL ERRPC ;INDICATE ERRORS
CKERR ;LEGAL COMMAND ?
JRST [LDB A,[POINT 7,TEXT,6] ;[74]IF THIS ERROR OCCURED
CAIN A,FORMFD ;[74] BECAUSE OF A FORMFEED
JRST [MOVEI A,SPACE ;[74] THEN REPLACE IT
DPB A,[POINT 7,TEXT,6] ;[74] WITH A SPACE AND
JRST REPARS] ;[74] TRY AGAIN
ERROR <AMBIGUOUS OR UNDEFINED COMMAND>,<JRST NXTCMD>
] ;[74] ELSE FLAG AN ERROR.
HRRZ B,(B)
CALL (B) ;DO COMMAND
JRST NXTCMD ;GO FOR ANOTHER
SUBTTL SECOND LEVEL ROUTINES
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
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
HRROI A,[ASCIZ !ON LINE !]
PSOUT
MOVEI A,.PRIOU
MOVE B,LINENM ;GET LINE NUMBER
MOVEI C,^D10 ;IN DECIMAL
NOUT
ERCAL ERRPC ;JUST INDICATE ERRORS
SKIPN CURFLD ;SKIP IF GOT ANY FIELDS
JRST SKIPFL ;SKIP FELD MESSAGE
TMSG <; FIELD >
HRROI B,NMFLD ;NAME OF FIELD
MOVEI A,.PRIOU
SETZB C,D ;TERMINATE ON NULL
SOUT
ERCAL ERRPC
TMSG < + >
MOVEI A,.PRIOU
MOVE B,FLDDSP ;DISPLAC. FROM FIELD
MOVEI C,^D10 ;DECIMAL
NOUT
ERCAL ERRPC
SKIPFL: ;SKIP FELD 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 TE LAST MSG LINE.
REMARK FALL INTO CRLF
CRLF:
HRROI A,[ASCIZ !
!]
PSOUT
RET ;RETURN
GETINF: ; ;DEB
HRROI A,[ASCIZ !
FORM SPECIFICATION FILE: !]
PSOUT
MOVEI A,DEFINP ;INPUT DEFAULTS
SETZ B, ;NO STRING
GTJFN
ERJMP [CALL ERRNCT ;ERROR - DONT COUNT IT
JRST GETINF] ;TRY AGAIN
MOVEM A,INPJFN
DVCHR ;SEE IF TTY
ERCAL ERRPC
SETZ C,
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 OPEN ;GO OPEN FILE
TXO F,%TTYIN ;INDICATE TTY INPUT
MOVE T,INPJFN ;SAME INPUT
MOVEM T,OUTJFN ; AND OUTPUT IF TTY
ORI T1,OF%WR ; ALSO WRITE ACCESS
OPEN:
MOVE A,INPJFN ;OPEN FILE
MOVE B,T1 ;GET FLAGS
OPENF
ERJMP [CALL ERRNCT ;ERROR - DONT COUNT TILL FILE OPEN
JRST GETINF] ;RETRY ON ERRORS
TXNN F,%TTYIN ;ON TTY
RET ;NO-RETURN
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:
HRROI A,[ASCIZ !LOG COMMANDS IN FILE: !]
PSOUT
MOVE T,[GJ%FOU+GJ%CFM+GJ%MSG]
MOVEM T,DEFINP+.GJGEN
MOVEI A,DEFINP
SETZ B,
GTJFN
ERJMP [CALL ERR
JRST GETLOG]
MOVEM A,LOGJFN ;SAVE LOG JFN
MOVE B,[OF%WR+7B5] ;SACII OUTPUT
OPENF
ERJMP [CALL ERR
JRST GETLOG]
CALL CRLF
RET
ERRPC: ;ERROR AND PC MESSAGE
TMSG <? ERROR AT PC >
MOVEI A,.PRIOU
HRRZ B,(P)
SOJ B, ;CALL ADDR - 1 = PC
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
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
MOVEI C,ATOMLN ;LENGTH OF BUFFER
MOVE A,[POINT 7,ATOM] ;SOURCE
MOVSI B,(POINT 7,0) ;DEST IN T
HRR B,T
SETZB T,D ;TEMPS
TXZ F,%MAALP+%MANUM ;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!
CAIL T,"0" ;NUMERIC?
CAILE T,"9"
JRST MANN
TXO F,%MANUM
JRST MAX
MANN:
CAIL T,"A"
CAILE T,"Z"
JRST MANA
TXO F,%MAALP
JRST MAX
MANA:
TXO F,%MAALP+%MANUM
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
CMEOF: ;END OF FILE
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 + LENGTH REQUIRED>,<TXNE F,%TTYIN
RET ;YES
JRST .+1> ;NO
TXNN F,%SWFRM ;FORM NAME SEEN ?
ERROR <FORM NAME MUST BE SPECIFIED>,<TXNE F,%TTYIN
RET
JRST .+1>
CALL CMDEND ;LOG CMD IF TTY
CALL POSTCK ;POST-CHECK LAST FIELD FOR ERRORS
REMARK MOVE FORM NAME TO THE STRING AREA.
HRROI A,NMFORM
HRRO B,.STR
SETZB D,C ;TERMINATE ON NULL ONLY
DPB B,.FORM
SIN
ERCAL ERRPC
CALL ADJB ;ADJ BYTE PTR
MOVE T,ERRCNT
JUMPE T,NOERRS ;NO ERRORS
HRROI A,[ASCIZ !
? !]
PSOUT
MOVEI A,.PRIOU
MOVE B,T
MOVEI C,^D10
NOUT
ERCAL ERRPC
HRROI A,[ASCIZ ! ERRORS DETECTED!]
PSOUT
JRST COMEND ;GO TO END
NOERRS:
CALL PUTREC ;PUT RECORD DESCRIPTION
CALL PUTSUM ; AND SUMMARY FILE
REMARK MAPOUT GETS RID OF DATA PAGES
CALL MAPOUT ;MAP OUTPUT PAGES
COMEND: ;COMMON ENDING
CALL CLOSES ;DO CLOSES
HALTF
POSTCK: ;POST-CHECK LAST FIELD
MOVE T,.PARAM ;GET PARAM PTR
ADD T,CFLD ;OFFSET
DPB PRM,T ;STORE PARAMS
CAIN CFLD,DEFFLD ;AT DEFAULT
JRST NNDEF ;YES - NO FIELD NAME
REMARK SAVE THE OFFSET INTO THE DATA RECORD
MOVE T,.OFFST ;COMPUTE POINTER
ADD T,CFLD
MOVE T1,OFFSET ;GET CURRENT OFFSET
DPB T1,T ;SAVE IT
MOVE T1,MAXLEN ;GET FIELD LENGTH
MOVE T,.LENG ;GET FIELD LENGTH
ADD T,CFLD
DPB T1,T
ADDM T1,OFFSET ;ADD TO TOTAL OFFSET
REMARK SAVE FIELD NAME IN STRINGS.
DEBUG0:
MOVE T1,.FIELD ;SAVE FLD-NAME PT
ADD T1,CFLD
HRROI A,NMFLD ;FROM FIELD NAME
HRRO B,.STR ;TO STRINGS
SETZB D,C ;END ON NULL
DPB B,T1 ;SAVE ADDR IN DATA BLOCK
SIN
ERCAL ERRPC
CALL ADJB ;FIX PTR
NNDEF:
TXNN F,%SWLRN ;LOWER RANGE ?
JRST NNLR ;NO
MOVE T,.STR
MOVE C,.LRANG
ADD C,CFLD
DPB T,C
MOVE A,LNLWR ;LENGTH OF LOWER RANGE FIELD
CAMLE A,MAXLEN ;[66]IF LONGER THAN THIS LENGTH
MOVE A,MAXLEN ;[66] THEN USE FIELD LENGTH
MOVEI B,NMLWR ;POINTER TO IT
HRLI B,(POINT 7,0)
CALL XTENDX ;MOVE IT TO STRING AREA
NNLR:
TXNN F,%SWURN ;SAW UPPER
JRST NNUR ;NO
MOVE T,.STR
MOVE C,.URANG
ADD C,CFLD
DPB T,C
MOVE A,LNUPR ;LENGTH OF UPPER RANGE
CAMLE A,MAXLEN ;[66]IF LONGER THAN THIS LENGTH
MOVE A,MAXLEN ;[66] THEN USE FIELD LENGTH
MOVEI B,NMUPR ;POINTER TO IT
HRLI B,(POINT 7,0)
CALL XTENDX ;MOVE IT TO STRING AREA
NNUR:
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 THIS LENGTH IS GREATER THAN FIELD LENGTH
MOVE A,MAXLEN ; THEN USE FIELD LENGTH
PUSH P,A ;SAVE VALUE FOR MOVE IN CASE OF CHANGE
TXNE PRM,%NUMER ;IF THIS FIELD IS NUMERIC
MOVE A,MAXLEN ; THEN IT WILL GET MAX LENGTH TREATMENT
MOVE T1,.NUMRD ;BUILD OF ADDRESS FOR VALUE LENGTH.
ADD T1,CFLD
DPB A,T1 ;DEPOSIT LENGTH
POP P,A ;RESTORE VALUE FOR MOVE
MOVE T1,.STR ;NEXT STRING WILL GO HERE.
MOVE T,.VALUE ;MAKE ADDRESS OF VALUE FOR THIS FIELD
ADD T,CFLD ; OFFSET IT
DPB T1,T ;DEPOSIT STRING ADDRESS IN VALUE POINTER.
CALL XTENDX ;MOVE THE STRING.
RET
MAPOUT: ;MAP OUTPUT PAGES
TXNN F,%SWOUT ;SAW OUTPUT COMMAND?
RET ;NO
REMARK MAP OUT THE FIELD DATA BLOCKS
SKIPG T,CURFLD ;ANY FIELDS?
RET ;NONE
DPB T,.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
IMULI T,FLDLEN ;#WORDS USED
ADDI T,2 ; PLUS HEADER WORDS
MOVE T2,T ;SAVE WORD COUNT
ADDI T2,777 ;ROUND UP
ANDI T2,777000 ; TO PAGE BOUNDARY
SOJ T, ;MINUS ONE FOR WORD 0
LSH T,-^D9 ;SHIFT OFF NON-PAGE BITS
MOVE ARG,T ;SAVE FOR LATER
HRRZ T,.STR ;GET NEW PTR
HRRZI T1,STRING ;AND OLD
SUB T,T1 ;NUMB WORDS USED
ADD T2,T ;GRAND TOTAL
SOJ T, ;- WORD 0
LSH T,-^D9 ;GET PAGES
DPB ARG,.DATPG ;NUMB DATA PAGES - 1
DPB T,.STRPG ;NUMB STRG PAGES -1
MOVE A,[.FHSLF,,<DATA>_<-^D9>] ;PROCESS,,FIRST-PAGE
HRLZ B,OUTJFN ;JFN,,PAGE-NUMBER
SKIPE C,ARG ;LOAD C, SKIP IF JUST ONE PAGE
TXO C,PM%CNT ;REP COUNT PRESENT
AOJ C,
PMAP
ERCAL ERRPC
REMARK WRITE OUT THE STRING PAGES
MOVE A,[.FHSLF,,<STRING>_<-^D9>] ;PAGE PTR
HRLZ B,OUTJFN ;OUTJFN,,0
HRLI C,0
ADD B,C ;OUTJFN,,PAGES+1
SKIPE C,T ;MORE THAN ONE PAGE
TXO C,PM%CNT ;YES
AOJ C,
PMAP ;DO IT
ERCAL ERRPC
REMARK UPDATE THE END OF FILE PTR AND BYTE SIZE.
MOVE A,OUTJFN ;GET JFN
HRLI A,400000+.FBBYV
MOVE B,[FB%BSZ]
MOVE C,[^D36B11] ;36 BITS/BYTE
CHFDB
ERCAL ERRPC
HRLI A,.FBSIZ ;EOF POINTER
SETO B, ;ALL BITS
MOVE C,T2 ;NEW BYTE PTR
CHFDB
ERCAL ERRPC
RET
LOGTTY: ;LOG CMD ON TTY
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
RET
CLOSES:
SETO A,
CLOSF ;CLOSE EVERYTHING
ERCAL ERRPC ;ERROR
RET
CMDEND: ;LOG CMD IF TTY
PUSH P,B ;SAVE COMND DATA
MOVEI A,CSB
MOVEI B,FDBCFM ;CONFIRM
COMND
ERCAL ERRPC
JRST NXPUSH
CMDLOG:
PUSH P,B
NXPUSH:
TXNE F,%TTYIN
CALL LOGTTY ;LOG CMD IF TTY
POP P,B ;RESTORE COMND DATA
RET
SUBTTL XTENDX - EXTEND A RANGE FIELD AND FILL WITH RIGHT THING
OPDEF EXTEND [123000,,000000]
OPDEF MOVSLJ [016000,,000000]
OPDEF MOVSRJ [017000,,000000]
XTENDX:
MOVE C,.LENG
ADD C,CFLD ;FORM LENGTH PTR
LDB D,C ;.LENGTH PTR
MOVE T,.STR ;STRING PTR
HRLI T,(POINT 7,0)
XTENDD: ;;DEBUG BREAK POINT
TXNN PRM,%NUMER ;NUMERIC ?
JRST XTENDA ;NO
TXNE PRM,%DATE+%SSN ;IF DATE OR SSN THEN
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 .STR PTR
RET ;AND RETURN
SUBTTL COMMAND ROUTINES (WITHOUT EXIT)
CMALPH: ;ALPH TYP FIELD
TXNE PRM,%DATE
ERROR <DATE FIELD CAN NOT BE ALPHA>,RET
TXNE PRM,%MONEY
ERROR <MONEY FIELD CAN NOT BE ALPHA>,RET
TXNE PRM,%SSN
ERROR <SOCIAL SECURITY FIELD CAN NOT BE ALPHA>,RET
CALL CMDEND
ICMALP: ;INTERNAL CALL TO COMMAND
TXZE PRM,%NUMER ;ALREADY NUMERIC
WARN <REDEFINED FROM NUMERIC TO ALPHA>
TXO PRM,%ALPHA
CALL CKSTNG
RET
CMNUMR: ;NUMERIC FIELD
TXNN PRM,%DATE
JRST ..D1
LDB T,.SUBTP ;DATE SUB-TYPE
JRST .+1(T) ;BR TABLE
JRST ICMNUM
JRST ..D1E
JRST ICMNUM
JRST ..D1E
JRST ICMNUM
..D1E:
ERROR <THIS TYPE OF DATE FIELD CAN NOT BE NUMERIC>,RET
..D1:
TXNE PRM,%YN
ERROR <YES-NO FIELD CAN NOT BE NUMERIC>,RET
CALL CMDEND
ICMNUM: ;INTERNAL CALL TO COMMAND
TXZE PRM,%ALPHA ;SEE IF ALPHA
WARN <REDEFINED FROM ALPHA TO NUMERIC>
TXO PRM,%NUMER
CALL CKSTNG
RET
CMAN: ;A-NUMERIC
TXNN PRM,%DATE
JRST ..D2
LDB T,.SUBTP
JRST .+1(T)
JRST ..D2E
JRST ICMAN
JRST ..D2E
JRST ICMAN
JRST ..D2E
..D2E:
ERROR <THIS TYPE OF DATE FIELD CAN NOT BE ALPHA-NUMERIC>,RET
..D2:
TXNE PRM,%MONEY
ERROR <MONEY FIELDS CAN NOT BE ALPHA-NUMERIC>,RET
TXNE PRM,%SSN
ERROR <SOCIAL SECURITY FIELD CAN NOT BE ALPPHA-NUMERIC>,RET
CALL CMDEND
ICMAN:
TXZE PRM,%ALPHA ;ALPHA?
WARN <REDEFINED FROM ALPHA TO APHANUMERIC>
TXZE PRM,%NUMER
WARN <REDEFINED FROM NUMERIC TO ALPHANUMERIC>
RET
CMERRM: ;ERROR MESSAGE LINE NUMBER
MOVEI A,CSB
MOVEI B,FDBERL ;GET A LINE NUMBER
COMND
ERCAL ERRPC
CKERR
ERROR <INVALID ARGUEMENT FOR ERROR-LINE COMMAND>,RET
HRLI C,0 ;SEE IF SPECIAL COMMAND
CAIE C,FDBERX ;SKIP IF NUMBER
HRRZ B,(B) ;GET EQUIVELENT NUMBER
CALL CMDEND
TXOE F,%SWERL ;SAW ERR-LINE
WARN <ERROR-LINE REDEFINED>
DPB B,.ERRNM
RET
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,^D255
CAIG B,0
ERROR <RANGE FOR LENGTH COMMAND IS 1 TO 255>,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 ..L1 ;NO - SKIP THIS CHECK
CAME B,MAXLEN ;NEW LENGTH ?
WARN <LENGTH REDEFINED> ;YES - GIVE WARNING
..L1: ;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>
RET
CMFILL: ;GET FILL CHARACTER
MOVE T,.FILLR
ADD T,CFLD
MOVEI A,CSB
MOVEI B,FDBQST ;GET TEXT
COMND
ERCAL ERRPC
CALL CMDEND
LDB T1,[POINT 7,ATOM,6]
SKIPE T1
SUBI T1,40
TXOE F,%SWFIL ;FILL SEEN
WARN <FILL CHARACTER REDEFINED>
DPB T1,T
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.
;**;[3] Change @CMFORM DZN 6-Nov-77
CMFORM: MOVEI A,CSB ;[3] READ THE FORM NAME
MOVEI B,FDBCOB ;[3] ..
CALL CMCOB ;[3] IN COBOL VARIABLE NAME FORMAT
RET ;[3] BAD ID--CMCOB PRINTED THE MESSAGE
CALL CMDEND ;[3] FINISH THE LINE AND LOG IT
TXOE F,%SWFRM ;[3] REMEMBER THAT WE SAW THE NAME
WARN <FORM name redefined.> ;[3] BUT ALSO CHECK IF REDEFINING
MOVEI T,NMFORM ;FORM NAME PTR
CALL MOVATM ;SAVE NAME
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.
;**;[3] Change @CMFLD DZN 6-Nov-77
CMFLD: TXNE F,%SWFLD ;[3] ALL REQUIRED COMMANDS GIVEN?
ERROR <POSITION and LENGTH missing for current field--command ignored.>,RET
DMOVE A,[6 ;[3] MOVE "FIELD-" TO DEFAULT FIELD NAME
POINT 7,[ASCII /FIELD-/]] ;[3] ..
DMOVE D,[6 ;[3] ..
POINT 7,DEFFNM] ;[3] ..
EXTEND A,[MOVSLJ] ;[3] ..
JFCL ;[3] SHOULD NEVER FAIL
SETZ A, ;[3] APPEND NEXT FIELD NUMBER TO NAME
MOVE B,CURFLD ;[3] ..
ADDI B,1 ;[3] NEXT FIELD #, NOT THIS ONE
MOVEI D,CIDCLN-6 ;[3] LEN OF COBOL ID - LEN OF "FIELD-"
EXTEND A,[CVTBDO "0"] ;[3] THE REAL WORK
JFCL ;[3] SHOULD NEVER FAIL
SETZ A, ;[3] DEPOSIT A NUL TERMINATOR FOR COMND
IDPB A,T ;[3] ..
MOVEI A,CSB ;[3] PARSE THE FIELD NAME
MOVEI B,FDBFLD ;[3] ..
CALL CMCOB ;[3] WITH SPECIAL-PURPOSE ROUTINE
RET ;[3] BAD ID--CMCOB PRINTED THE MESSAGE
CALL CMDEND ;[3] PARSE THE END-OF-LINE AND LOG LINE
MOVEI T,FDBCM2 ;[3] SEEN AT LEAST 1 FIELD COMMAND SO
MOVEM T,CMDPTR ;[3] 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 FIILD CMD
MOVEI T,NRFLDS ;SET # REQD CMDS
MOVEM T,NUMREQ
SETZM LNUPR
SETZM LNLWR
SETZM LNVAL
SETZM LNFLD
SETZM MAXLEN
;WE'RE NOW READY TO INITIALIZE THE NEW FIELD.
AOS T,CURFLD ;[3] ADVANCE TO THE NEXT FIELD NUMBER
CAILE T,MAXFLD ;[3] BUT NOT TOO FAR
ERROR <Too many FIELDs specified.>,RET ;[3] ..
CAIN CFLD,DEFFLD ;@DEFAULT FIELD ?
MOVEI CFLD,DATA-FLDLEN ;POINT TO DATA AREA
ADDI CFLD,FLDLEN ;GO TO NEXT FLD
MOVEI T,NMFLD ;FIELD NAME PTR
CALL MOVATM
MOVEM D,LNFLD ;SAVE LENGTH
IFN DEFAULT,< ;[3] COPY DEFAULT FIELD PARAMS
MOVE A,CFLD ;[3] COPY TO THE CURRENT FIELD AREA
HRLI A,DEFFLD ;[3] FROM THE DEFAULT FIELD SPECS
MOVEI B,FLDLEN-1(A) ;[3] UNTIL CURRENT FIELD AREA IS FULL
BLT A,(B) ;[3] ..
>
RET
SUBTTL PARSE A COBOL VARIABLE NAME
;THIS ROUTINE READS IN AND VERIFIES A COBOL VARIABLE NAME. TO BE VALID,
;IT MUST CONSIST OF ONLY "A".."Z", "0".."9", OR "-", MUST NOT BEGIN OR END WITH
;"-", MUST NOT CONSIST OF JUST DIGITS, AND MUST BE AT MOST 30 CHARACTERS LONG.
;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 ;[3] READ IN THE TEXT LINE
ERCAL ERRPC ;[3] GO PRINT WHICH ERROR CAUSED THIS
MOVE B,[POINT 7,ATOM] ;[3] BEGIN SCANNING AT THE STRING
MOVX C,<-ATOMLN,,0> ;[3] MAKING SURE NOT TO GO TOO FAR
SETZ D, ;[3] CLEAR FLAGS AND COUNT OF GOOD CHARS
CMCOB1: ILDB T,B ;[3] READ NEXT CHARACTER
CAIL T,"a" ;[3] CHECK FOR LEGAL LOWER CASE
CAILE T,"z" ;[3] ..
JRST .+2 ;[3] NOT--CHECK FURTHER
JRST [SUBI T,"a"-"A" ;[3] YES--CONVERT TO UPPER CASE
DPB T,B ;[3] AND STORE BACK
TXZ D,1B0 ;[3] LAST CHAR NOT "-"
TXO D,1B1 ;[3] LEGAL NON-DIGIT, LEGAL CHAR
ADDI D,1 ;[3] COUNT TOWARD 30 CHARACTER MAX
JRST CMCOB2] ;[3] CONTINUE LOOPING FOR CHARS
CAIL T,"A" ;[3] CHECK FOR LEGAL UPPER CASE
CAILE T,"Z" ;[3] ..
JRST .+2 ;[3] NOT--CHECK FURTHER
JRST [TXZ D,1B0 ;[3] YES--LAST CHAR NOT "-"
TXO D,1B1 ;[3] LEGAL NON-DIGIT, LEGAL CHAR
ADDI D,1 ;[3] COUNT TOWARD 30 CHARACTER MAX
JRST CMCOB2] ;[3] CONTINUE LOOPING FOR CHARS
CAIL T,"0" ;[3] CHECK FOR LEGAL DIGIT
CAILE T,"9" ;[3] ..
JRST .+2 ;[3] NOT--CHECK FURTHER
JRST [TXZ D,1B0 ;[3] YES--LAST CHAR NOT "-"
ADDI D,1 ;[3] COUNT TOWARD 30 CHARACTER MAX
JRST CMCOB2] ;[3] CONTINUE LOOPING FOR CHARS
CAIN T,"-" ;[3] CHECK FOR HYPHEN
JRST [TXNN D,777777 ;[3] YES--CHECK FOR FIRST CHAR OF ID
JRST CMCER1 ;[3] FIRST CHAR--ID IS BAD
TXO D,1B0!1B1 ;[3] LAST CHAR WAS "-", LEGAL NON-DIGIT
ADDI D,1 ;[3] COUNT TOWARD 30 CHARACTER MAX
JRST CMCOB2] ;[3] CONTINUE LOOPING FOR CHARS
; ..
; ..
CAIE T," " ;[3] CHECK FOR SPACES AND TABS
CAIN T," " ;[3] ..
JRST [TXNE D,777777 ;[3] YES--ID SEEN YET?
JRST CMCOB3 ;[3] YES--VALID TERMINATION--GO CHECK RESULTS
JRST CMCOB2] ;[3] NO--SKIP THESE 'TIL WE HIT THE ID
CAIE T,"!" ;[3] NOW CHECK FOR VALID TERMINATORS
CAIN T,";" ;[3] ..
JRST CMCOB3 ;[3] AND GO CHECK RESULTS IF SO
JUMPE T,CMCOB3 ;[3] ..
JRST CMCER2 ;[3] ALL THE REST IS JUNK
CMCOB2: AOBJN C,CMCOB1 ;[3] LOOP FOR NEXT CHAR 'TIL NO MORE
IBP B
CMCOB3:
SETZ T,
DPB T,B
TXNE D,1B0 ;[3] ID ENDED WITH "-"?
ERROR <COBOL variable may not end with '-'.>,RET
TXNN D,1B1 ;[3] ALL DIGITS?
ERROR <COBOL variable may not contain all digits.>,RET
TXNN D,777777 ;[3] ANYTHING AT ALL?!
ERROR <No COBOL variable specified.>,RET
MOVEI D,(D) ;[3] NOW GET COUNT OF CHARACTERS IN ID
CAILE D,^D30 ;[3] AND COMPARE AGAINST THE MAX
ERROR <COBOL variable may not be longer than 30 characters.>,RET
AOS (P) ;[3] AT LAST! A GOOD IDENTIFIER!
RET ;[3] SO GIVE SKIP RETURN
CMCER1: ERROR <COBOL variable may not begin with '-'.>,RET
CMCER2: ERROR <COBOL variable may contain only letters, digits, or '-'.>,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
CMPREV: ;PREVIOUS-DUPE ATTRIB.
CALL CMDEND
TXZE PRM,%MSDUP ;SEE IF MAST-DUPE
WARN <REDEFINED FROM MASTER-DUPE TO PREVIOUS-DUPE>
TXO PRM,%PRDUP ;SET PREV-DUPE
RET
CMNODP: ;UNDUPPED
CALL CMDEND
TXZ PRM,%DUPE
RET
CMPROT: ;PROTECTED ATTRIB.
CALL CMDEND
TXO PRM,%PROT ;SET PROTECTED
RET
CMUPT: ;NOT PROTECTED
CALL CMDEND
TXZ PRM,%PROT
RET
CMOPTN:
CALL CMDEND
TXZ PRM,%REQD
RET
CMREQU: ;REQUIRED PARAM.
CALL CMDEND
TXO PRM,%REQD ;SET REQUIRED
RET
;[50] INSERT CODE TO ADD THE ZERO OR BLANK FILLED NUMERICS
CBLANK: ;REWRITE NUMERICS WITH BLANK FILL
CALL CMDEND
TXZ PRM,%ZERBL ;SET TO 0, BLANK FILL.
RET
CZERO: ;REWRITE NUMERICS WITH ZERO FILL
CALL CMDEND
TXO PRM,%ZERBL ;SET TO 1, ZERO FILL.
RET
;[57] INSERT CODE TO ADD THE SPACE TO LEGAL ALPHABETICS
CSPACE: ;ALLOW SPACES IN ALPHABETICS
CALL CMDEND
TXO PRM,%SPACE ;SET TO 1, SPACES ALLOWED
RET
CNOSPACE: ;DO NOT ALLOW SPACES IN ALPHABETICS
CALL CMDEND
TXZ PRM,%SPACE ;SET TO 0, NO SPACES ALLOWED.
CMSECT: ;MEMBER OF SECTION
MOVE T,CFLD
ADD T,.SECTN ;SECTION PTR
LDB ARG,T ;GET SECTIONS
CMSECL:
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
JRST CMSECD ;DONE
CAIG B,^D28 ;RANGE CHECK
CAIG B,0
ERROR <SECTION NUMBERS MUST BE IN RANGE 1 TO 28>,RET
MOVEI T1,1 ;A BIT
SOJ B, ;SECTION-1
LSH T1,(B) ;1_<SESCTION-1>
ORM T1,ALLSEC ;[107]INDICATE THIS SECTION USED.
OR ARG,T1 ;SET THIS SECTION
JRST CMSECL
CMSECD: ;DONE
CALL CMDLOG ;DONE (FINALLY)
;CONFIRM ALREADY DONE !!
DPB ARG,T ;STORE IT
RET ; AND RETURN
CMDATE: ;DATE FIELD
MOVEI A,CSB
MOVEI B,FDBDAT ;GET TYPE OF DATE
COMND
ERCAL ERRPC
CKERR
ERROR <TYPE OF DATE FIELD MUST BE SPECIFIED>,RET
CALL CMDEND
TXZE PRM,%TYPE ;TYPE DEFINED YET?
WARN <FIELD REDEFINED TO BE A DATE FIELD>
TXO PRM,%DATE ;SET DATE TYPE
HRRZ B,(B) ;GET DATE NUMBER
DPB B,.SUBTP ;SAVE SUB-TYPE CODE
JRST .+1(B) ;BRANCH TABLE OF DATES
JRST SETL8
JRST SETL9
JRST SETL5
JRST SETL9
JRST SETL8
JRST SETL8 ;[102]CANADIAN DATE DD/MM/YY
SETL5:
MOVEI B,5
CALL ICMLEN
JRST SETN
SETL8:
MOVEI B,^D6
CALL ICMLEN
JRST SETN
SETL9:
MOVEI B,^D7
CALL ICMLEN
JRST SETAN
SETA: ;SET ALPHABETIC
CALL ICMALP
CALL CKSTNG
RET
SETN: ;SET NUMERIC ATTRIB
CALL ICMNUM
CALL CKSTNG
RET
SETAN: ;SET ALPHA-NUMER
CALL ICMAN
CALL CKSTNG
RET
TELLEN:
TXNN F,%TTYIN
JRST ..20
PUSH P,B ;SAVE NUMBER
FMSG <[.PRIOU]>,<[LENGTH SET TO >
MOVEI A,.PRIOU
POP P,B ;GET NUMBER
MOVEI C,^D10
NOUT
ERCAL ERRPC
PUSH P,B ;AGAIN
FMSG <[.PRIOU]>,<]
>
POP P,B
..20:
RET
CMMONY: ;MONEY FIELD
MOVEI A,CSB
MOVEI B,FDBN2C
COMND
ERCAL ERRPC
CKERR ;UNPARSABLE
ERROR <NUMBER REQUIRED IN MONEY COMMAND>,RET
HRLI C,0
CAIN C,FDBCFM ;CONFIRMATION ?
JRST [MOVEI B,2 ;DEFAULT TO 2
JRST WASNUL]
CAIG B,7 ;RANGE CHECK
CAIGE B,0
ERROR <RANGE IS 0 TO 7 FOR MONEY COMMAND>,RET
WASNUL: ;NULL LENGTH
TXNN F,%SWLEN ;LENGTH SEEN
JRST NOLENG
MOVE ARG,MAXLEN ;GET HIGHEST LENGTH SO FAR.
CAMGE ARG,B ;LEN > #DEC.PLACES?
ERROR <LENGTH TOO SMALL FOR MONEY FIELD>,RET
NOLENG: ;LENGTH NOT SEEN YET
CAIE C,FDBCFM ;ALREADY CONFIRMED ?
CALL CMDEND ;NO - END OF COMMAND
TXZE PRM,%TYPE+%SUB
WARN <FIELD TYPE REDEFINED TO BE MONEY>
TXO PRM,%MONEY
DPB B,.SUBTP ;SUBTYPE+DEC. PLACES
CALL SETN
RET
CMPOSI: ;POSITION OF FIELD ON SCREEN
MOVEI A,CSB
MOVEI B,FDBLIN
COMND
ERCAL ERRPC
CKERR
ERROR <NUMBER REQUIRED FOR LINE NUMBER IN POSITION COMMAND>,RET
CAIG B,^D63 ;RANGE CHECK
CAIG B,0
ERROR <RANGE IS 1 TO 63 FOR LINE NUMBER IN POSITION COMMAND>,RET
MOVE ARG,B ;SAVE LINE NUMBER
MOVEI B,FDBCOL
COMND
ERCAL ERRPC
CKERR
ERROR <NUMBER REQUIRED FOR COLUMN NUMBER IN POSITION COMMAND>,RET
CAIG B,^D255
CAIG B,0
ERROR <RANGE IS 1 TO 255 FOR COLUMN NUMBER IN POSITION COMMAND>,RET
CALL CMDEND
TXNN F,%SWPOS
CALL DCRRQD
TXOE F,%SWPOS
WARN <POSITION REDEFINED>
MOVE T,.COLM
ADD T,CFLD
DPB B,T
MOVE T,.LINE
ADD T,CFLD
DPB ARG,T
RET
CMSIZE: ;SET SIZE OF SCREEN
REMARK SIZE LINES COLUMNS
TXOE F,%SWSIZ ;SAW SIZE YET
ERROR <SIZE OF SCREEN CAN NOT BE REDEFINED>,RET
MOVEI A,CSB
MOVEI B,FDBMXL
COMND
CKERR
ERROR <NUMBER REQUIRED FOR LINE NUMBER>,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
CKERR
ERROR <NUMBER REQUIRED FOR COLUMN NUMBER>,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
RET
CMSOCI: ;SOCIAL SECURITY NUMBER
CALL CMDEND
TXZE PRM,%TYPE+%SUB
WARN <FIELD REDEFINED TO BE SOCIAL-SECURITY-NUMBER>
TXO PRM,%SSN
MOVEI B,^D9
CALL ICMLEN
CALL SETN
RET
CMYN: ;YES-NO FIELD
CALL CMDEND
TXZE PRM,%TYPE+%SUB
WARN <FIELD REDEFINED TO BE A YES-NO FIELD>
TXO PRM,%YN
MOVEI B,^D1
CALL ICMLEN
CALL SETA
RET
CMLOWR: ;LOWER RANGE
CAIN CFLD,DEFFLD ;AT DEF FLD
ERROR <LOWER RANGE ILLEGAL IN DEFAULTS>,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 ;GEB LENGBH OF IBEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
CMUPRR: ;UPPER RANGE
CAIN CFLD,DEFFLD ;AT DEF FLD
ERROR <UPPER RANGE ILLEGAL IN DEFAULTS>,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 ;GEB LENGBH OF IBEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
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,FDBOUF
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
CMSUMM: ;SUMMARY-FILE SPEC
MOVE HLDJFN,SUMJFN
MOVEI T,DEFSUM
MOVEM T,CSB+.CMGJB
MOVEI A,CSB
MOVEI B,FDBOUF
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
RET
WARN <SUMMARY 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,FDBOUF
COMND
ERCAL ERRPC
CKERR
JERROR <FILE NAME REQUIRED IN RECORD-DESCRIPTION-FILE COMMAND>,RET
CALL CMDEND
MOVEM B,RECJFN
MOVEI T,NMRECF
CALL MOVATM
TXON F,%SWREC
RET
WARN <RECORD-DESCRIPTION FILE REDEFINED>
CALL RELJFN
RET
CMTERM: ;TERMINALS ALLOWED
MOVEI A,CSB
MOVEI B,FDBTRM
COMND
ERCAL ERRPC
CKERR
ERROR <INVALID TERMINAL TYPE SPECIFIED IN TERMINAL COMMAND>,RET
CALL CMDEND
LDB ARG,.TRMS ;GET TERMINAL ALLOWED
HRRZ B,(B) ;GET TERM NUMBER
MOVEI T,1 ;A BIT
LSH T,(B) ;SHIFT BITS
ORI T,400000 ;SAY WE HAVE RESTRICTIONS
OR ARG,T ;COMBINE WITH OTHER BITS
DPB ARG,.TRMS ;SAVE WHOLE THING
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 <STRING REQUIRED IN VALUE COMMAND>,RET
CALL CMDEND
MOVEI T,NMVAL
CALL MOVATM ;MOVE STRING
MOVEM D,LNVAL ;SAVE LENGTH
TXOE F,%SWVAL
WARN <VALUE REDEFINED>
REMARK SAVE TYPE BITS
MOVEI T,VALFLG
CALL CKCLAS ;ANY CLASS CONFLICTS ?
TXNE F,%SWLEN
JRST [CAMLE D,MAXLEN ;[66]IF VALUE IS LARGER THAN FIELD LENGTH
MOVE D,MAXLEN ;[66] THEN MAKE IT MAX LENGTH.
MOVEM D,LNVAL ;[66]INSURE THIS IS SET UP RIGHT.
RET] ;[66]RETURN
MOVE B,D ;GET LENGTH OF ITEM
CALL ICMLEN ;TELL USER + SET LENGTH
RET
ADJB: ;ADJUST PTR IN 'B'
TLNN B,760000 ;ONE OR NO BITS LEFT ?
AOJ B, ;MUST ADD ONE MORE WORD
TLZ B,770000 ;SET BYTES LEFT TO 0
TLO B,440000
AOJ B, ;ALL NEXT WORD IS AVAIL
MOVEM B,.STR
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 ;ED 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
CMFULL: ;FULL FIELD REQUIRED
CALL CMDEND
;**;[4] CHANGE @CMFULL STATEMENT DSB 31-JAN-78
;[4] TXO PRM,%FULL+%REQD ;FIELD IS REQD AND MUST BE FULL
TXO PRM,%FULL ;[4]FULL FIELD NOT IMPLICITLY REQUIRED.
RET
DCRRQD: ;DECREMENT NUMBER OF REQUIRED FELDS
SOSN NUMREQ ;ONE LESS REQIRED
TXZ F,%SWFLD ;NO MORE LEFT
RET ;DONE
REMARK CHECK INPUT VALUES FOR CONFLICTS WITH
REMARK EXISTING CLESS DEFINEITIONS.
CKCLAS:
MOVE T1,F ;GET FLAG BITS
AND T1,[%MANUM+%MAALP] ;GET ONLY THOSE NEEDED
MOVEM T1,@T ;SAVE AT C(T)
MOVE T1,F ;GET ALL FLAGS
TXNN PRM,%CLASS ;ANY CLASS BITS SET ?
RET ;NO - ALL IS OK
MOVN T,T1
TXNN T,%MAALP+%MANUM ;A/N DATA
JRST CONFX ;BAD !
TXNN T1,%MANUM ;DATA NUM?
JRST CKCALP ;NO
TXNN PRM,%NUMER
JRST CONFX
RET
CKCALP:
TXNN PRM,%ALPHA
JRST CONFX
RET
CONFX:
TXNE PRM,%NUMER ;NUMER
ERROR <DATA IS NOT NUMERIC>,RET
ERROR <DATA IS NOT ALPHABETIC>,RET
REMARK SEE IF CLASS CONFLICTS WITH THE THREE STRING VALUES
CKSTNG:
SETZ T1,
TXNE PRM,%ALPHA
TXO T1,%MAALP
TXNE PRM,%NUMER
TXO T1,%MANUM
TXNE PRM,%ALPHA
HRROI T2,[ASCIZ /ALPHABETIC/]
TXNE PRM,%NUMER
HRROI T2,[ASCIZ /NUMERIC/]
TXNN F,%SWVAL
JRST ..A1
MOVE T,VALFLG ;VALUE
AND T,T1
SKIPE T
JRST ..A1
TXNE PRM,%ALPHA
ERROR <VALUE IS NOT ALPHABETIC>,<JRST .+2>
ERROR <VALUE IS NOT NUMERIC>
..A1:
TXNN F,%SWLRN
JRST ..A2
MOVE T,LWRFLG
AND T,T1
SKIPE T
JRST ..A2
TXNE PRM,%ALPHA
ERROR <LOWER RANGE IS NOT ALPHABETIC>,<JRST .+2>
ERROR <LOWER RANGE IS NOT NUMERIC>
..A2:
TXNN F,%SWURN
JRST ..A3
MOVE T,UPRFLG
AND T,T1
SKIPE T
JRST ..A3
TXNE PRM,%ALPHA
ERROR <UPPER RANGE IS NOT ALPHABETIC>,<JRST .+2>
ERROR <UPPER RANGE IS NOT NUMERIC>
..A3: RET
SUBTTL CREATE RECORD DESCRIPTION FILE
PUTREC: ;RECORD DESCRIPTION
REMARK SEE IF RECORD DESCRIPTION IS DESIRED
TXNN F,%SWREC
RET ;NO
REMARK SETUP FILE
MOVE A,RECJFN
MOVE B,[OF%WR+7B5]
OPENF
ERJMP [CALL ERR
ERROR <RECORD DESCRIPTION FILE WILL NOT BE CREATED>,RET]
REMARK MAKE A HEADING
FMSG RECJFN,<************************************************************
>
FMSG RECJFN,<* RECORD DESCRIPTION OF FORM >,NMFORM ,,X
FMSG RECJFN,<************************************************************
>
REMARK SET UP TO DO EACH FIELD
SETZB ARG,T
MOVEI T2,DATA
REMARK DO THE FIELD BY FIELD STUFF
RECLUP:
CAML ARG,CURFLD ;DONE YET
;[75] RET ; YES
JRST PUTFNM ;[75]OUTPUT THE FIELD NUMBERS
MOVE T1,.FIELD
ADD T1,T2
LDB T,T1
FMSG RECJFN,< 10 >,T
;[107] COMPUTE TOTAL RECORD LENGTH
MOVE T1,.LENG
ADD T1,T2
LDB T,T1
ADDM T,TOTLEN
MOVE T1,.PARAM
ADD T1,T2
LDB PRM,T1 ;PARAMETERS
REMARK OUTPUT PICTURE OF ITEM.
FMSG RECJFN,<
PICTURE >
REMARK TEST FOR DATE. THESE GET SPECIAL PICTURES.
TXNN PRM,%DATE
JRST NPICDT
SETZ T,
LDB T,.SUBTP ;SUB-TYPE OF DATE
JRST .+1(T)
JRST PIC0
JRST PIC1
JRST PIC2
JRST PIC1
JRST PIC0
JRST PIC0 ;[102] CANADIAN DATE DD/MM/YY
PIC0:
FMSG RECJFN,<9(6>
JRST D7
PIC1:
FMSG RECJFN,<X(7>
JRST D7
PIC2:
FMSG RECJFN,<9(5>
JRST D7
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
LDB X,.SUBTP ;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 A,RECJFN
MOVE B,T
SUB B,X ;TOTAL-1-CENTS
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG RECJFN,<)>
NODOLR:
FMSG RECJFN,V;IMPLIED DECIMAL POINT
JUMPE X,NOCENT ;ANY CENTS ?
FMSG RECJFN,<9(>
MOVE A,RECJFN
MOVE B,X
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG RECJFN,<)>
NOCENT:
JRST D7ONLY ;DO DISP
NPICMN:
TXNN PRM,%NUMER
JRST $$30
FMSG RECJFN,<S9(>
$$30:
TXNN PRM,%ALPHA
JRST $$31
FMSG RECJFN,<A(>
$$31:
TXNE PRM,%ALPHA+%NUMER
JRST $$32
FMSG RECJFN,<X(>
$$32:
REMARK DECIDE ON A LENGTH AND PUT IT IN PICTURE CLAUSE
MOVE T1,.LENG
ADD T1,T2
SETZ T,
LDB T,T1 ;LENGTH ==> T
MOVE A,RECJFN
MOVE B,T
MOVEI C,^D10
NOUT
ERCAL ERRPC
REMARK DO DISPLAY-7 CONSTANT.
D7:
FMSG RECJFN,<)>,,,,1
D7ONLY:
FMSG RECJFN,< DISPLAY-7.
>
ADDI T2,FLDLEN
AOJA ARG,RECLUP
;[75] 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.
;
PUTFNM:
FMSG RECJFN,<
************************************************************
>
FMSG RECJFN,<* FIELD NUMBER TABLE OF FORM >,NMFORM ,,X
FMSG RECJFN,<************************************************************
>
SETZB ARG,T ;INITIALIZE TABLE INDEXES
MOVEI T2,DATA
FMSG RECJFN,<01 FN->,NMFORM
FMSG RECJFN,< COMPUTATIONAL.
>
;FOR EACH FIELD IN THE FORM
;DO--
FNMLP: CAML ARG,CURFLD ;IF PASSED ALL FIELDS THEN
RET ; WE ARE DONE
MOVE T1,.FIELD ; ELSE OUTPUT THE NEXT FIELD
ADD T1,T2
LDB T,T1
FMSG RECJFN,< 10 FN->,T
FMSG RECJFN,<
PICTURE S9(6) VALUE IS >
MOVE A,RECJFN
MOVEI B,1(ARG)
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG RECJFN,<.
>
ADDI T2,FLDLEN ;GO TO NEXT ENTRY IN THE TABLE
AOJA ARG,FNMLP ;AND CONTINUE
;END--
SUBTTL CREATE SUMMARY FILE
SALL
PUTSUM: ;SUMMARY FILE
MOVE A,SUMJFN ;GET SUMMARY FILE JFN
MOVE B,[OF%WR+7B5] ;OUTPUT, ASCII
OPENF ;DO OPEN
JERROR <SUMMARY FILE WILL NOT BE WRITTEN>,<CALL ERR
RET>
REMARK WRITE OUT HEADER INFO TO FILE
FMSG SUMJFN,< TRAFFIC-20 -- FORM SUMMARY
>
FMSG SUMJFN,<FORM :>,NMFORM,,X
TXNN F,%SWOUT ;SAW OUTPUT FILE ?
JRST $$14 ;NO
HRROI A,NMOUTF
MOVE B,OUTJFN
SETZ C,
JFNS
FMSG SUMJFN,<OUTPUT-FILE :>,NMOUTF,,X
$$14:
TXNN F,%SWSUM ;SAW SUMMARY FILE ?
JRST $$15
HRROI A,NMSUMF
MOVE B,SUMJFN
SETZ C,
JFNS
FMSG SUMJFN,<SUMMARY-FILE :>,NMSUMF,,X
$$15:
TXNN F,%SWREC ;SAW RECORD-DESC FILE ?
JRST $$16
HRROI A,NMRECF
MOVE B,RECJFN
SETZ C,
JFNS
FMSG SUMJFN,<RECORD-DESC-FILE:>,NMRECF,,X
$$16:
TXNN F,%SWERL ;SAW ERROR-LINE ?
JRST NOERLS ;NO
FMSG SUMJFN,<ERROR-LINE :>
SETZ B, ;GET NUMBER
LDB B,.ERRNM
JUMPE B,DSPBTM ;0 = BOTTOM
MOVE A,SUMJFN ;JFN FOR SUMMARY
MOVEI C,^D10 ;DECIMAL NUMBER
NOUT
ERCAL ERRPC
JRST NOBTM
DSPBTM:
FMSG SUMJFN,<BOTTOM>
NOBTM:
FMSG SUMJFN,<
>
;[107] PRINT A FEW MORE THINGS IN THE GENERAL SECTION
FMSG SUMJFN,<SECTIONS IN USE: >
MOVE T,ALLSEC
CALL SECOUT
FMSG SUMJFN,<SECTIONS NOT IS USE: >
MOVE T,[1777777777]
XOR T,ALLSEC
CALL SECOUT
FMSG SUMJFN,<TOTAL RECORD SIZE: >
MOVE A,SUMJFN
MOVE B,TOTLEN
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG SUMJFN,<
LAST FIELD NUMBER: >
MOVE A,SUMJFN
MOVEI C,^D10
MOVE B,CURFLD
NOUT
ERCAL ERRPC
FMSG SUMJFN,<
>
NOERLS: ;NO ERROR-LINE SEEN
REMARK DO SUMMARY FOR EACH FIELD DEFINED.
SETZ ARG,T ;ARG=COUNTER; T=WORK AREA
MOVEI T2,DATA ;T2 => DATA FIELDS
FLDLUP:
CAML ARG,CURFLD ;DONE ALL FIELDS YET ?
;ARG = FIELD COUNTER
JRST PRT3 ;[107]DO THE SECTION-FIELD OUTPUT.
MOVE T1,.FIELD ;GET FIELD PTR
ADD T1,T2 ; USING OUT NEW PTR
LDB T,T1 ;
FMSG SUMJFN,<
FIELD:>,T ;OUTPUT FIELD NAME
;[76] ADD THE FIELD NUMBER TO THE SUMMARY FILE OUTPUT
FMSG SUMJFN,< FIELD NUMBER: >
MOVE A,SUMJFN ;PREPARE TO OUTPUT THE NUMBER
MOVEI B,1(ARG) ; WITH THE NOUT JSYS
MOVEI C,^D10 ; BASE 10
NOUT
ERCAL ERRPC
FMSG SUMJFN,<
>
;[76] END
SETZ T,
MOVE T1,.LINE
ADD T1,T2
LDB T,T1
FMSG SUMJFN,<POSITION: >
MOVE A,SUMJFN
MOVE B,T
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG SUMJFN,<,>
MOVE A,SUMJFN
MOVEI C,^D10
SETZ T,
MOVE T1,.COLM
ADD T1,T2
LDB T,T1
MOVE B,T
NOUT
ERCAL ERRPC
FMSG SUMJFN,< LENGTH: >
SETZ T,
MOVE T1,.LENG
ADD T1,T2
LDB T,T1
MOVEM T,MAXLEN ;SAVE LENGTH THIS FIELD
MOVE A,SUMJFN
MOVE B,T
MOVEI C,^D10
NOUT
ERCAL ERRPC
REMARK SEE IF FILLER IS NON-SPACE
SETZ T,
MOVE T1,.FILLR
ADD T1,T2
LDB T,T1
JUMPE T,$$13 ;NULL FILLER
FMSG SUMJFN,< FILLER: ">
ADDI T," "
MOVE A,SUMJFN
MOVE B,T
BOUT
ERCAL ERRPC
FMSG SUMJFN,<">
$$13:
FMSG SUMJFN,<
>
REMARK DO VALUE - ATTRIBUTES - LOWER / UPPER RANGE
SETZB T,A
MOVE T1,.VALUE
ADD T1,T2
LDB T,T1 ;FIRST BYTE OF VALUE
MOVE A,(T) ; IN A
TLNN A,774000 ;FIRST BYTE = NULL ?
JRST $$12 ;YES - NO VALUE
FMSG SUMJFN,<VALUE: ">,T,,,MAXLEN
FMSG SUMJFN,<"
>
$$12:
REMARK DO ATTRIBUTES
SETZB T,PRM
MOVE T1,.PARAM
ADD T1,T2
LDB PRM,T1 ;GET PARAMS
JUMPE PRM,SKPATT ;NULL ? THEN SKIP IT.
FMSG SUMJFN,<ATTRIBUTES: >
;;TEST THE TYPE;;
TXNE PRM,%NUMER+%ALPHA ;IF IT IS ALPHA OR NUMER
JRST $$12A ; THEN OUTPUT THESE
; ELSE IT IS ALPHANUMERIC
FMSG SUMJFN,< ALPHANUMERIC>
JRST $$2
$$12A:
TXNN PRM,%NUMER ;NUMERIC
JRST $$1
FMSG SUMJFN,< NUMERIC>
TXNN PRM,%ZERBL ;IF NOT ZERO FILLED
JRST $$2 ; THEN GO ON
FMSG SUMJFN,< ZERO-FILLED>
JRST $$2
$$1:
TXNN PRM,%ALPHA ;ALPHA
JRST $$2
FMSG SUMJFN,< ALPHABETIC>
TXNN PRM,%SPACE ;IF SPACES ARE NOT ALLOWED
JRST $$1A ; THEN GO ON
FMSG SUMJFN,< ALLOW-SPACES>
JRST $$2
$$1A: FMSG SUMJFN,< NO-SPACES>
$$2:
TXNN PRM,%REQD
JRST $$2A
FMSG SUMJFN,< REQUIRED>
JRST $$3
$$2A: FMSG SUMJFN,< OPTIONAL>
$$3:
TXNN PRM,%FULL
JRST $$3A
FMSG SUMJFN,< FULL-FIELD>
JRST $$4
$$3A: FMSG SUMJFN,< NOT-FULL-FIELD>
$$4:
TXNN PRM,%PROT
JRST $$4A
FMSG SUMJFN,< PROTECTED>
JRST $$5
$$4A: FMSG SUMJFN,< UNPROTECTED>
$$5:
TXNN PRM,%YN
JRST $$6
FMSG SUMJFN,< YES-NO>
$$6:
TXNN PRM,%SSN
JRST $$7
FMSG SUMJFN,< SOCIAL-SECURITY-NUMBER>
$$7:
TXNN PRM,%MONEY
JRST SKPMNY
FMSG SUMJFN,< MONEY (>
SETZ B,
LDB B,.SUBTP ;=NUMBER OF PLACES
MOVE A,SUMJFN
MOVEI C,^D10
NOUT
ERCAL ERRPC
FMSG SUMJFN,< DEC. POSITIONS)>
SKPMNY:
REMARK DO DATE STUFF
TXNN PRM,%DATE
JRST SKPDAT
FMSG SUMJFN,< DATE->
SETZ B,
LDB B,.SUBTP
JRST .+1(B)
JRST PD0
JRST PD1
JRST PD2
JRST PD3
JRST PD4
JRST PD5 ;[102] CANADIAN DATE DD/MM/YY
PD0:
FMSG SUMJFN,<DASH>
JRST SKPDAT
PD1:
FMSG SUMJFN,<DEC>
JRST SKPDAT
PD2:
FMSG SUMJFN,<JULIAN>
JRST SKPDAT
PD3:
FMSG SUMJFN,<MILITARY>
JRST SKPDAT
PD4:
FMSG SUMJFN,<SLASH>
JRST SKPDAT
PD5: ;[102] CANADIAN DATE DD/MM/YY
FMSG SUMJFN,<CANADA> ;[102]
JRST SKPDAT ;[102]
SKPDAT:
TXNN PRM,%MSDUP
JRST $$8
FMSG SUMJFN,< MASTER-DUPE>
JRST $$9
$$8:
TXNN PRM,%PRDUP
JRST $$8A
FMSG SUMJFN,< PREVIOUS-DUPE>
JRST $$9
$$8A: FMSG SUMJFN,< NO-DUPE>
$$9:
FMSG SUMJFN,<
>
SKPATT:
REMARK DO SECTION STUFF
SETZ T, ;FOR SECTION BITS
MOVE T1,.SECTN
ADD T1,T2
LDB T,T1
REMARK TEST EACH BIT AND OUTPUT THE NUMBER IF IN THIS SECT.
JUMPE T,SKPSEC
FMSG SUMJFN,<SECTION:>
CALL SECOUT ;[107]OUTPUT THE SECTION
JRST SKPSEC ;[107] AND CONTINUE.
SECOUT: ;[107] SUBROUTINE CALL
MOVEI T1,1
SKIPA ;SKIP ROTATE FIRST TIME
ROTSEC:
LSH T,-1 ;LSH DOWN ONE BIT
JUMPE T,DONSEC ;DONE IF NO MORE
TRNN T,1 ;TEST LOW ORDER BIT
AOJA T1,ROTSEC ;ROTATE SECTIONS
MOVE A,SUMJFN
MOVEI B," "
BOUT
ERCAL ERRPC
MOVE B,T1
MOVEI C,^D10
NOUT
ERCAL ERRPC
AOJA T1,ROTSEC
DONSEC:
FMSG SUMJFN,<