Trailing-Edge
-
PDP-10 Archives
-
704rmsf2
-
10,7/rms10/rmssrc/utlenv.mac
There are 11 other files named utlenv.mac in the archive. Click here to see a list.
TITLE UTLENV - STATIC ENVIR CMDS AND THEIR SUPPORT ROUTINES
SUBTTL A. UDDIN
SEARCH RMSMAC,RMSINT
$PROLOG(UTL)
SZ%DRV==20 ;FOR CHANGE/DISP, MAX DATFLDS/CMD LINE
SZ%DDT==^d500
$IMPURE
$DATA (BUFSIZ) ;SIZE OF RECORD BUFFER
$DATA (BUFADR) ;PTR TO RECORD BUFFER
$DATA (CPOSIT) ;CURR POS FOR DATA FIELDS
$DATA (CSTYPE) ;CURR STRING DATA TYPE
$DATA (DDCURR) ;CURR ADDRESS IN PRIVATE SYMTAB
$DATA (DDTAB,SZ%DDT) ;SPACE FOR PRIVATE SYMTAB
$DATA (DEFFAB) ;ADDR OF FAB FOR A DEFINE FILE
$DATA (ISYMBP,2) ;STP FOR DISPLAY OF SYM NAME
$DATA (OUTFAB) ;ADDR OF FAB FOR REPORT FILE
$DATA (TTYFAB) ;ADDR OF FAB FOR TTY:
$DATA (VASZPT) ;SYMBOL IN RADIX50
$PURE
; FMT STATS FOR INFO COMMAND
;
INFAREA:[$FMT(,<-CA%STP,-CA%ASZ,BUCKET-SIZE=,-CA%NUM>)]
INFBKT: [$FMT(,<Current bucket at page ,-CA%NUM>)]
INFDAI: [$FMT(,<-CA%STP,-CA%ASZ,-CA%ASZ, ,at W,-CA%NUM>)]
INFDAS: [$FMT(,<-CA%STP,-CA%ASZ,-CA%ASZ, ,C,-CA%NUM, thru C,-CA%NUM>)]
INFDDD: [$FMT(,<DEFINE DATA default is ,-CA%ASZ, at ,-CA%NUM>)]
INFFIL: [$FMT(,<RMS file is ,-CA%ASZ>)]
INFFNO: [$FMT(,<RMS file is Not open>)]
INFKEY: [$FMT(,<-CA%STP,-CA%ASZ,-CA%NOCR>)]
INFKEG: [$FMT(,<-CA%ASZ, ,-CA%NOCR>)]
INFKA0: [$FMT(,</NOCHA+NODUP,-CA%NOCR>)]
INFKA1: [$FMT(,</NOCHA+DUP,-CA%NOCR>)]
INFKA2: [$FMT(,</CHA+NODUP,-CA%NOCR>)]
INFKA3: [$FMT(,</CHA+DUP,-CA%NOCR>)]
INFKDA: [$FMT(,</DAN:,-CA%ASZ,-CA%NOCR>)]
INFKDF: [$FMT(,</DAF:,-CA%NUM,-CA%NOCR>)]
INFKIA: [$FMT(,</IAN:,-CA%ASZ,-CA%NOCR>)]
INFKIF: [$FMT(,</IAF:,-CA%NUM,-CA%NOCR>)]
INFKRF: [$FMT(,<Current key-of-ref is ,-CA%NUM>)]
INFREC: [$FMT(,<Current record at ,-CA%RFA>)]
INFREP: [$FMT(,<Report file is ,-CA%ASZ>)]
DATTYP:
[ASCIZ/ASCII/]
[ASCIZ/EBCDIC/]
[ASCIZ/F-BYTES/]
[ASCIZ/SIXBIT/]
[ASCIZ/DECIMAL/]
[ASCIZ/OCTAL/]
[ASCIZ/FLOAT/]
BPWVEC: EXP 5,4,6 ;BYTES/WD BY STRING TYPE
KEYBSZ: EXP 7,9,6
$SCOPE (TOP-LEVEL)
$LREG (PB) ;PTR TO CURR RMS ARG BLK
SUBTTL PROCESS CLOSE COMMAND
$PROC (C.CLOSE)
;
; C.CLOSE = CLOSE THE RMS!REPORT FILE
;
; NOTES:
; CLOSE RMSFILE!REPORTFILE
$P (KEYW) ;PICK UP FIELD BEING DEFINED
CASES T1,MX%CLO
$CASE (CLO%RMS) ; RMS FILE
MOVE T5,UTLFLG ;CHECK IF FILE IS OPEN
TXZN T5,UT%FOP
ERRU(FNO) ;FILE NOT OPEN
$CALL CLORMS ;DO REAL WORK
RETT
$CASE (CLO%REP) ; REPORT FILE
MOVE T5,UTLFLG ;FIRST CHECK IF FILE IS OPEN
TXZN T5,UT%RFO
ERRU(FNO) ;FILE NOT OPEN
$CALL CLORPT ;DO REAL WORK
RETT ;DONE
$ENDPROC
$UTIL (CLORMS) ;CLOSE RMS FILE
$CALLB BK$PUT,<[0]> ;RELEASE BKT IF HAVE 1
$CALLB VR$CLEAN ;INSURE SCAN CMDS LEFT NOTHING AROUND
$FLAGZ (UTLFLG,UT%FOP) ;CLEAR FLAG
$CLOSE @FAB ;CLOSE THE RMS FILE
$CHKERR (?UTLCCF could not close file)
$CALL M.RMSF ;FINALLY FREE ALL MEM FOR _AB BLOCKS
RETURN
$ENDUTIL
$UTIL (CLORPT) ;CLOSE REPORT FILE
$CALL RP$PUT ;INSURE RPT BUFFER CLEAN
$CLOSE @OUTFAB
$CHKERR (?UTLCCF could not close file)
$FLAGZ (UTLFLG,UT%RFO)
$CALL M.REPF ;FREE ALL _AB BLOCKS FOR REP FILE
$COPY OUTFAB,TTYFAB ;RESTORE DEFAULT REPORT DEVICE
$COPY OUTRAB,TTYRAB
RETURN
$ENDUTIL
SUBTTL EXIT COMMAND
$PROC (C.EXIT)
;
; C.EXIT - EXIT TO MONITOR AFTER CLOSING ALL OPEN FILES
;
MOVE T5,UTLFLG ;GET STATUS FLAGS
TXNE T5,UT%FOP ;IS RMS FILE OPEN?
$CALL CLORMS ;YES, CLEAN UP
MOVE T5,UTLFLG ;GET STATUS FLAGS
TXNE T5,UT%RFO ;IS REPORT FILE OPEN?
$CALL CLORPT ;YES, CLEAN UP
IFN TOP$10,<EXIT 1,>
IFN TOP$20,<HALTF>
RETT
$ENTRY (SY.EXIT) ;RET TO EXEC
IFN TOP$10,<EXIT 1,>
IFN TOP$20,<HALTF>
RETT
$ENDPROC
SUBTTL PROCESS DEFINE COMMAND
$SCOPE (DEFINE-CMD)
$LREG (DD) ;PTR TO ENTRY IN (DDT-LIKE) SYMTAB
$LREG (UF) ;PTR TO CURR DAT FLD BEING DEFINED
$LREG (P1) ;MAY BE USED BY BOTTOM-LEVEL UTILS
$LREG (P2)
$LOCALS
$WORD (CAID) ;CURR AREA ID DURING DEF FILE
$WORD (DTPVAL) ;DAT TYP XB$ VALUE
$WORD (DUMDD,SZ%DD) ;USED WHEN DATFLD ALSO DEFINED AS KEY
$WORD (KAT) ;KEY ATTR ACCUMULATOR
$WORD (KREF) ;INCR BY DEF FIL TO SET REF OF XAB LIST
$WORD (LXAB) ;ADDR OF LAST XAB PROCESSED IN A LIST OF XAB'S
$WORD (SEGPTR) ;PTR OFFSET FROM XAB FOR CURR POS/SIZ
$ENDLOC
$PROC (C.DEFINE)
;
; C.DEFINE - PROCESS DEFINE CMD
;
; DEFINE AREA area-name (WITH BUCKET SIZE) n1
; DEFINE DATAFIELD datafield-name (WITH TYPE) ASCII!FILE-BYTES!SIXBIT (WITH LENGTH) n1 (STARTING AT BYTE) n2
; DEFINE KEY key-name (WITH SEGMENTS) segment-list
; DEFINE FILE file-name (WITH ORGANIZATION) [see DEFORG]
$EH (DEFABORT) ;CLEAN UP PARTIALLY DEF SYMS
SETZM DD ;INDIC NO SYMBOL DEFINED YET
$P (KEYW) ;PICKUP THE KEYWORD VAL
CASES T1,MX%DEF ;DISPATCH OFF TYPE OF BLK
$CASE (DEF%FIL) ; ** DEFINE A SKELETON FILE
$CALL INITAB,<FABINI> ;SETUP A FAB
MOVEM PB,DEFFAB ;SAVE IT'S ADDR
$CALL M.TOK ;ALC ROOM AND COPY FILE STRING
$STORE (T1,FNA,(PB)) ;PTR TO FILE SPEC
MOVEI T1,FB$PUT ;INDIC WRITE ACCESS
$STORE T1,FAC,(PB) ;PUT IT IN FAB
$CALL DEFORG ;REST OF CMD LINE IS FILE ORG DEPENDENT
$CREATE @DEFFAB ;PUT THE FILE ON DISK
$CHKERR (?UTLCDF could not DEFINE file)
$CLOSE @DEFFAB ;PERMANIZE IT
$CHKERR (?UTLCCF could not close file)
RETT ;** DONE
DEFABORT:
JUMPE DD,L$RETF ;NO SYMBOL ALLOC
MOVNI T1,SZ%DD ;GET SIZE OF ENTRY ALLOC
ADDM T1,DDCURR ;MOVE CURR PTR BACK OVER IT
RETF ;HAVE CLEANED UP
SUBTTL (RE)DEFINING NAMES
$CASE (DEF%DAT) ; ** DEFINE DATA FIELDS
$CALL ALCBLK,<FLDINI> ;DATA FIELD DESC INIT VALS
$CALL DEDTYP ;PROC DATA TYPE
MOVEM PB,UF ;ADJ TO KEY CONTEXT
SETZM PB ;DONE
$CALL DKDSWIT ;EAT DATFLD & KEY SWITS
RETT
$CASE (DEF%KEY) ; ** DEFINE KEY XAB. (ADDITIONAL INFO FOR CREATING AN ISAM FILE)
$CALL ALCBLK,<XKINI> ;SET UP XAB WITH INIT VALUES
MOVEM PB,SEGPTR(CF) ;INIT CURR SEG TO 1ST ONE
SOS SEGPTR(CF) ;DO "FULL" TEST AT TOP OF LOOP
;(AFTER SY.CHK SO PTR NOT CLOBBED)
DKS.LP:
$CALL SY.CHK,<DA$TYP> ;MUST BE DATAFLD (SET PB)
AOS T4,SEGPTR(CF) ;POINT TO NEXT SEGMENT
CAIL T4,8(PB) ;AT MOST EIGHT SEGS
ERRU (TMS) ;TOO MANY SEGS
MOVEM T2,XK.SEG(T4) ;SAME PTR TO SEG'S SYMBOL
$CALL P$COMMA ;MORE SEGMENTS?
JUMPT DKS.LP
$CALL DKDSWIT ;PROCESS SWITCHES
RETT
$CASE (DEF%ARE) ; DEFINE AREA (ALLOCATION) XAB.
$CALL ALCBLK,<XAINI> ;SET UP AREA XAB & INIT.
$P (NUM) ;FETCH BUCKET SIZE
$STORE T1,BKZ,(PB) ;PUT IT IN XAB
RETT
$CASF
ERRU(IUE) ;INTERNAL ERROR
$ENTRY (C.REDEF)
;
; C.REDEF - REDEF PROPS OF A DATA NAME
; NOTES:
; LOCATES SYMBOL BLK AND THEN MERGES WITH DEFINE
$CALL SY.GET ;PICK UP NAME TO REDEF
MOVEM T2,DD ;SAVE SYMBLK PTR
$FETCH T3,BID,(T1) ;GET BLK TYPE
CAIN T3,DA$TYP ;DAT BLK?
JRST L$CASE(DEF%DAT) ;YES
CAIE T3,XA$TYP ;MUST BE XAB
ERRU (IUE) ;OOPS
$FETCH T3,COD,(T1) ;GET TYPE OF XAB
CAIN T3,XB$KEY ;KEY?
JRST L$CASE(DEF%KEY) ;YES
CAIN T3,XB$ALL ;AREA?
JRST L$CASE(DEF%AR) ;YES
ERRU (IUE) ;OOPS
SUBTTL GENERAL SUBROUTINES TO SUPPORT DEFINE
$UTIL (ALCBLK,<INIBLK>)
;
; ALCBLK - SETUPS AN USER ARG BLK
; ARGUMENT:
; INIBLK = THE INITIAL-VALUE COPY OF BLK OR 0 (FOR TOKEN DET BLK)
; RETURNS:
; PB = PTR TO ALLOCATED BLK
$REG (IB,P1) ;PTR TO INIT ARGBLK
$REG (BSZ,P2) ;WDS IN BLK
MOVEI IB,@INIBLK(AP) ;MATER PTR TO INIT VAL BLK
JUMPN DD,ALBINI ;SYM ALR LOC, INIT IT
$CALL SY.STOR ;PUT IN TABLE IF NOT ALREADY THERE
JUMPF L$ERRU(NAD) ;NAME ALREADY DEFINED
MOVEM T1,DD ;PRESERVE DD SYMBLK PTR
ALBINI:
$FETCH (BSZ,BLN,(IB)) ;GET LEN OF ARGBLK NEEDED
CAIN IB,XKINI ;SPECIAL CASE?
ADDI BSZ,2+8 ;YES, ALC WDS FOR XK.IAP, XK.DAP & SEGS
SKIPE T1,DD.VAL(DD) ;ARGBLK ALREADY ALLOC?
$SKIP ;NO
$CALL M.ALC,<BSZ> ;ALLOC A BLK
$ENDIF
MOVEM T1,PB ;PRESERVE PTR TO BLK
MOVEM T1,DD.VAL(DD) ;SET VALUE OF SYMBOL TO ADDR OF ARGBLK
HRL T1,IB ;GET ADDR OF INIT VALS
ADDI BSZ,-1(PB) ;GET LAST WORD OF BLK
BLT T1,0(BSZ) ;COPY INIT VALS TO ALLOC BLK
RETURN
$ENDUTIL
SUBTTL ROUTINES TO SUPPORT DEFINE-FILE
$UTIL (DEFFXC)
;
; DEFFXC - CHK REC SIZE FOR FILES WITH FIXED FORMAT
;
$FETCH T1,RFM,(PB) ;GET REC FMT
CAIE T1,FB$FIX ;FIXED LEN RECS?
$SKIP ;YES
$FETCH T1,MRS,(PB) ;GET REC SIZE
JUMPE T1,L$ERRU(RSR) ;REC SIZ REQUIRED FOR FIXED R
$ENDIF
RETURN
$ENDUTIL
$UTIL (DEFORG)
;
; DEFORG - PARSE THE ORG DEPENDENT PART OF THE CMD LINE
; RETURNS:
; FIELDS IN FAB SET UP & xabs linked into chain
; NOTES:
; INDEXED (WITH KEYS) key-name-list
; RELATIVE (WITH MAX REC SIZE) N
; :
$CALL P$KEYW
JUMPF L$CASE(DFO%SEQ) ;NO ORGANIZATION. DEFAULTS TO SEQ.
CASES T1,MX%DFO ;FILE ORG CASES
$CASE (DFO%STR) ;STREAM ASCII
MOVEI T1,FB$STM ;INDIC TYPE OF SEQ FILE
$STORE T1,RFM,(PB) ;DONE
$CASE (DFO%LSA) ;LINE-SEQ
MOVEI T1,FB$LSA ;INDIC TYPE OF SEQ FILE
$STORE T1,RFM,(PB) ;DONE
; JRST L$CASE(DFO%SEQ) ;SET ORG TOO
$CASE (DFO%SEQ) ;SEQUENTIAL
MOVEI T1,FB$SEQ
$STORE T1,ORG,(PB)
$CALL DEFSWIT ;GET SWITCHES
$CALL DEFFXC ;CHK RFM VS. MRS
RETURN
$CASE (DFO%REL) ;RELATIVE
MOVEI T1,FB$REL
$STORE T1,ORG,(PB)
$P (NUM) ;REC SIZE REQUIRED
$STORE T1,MRS,(PB) ;PUT IT AWAY
$CALL DEFSWIT ;GET SWITCHES
RETURN
$CASE (DFO%IND) ;INDEX
MOVEI T1,FB$IDX
$STORE T1,ORG,(PB)
DEFKEY: ;PARSE KEYS OF THE FILE
SETOM DTPVAL(CF) ;INDIC BYTE SIZE NOT KNOWN YET
SETOM KREF(CF) ;INIT KEY-OF-REFERENCE
SETZM CAID(CF) ;DITTO AID (THEY START FROM 1)
$CALL SYMKEY ;SCAN FOR KEY NAME
$FETCH T2,FLG,(T1) ;CHECK FLG FIELD.
TXNE T2,XB$CHG ;CHANGE OPTION SPEC.?
ERRU (PKC) ;PRIM KEY CAN'T CHANGE
$STORE T1,XAB,(PB) ;STORE START OF XAB LIST IN FAB
DEFKLP:
MOVEM T1,LXAB(CF) ;REMEMBER ADDR OF LAST XAB
AOS T2,KREF(CF) ;SET REF FLD
$STORE T2,REF,(T1) ;...OF NEXT XAB IN LIST
$CALL DEKBSZ ;BIND SEGS TO KEY
$CALL DEFKAR ;PUTS ITS AREA IN LIST IF NECES
$CALL P$COMMA ;MORE IN THE LIST?
JUMPF L$IFX ;NO.
$CALL SYMKEY ;YES, SCAN FOR KEY NAME
MOVE T2,LXAB(CF) ;SET UP NXT FIELD
$STORE T1,NXT,(T2)
JRST DEFKLP
$ENDIF
$CALL DEFSWIT ;PROCESS FILE SWITCHES
$CALL DEFFXC ;CHK RFM VS. MRS
DFICHK:
$FETCH T5,BSZ,(PB) ;GET BYTE SIZE BACK
JUMPG T5,L$JUMP ;USER SPEC BYTE SIZE?
SKIPGE T1,DTPVAL(CF) ;NO, USE KEY DCL INFO IF POSS
MOVEI T1,XB$STG ;CANT, USE ASCII DEFAULT
MOVE T5,KEYBSZ(T1) ;SET FROM KEY DAT TYPE
$STORE T5,BSZ,(PB) ;PUT BSZ AWAY
$JUMP ;YES
SETOM T1 ;START WITH NULL DTP
CAIN T5,6 ;SIXBIT?
MOVEI T1,XB$SIX ;YES
CAIN T5,7 ;ASCII?
MOVEI T1,XB$STG ;YES
CAIN T5,9 ;EBCDIC?
MOVEI T1,XB$EBC ;YES
JUMPL T1,L$ERRU(IBS) ;BAD BYTE SIZE FOR IDX FILE
$ENDIF
SKIPGE DTPVAL(CF) ;SET YET?
MOVEM T1,DTPVAL(CF) ;NO, SO SET NOW
CAME T1,DTPVAL(CF) ;KEY SEG DAT TYPES MATCH BSZ?
ERRU (KIB) ;NO
$CALL DEFKTYP ;SET XB$DTP FOR EACH KEY
RETURN
$CASF
ERRI (ISC)
$UTIL (SYMKEY)
;
; SYMKEY - EAT TOKEN & VERIFY THAT IT IDENTIFIES KEY DESCRIPTOR
; RETURNS:
; T1 = PTR TO KEY DESC
$CALL SY.GET ;PICK UP XAB NAME FOR PRIMARY KEY
JUMPF L$ERRU(NNK,VASZPT) ;NAME NOT KNOWN
LOAD T3,UF.BID(T1) ;GET TYPE OF SYMBOL
CAIE T3,DA$TYP ;IS IT DATFLD?
$SKIP ;YES
SKIPN T1,UF.KEY(T1) ;ALSO KEY?
ERRU (WTN,VASZPT) ;NO
RETURN ;WITH PTR TO KEY DESC
$ENDIF
CAIE T3,XA$TYP ;XAB?
ERRU (WTN,VASZPT) ;NO, DEF NOT RIGHT TYPE
$FETCH T3,COD,(T1) ;GET TYPE OF XAB
CAIE T3,XB$KEY ;IS IT KEY?
ERRU (WTN,VASZPT) ;NO
RETURN ;WITH PTR TO KEY DESC
$ENDUTIL
$ENDUTIL
SUBTTL ROUTINES TO SUPPORT AREAS IN DEFINING IDX FILES
$UTIL (DEFKAR)
;
; DEFKAR - PUT KEY'S AREA XABS IN XAB CHAIN IF NECES
;
$REG (KX,P1) ;PTR TO CURR KEY XAB
MOVE KX,LXAB(CF) ;GET PTR TO CURR KEY
SKIPN T4,XK.IAP(KX) ;IS THERE AN AREA SPEC?
$SKIP ;YES
$CALL DEFARID ;SET AREA ID FROM AREA NAME
$STORE T1,IAN,(KX) ;PUT RET VAL AWAY
$ENDIF
SKIPN T4,XK.DAP(KX) ;IS THERE AN AREA SPEC?
$SKIP ;YES
$CALL DEFARID ;SET AREA ID FROM AREA NAME
$STORE T1,DAN,(KX) ;PUT RET VAL AWAY
$ENDIF
RETURN
$UTIL (DEFARID)
;
; DEFARID - SET OR FIND AREA ID OF AREA IN XABLIST
; ARGUMENTS:
; T4 = SYM PTR FOR AREA XAB BEING SCANNED
; RETURNS:
; T1 = AID TO PUT IN KEY
; NOTES:
; PUTS AREA IN XAB CHAIN IF NECES (UPDATING LXAB(CF))
MOVE T4,DD.VAL(T4) ;GET TO XAB ITSELF
$FETCH T3,XAB,(PB) ;GET HEAD OF LIST
DFARLP:
$FETCH T2,COD,(T3) ;SEE IF AREA
CAIE T2,XB$ALL ;IS IT?
$SKIP ;YES
$FETCH T1,AID,(T3) ;GET AID FLD IN CASE THIS 1 IT
CAMN T3,T4 ;IS PTR IN KEY MATCH 1 IN XAB CHAIN
RETURN ;YES, SO DONE -- RET WITH AID
$ENDIF
$FETCH T3,NXT,(T3) ;GET NEXT XAB
JUMPN T3,DFARLP ;CHK AGAIN
AOS T1,CAID(CF) ;INCR CURR AREA ID
$STORE T1,AID,(T4) ;PUT IT IN AREA XAB
MOVE T5,LXAB(CF) ;GET XAB CURR LAST
$STORE T4,NXT,(T5) ;PUT SEARCHED FOR AREA IN XAB CHAIN
MOVEM T4,LXAB(CF) ;MAKE IT LAST
RETURN
$ENDUTIL
$ENDUTIL
SUBTTL ROUTINES TO SUPPORT KEYS IN DEFINING IDX FILES
$UTIL (DEKBSZ)
;
; DEKBSZ - CHK/DET BYTE SIZE OF KEYS IN FILE
; NOTES:
; SCAN CURR KEY DESC'S SEGS, CHKING UF.TYP AGAINST DTPVAL(CF).
; IF DTPVAL NOT SET YET, SETS IF SEGMENT HAS EXPLIC STRING TYPE.
MOVE T4,LXAB(CF) ;GET PTR TO THE KEY XAB
DSB.LP:
SKIPN T3,XK.SEG(T4) ;GET SYM PTR FOR CURR SEG
RETURN ;ALL DONE IF 0
MOVE T5,DD.VAL(T3) ;PT TO DATFLD BLK
LOAD T2,UF.TYP(T5) ;GET DAT TYPE
SETOM T1 ;PRESUME NUMERIC
CAIN T2,DFT%SIX ;SIXBIT?
MOVEI T1,XB$SIX ;YES
CAIN T2,DFT%ASC ;ASCII?
MOVEI T1,XB$STG ;YES
CAIN T2,DFT%EBC ;EBCDIC?
MOVEI T1,XB$EBC ;YES
SKIPGE DTPVAL(CF) ;SET YET?
MOVEM T1,DTPVAL(CF) ;NO, SO SET NOW
CAME T1,DTPVAL(CF) ;MATCH KEYS (OR STILL UNSET)?
JUMPGE T1,L$ERRU(KIB) ;NO, ERR UNL CURR KEY NUMERIC OR F-BYTE
AOJA T4,DSB.LP ;BUMP PTR TO NEXT POS,SIZ,SEG
$ENDUTIL
$UTIL (DEFKTYP)
;
; DEFKTYP - SET XB$DTP AND SEGM DATA FOR EACH KEY OF FILE
;
$FETCH T3,XAB,(PB) ;GET HEAD OF LIST
MOVE T4,DTPVAL(CF) ;VAL TO SET EACH XB$DTP TO
DFKTLP:
$FETCH T1,COD,(T3) ;SEE IF KEY
CAIE T1,XB$KEY ;IS IT?
$SKIP ;YES, CHK FOR NUMERIC SEGS
$STORE T4,DTP,(T3) ;PUT AWAY KEY STRING TYPE
MOVEM T3,T5 ;DONT CLOB XAB PTR
DFNSLP: ;DEF NUM SEG
SKIPN T2,XK.SEG(T5) ;GET SYM PTR FOR CURR SEG
JRST L$IFX ;ALL DONE IF 0
MOVE T2,DD.VAL(T2) ;PT TO DATFLD BLK
LOAD T1,UF.TYP(T2) ;CHK IF NUMERIC
CAIL T1,DFT%INT ;IS IT?
SKIPA TAP,BPWVEC(T4) ;YES, CONV POS/SIZ TO BYTES
MOVEI TAP,1 ;NO
LOAD T1,UF.POS(T2) ;POS TO XAB
IMUL T1,TAP ;WD OFF * B/W = BYT OFFS
$STORE T1,POS,(T5) ;DONE
LOAD T1,UF.SIZ(T2) ;SIZE TO XAB
IMUL T1,TAP ;DITTO SIZE
$STORE T1,SIZ,(T5) ;DITTO, SIZE
AOJA T5,DFNSLP ;BUMP PTR TO NEXT POS,SIZ,SEG
$ENDIF
$FETCH T3,NXT,(T3) ;GET NEXT XAB
JUMPN T3,DFKTLP ;CHK AGAIN
RETURN
$ENDUTIL
SUBTTL ROUTINES FOR DEFINE-DATA
$UTIL (DEDTYP)
;
; DEDTYP - PROCESS DATA TYPE OF DEFINE-DATA
;
$P (KEYW) ;PICK UP DATA TYPE
STOR T1,UF.TYP(PB) ;STORE DATA TYPE
CAIGE T1,DFT%INT ;INTEGER?
JRST DEDSTR ;STR DATA TYPE
DEDBIN:
$CALL P$NUM ;WORD OFFSET SPECIFIED?
MOVE T3,CSTYPE ;GET STRING TYPE (INIT ASCII)
MOVE T3,BPWVEC(T3) ;GET BYTES PER WORD
JUMPT L$IFX ;POSIT SPECIFIED
MOVE T1,CPOSIT ;GET DEFAULT POS.
ADDI T1,-1(T3) ;SETUP FOR TRUNCATING DIVID
IDIV T1,T3 ;GET WD OFFSET
$ENDIF
STOR T1,UF.POS(PB) ;STORE WORD OFFSET
ADDI T1,1 ;HOP PAST IT
IMUL T1,T3 ;RECONVERT TO CHARS
MOVEM T1,CPOSIT
$COPY UF.SIZ(PB),I 1 ;# OF WDS IN FLD
RETURN
DEDSTR:
$P (NUM) ;GET THE LENGTH
STOR T1,UF.SIZ(PB) ;STORE SIZE
$CALL P$NUM ;CHK FOR POS
JUMPT L$IFX ;JUMP IF EXPLIC
LOAD T2,UF.TYP(PB) ;GET CURR TYPE
CAME T2,CSTYPE ;MATCH UP?
JRST DEDERR ;NO, USER MUST SPEC POS
MOVE T1,CPOSIT ;SET DEFAULT UP
$ENDIF
STOR T1,UF.POS(PB) ;PUT IT AWAY
$INCR T1,UF.SIZ(PB) ;HOP OVER CURR FIELD
MOVEM T1,CPOSIT ;PERMANIZE NEW DEFALUT
$COPY CSTYPE,UF.TYP(PB) ;UPDATE CURR STRING TYPE
RETURN
DEDERR: ;SUBROUTINES MAY ABORT TO HERE
SETZM 0(DD) ;CLEAR OUT ABORTED DEF
ERRU (NPS) ;TELL USER
$ENDUTIL
SUBTTL SWITCH PROCESSING FOR DEFINE
$UTIL (DEFSWIT)
;
; DEFSWIT -PARSES SWITCHES ON DEFINE FILE COMMAND.
;
; NOTES:
; EATRFV IS NOT USED BECAUSE OF CONFLICTS IN DISPLACEMENTS
; OF CERTAIN FIELDS IN RMS argblks AND RMS ENTITY DESCRIPTORS.
DEFSLP:
$CALL P$SWIT ;GET A SWITCH
JUMPF L$RET ; ALL DONE
CASES T1,MX%DFI
$CASE (DFI%BKS) ;BKT SIZE FOR AREA 0
$CALL P$NUM ;EAT IT
$STORE T1,BKS,(PB)
JRST DEFSLP
$CASE (DFI%BSZ) ;BYTE SIZE
$CALL P$NUM
CAILE T1,^D36 ;MUST BE <= 36
ERRU (IBS) ;invalid BYTE SIZE
$STORE T1,BSZ,(PB)
JRST DEFSLP
$CASE (DFI%MRS) ;MAX. RECORD SIZE
$CALL P$NUM
$STORE T1,MRS,(PB)
JRST DEFSLP
$CASE (DFI%RFM) ;RECORD FORMAT
$CALL P$KEYW
$STORE T1,RFM,(PB)
JRST DEFSLP ;CHK FOR ANOTHER SWITCH
$ENDUTIL
$UTIL (DKDSWIT)
;
; DKDSWIT - PROCESS SWITCHES ON DEFINE KEY & DATFLD CMDS
; NOTES:
; CHABVAL ISNT USED BECAUSE AREA-NAMES & THE FLAG SWITCHES ARE SPECIAL
SETZM KAT(CF) ;INIT KEY ATTRIBUTES ACCUM
DKDSLP:
$CALL P$SWIT ;PICK UP NEXT SWITCH
JUMPT L$IFX ;NO JUMP IF DONE
JUMPE PB,L$RET ;EXIT IF NO KEY XAB
MOVE T1,KAT(CF) ;GET KEY ATTR
$STORE T1,FLG,(PB) ;STORE FLAG FLD IN XAB
RETURN
$ENDIF
CAIN T1,KD%DIS ;OTHER THAN /DISP?
$SKIP ;YES, INIT KEY ENVIR IF NECES
JUMPN PB,L$IFX ;KEY XAB ALREADY SET UP
PUSH P,T1 ;KLUDGILY PRESERVE CASE VAR
$CALL ALCKEY ;ALC KEY DESC IF NECES (PB=0)
POP P,T1 ;RESTOR CASE VAR
$ENDIF
CASES T1,MX%KD ;DISPATCH
$CASE (KD%DIS) ;DATFLD SWITCH, DISPLAY FMT
$P (KEYW) ;PICK UP DEC/OCT
STOR T1,UF.TYP(UF) ;JUST EXPLODE INT TO DEC/OCT
JRST DKDSLP
$CASE (KD%KEY) ;ATTRIBUTE-LESS KEY
JRST DKDSLP ;SYNTAX TABS GUARAN NEXT CALL FAILS
$CASE (KD%DAN) ;DATA-AREA NAME
$CALL SY.CHK,<-XB$ALL> ;GET AREA NAME
MOVEM T2,XK.DAP(PB) ;STORE PTR TO AREA SYM
JRST DKDSLP ;CHK FOR MORE SWIT
$CASE (KD%DFL) ;DATA-FILL LIMIT
$CALL P$NUM ;GET THE LIMIT
$STORE T1,DFL,(PB)
JRST DKDSLP ;CHK FOR MORE SWIT
$CASE (KD%CHA) ;CHANGES ALLOWED?
$FLAGO KAT(CF),XB$CHG
JRST DKDSLP ;CHK FOR MORE SWIT
$CASE (KD%DUP) ;DUPLICATES-ALLOWED?
$FLAGO KAT(CF),XB$DUP
JRST DKDSLP ;CHK FOR MORE SWIT
$CASE (KD%IAN) ;INDEX-AREA NAME
$CALL SY.CHK,<-XB$ALL> ;GET AREA NAME
MOVEM T2,XK.IAP(PB) ;STORE PTR TO AREA SYM
JRST DKDSLP ;CHK FOR MORE SWIT
$CASE (KD%IFL) ;INDEX-FILL
$CALL P$NUM
$STORE T1,IFL,(PB)
JRST DKDSLP
$UTIL (ALCKEY)
;
; ALCKEY - ALC A KEY XAB/DESC
; NOTES:
; SETS UF.KEY IF ALLOC NECES
; SETS XK.SEG IF ALLOC NECES
SETZM DUMDD+DD.VAL(CF) ;KLUDGE, CAUSES ALCBLK TO ALC KEY XAB
MOVEM DD,DUMDD+DD.NAM(CF) ;DONT CLOB DATFLD'S DD
MOVEI DD,DUMDD(CF) ;INDIC SYMBOL ALREADY EXISTS
$CALL ALCBLK,<XKINI> ;ALLOC THE KEY XAB
MOVEM PB,UF.KEY(UF) ;PT DATFLD DESC AT KEY XAB
$COPY XK.SEG(PB),DUMDD+DD.NAM(CF),DD
;INDIC DATFLD IS 1ST (& ONLY) SEG OF KEY
RETURN
$ENDUTIL
$ENDUTIL
$ENDSCOPE(DEFINE)
SUBTTL PROCESS THE INFO CMD
$SCOPE (INFO)
$LREG (DD) ;SYMTAB PTR
$LREG (TYP) ;SYM TYP CODE
$PROC (C.INFO)
;
; C.INFO - LIST OUT THE CURRENT ENVIRONMENT
;
; SYNTAX:
; INFO ALL!AREAS!CONTEXT!DATAFIELDS!KEYS
MOVE PB,FAB ;SETUP FAB ADDR
$P (KEYW)
CASES T1,MX%INF
$CASE (INF%ALL)
$CALL INFCTX ;DISPLAY CONTEXT INFO
$CALL INFNAM,<[INF%DAT]>
$CALL INFNAM,<[INF%KEY]>
$CALL INFNAM,<[INF%AR]>
RETT
$CASE (INF%CON)
$CALL INFCTX
RETT
$CASE (INF%ARE)
$CASE (INF%KEY)
$CASE (INF%DAT)
MOVEM T1,T5 ;MAKE PASSABLE
$CALL INFNAM,<T5> ;PUT OUT APPROP 1
RETT
$ENDPROC
SUBTTL ROUTINES FOR INFO
$UTIL (INFCTX) ;DO WORK FOR INFO CONTEXT
MOVE T4,CSTYPE ;GET CURR TYPE
TT$OUT (INFDDD,<DATTYP(T4),CPOSIT>)
;DEF DATA DEFAULTS
MOVE T1,UTLFLG
TXNE T1,UT%FOP ;FILE OPEN?
$SKIP ;NO
TT$OUT (INFFNO) ;TELL USER
RETURN ;REST N/A
$ENDIF
MOVE T2,OUTFAB ;GET RPT FILE FAB PTR
$FETCH T1,FNA,(T2) ;GET FILNAM PTR
TT$OUT (INFREP,T1) ;PUT IT OUT
$FETCH T1,FNA,(PB) ;GET FILNAM PTR
TT$OUT (INFFIL,T1) ;PUT IT OUT
TT$OUT (INFREC,CU.REC) ;RFA OF CURR REC
$FETCH T1,ORG,(PB) ;GET FILE ORG
CAIE T1,FB$IDX ;IS IT INDEX?
RETURN ;NO, NO MORE CONTEXT
TT$OUT (INFBKT,CU.BKT) ;P# OF CURR BKT
TT$OUT (INFKRF,CU.KRF) ;CURR KEY OF REF
RETURN
$ENDUTIL
$UTIL (INFKAT)
;
; INFKAT - OUTPUT KEY ATTRIBUTES
;
PUSH P,PB ;SAVE ORIG ARGBLK PTR
INKSLP:
SKIPN T1,XK.SEG(PB) ;GET SEG NAME PTR
$SKIP ;STILL MORE
TT$OUT(INFKEG,0(T1)) ;PUT OUT SEG NAME,
AOJA PB,INKSLP ;GET NEXT SEG
$ENDIF
POP P,PB ;GET ORIG AB PTR BACK
$FETCH T1,FLG,(PB) ;GET KEY ATTR BITS
TT$OUT (INFKA0(T1)) ;PICK RIGHT ELEM OF VECT
SKIPN T1,XK.DAP(PB) ;GET AREA NAME PTR
$SKIP ;STILL MORE
TT$OUT(INFKDA,0(T1)) ;PUT OUT AREA NAME FROM SYM BLK
$ENDIF
SKIPN T1,XK.IAP(PB) ;GET AREA NAME PTR
$SKIP ;STILL MORE
TT$OUT(INFKIA,0(T1)) ;PUT OUT AREA NAME,
$ENDIF
$FETCH T1,DFL,(PB) ;GET DATA FILL
JUMPE T1,L$IFX ;PUT OUT ONLY IF NOT NULL
TT$OUT(INFKDF,T1) ;PUT OUT # OF WORDS
$ENDIF
$FETCH T1,IFL,(PB) ;GET DATA FILL
JUMPE T1,L$IFX ;PUT OUT ONLY IF NOT NULL
TT$OUT(INFKIF,T1) ;PUT OUT # OF WDS
$ENDIF
RETURN
$ENDUTIL
$UTIL (INFNAM,<TYPBLK>)
;
; INFNAM - SCAN PRIVATE SYM TAB, PICKING OUT INDICATED TYPE BLKS
; ARGUMENTS:
; TYPBLK = TYPE TO SCAN FOR
MOVE TYP,@TYPBLK(AP) ;GET ARGBLK TYPE
MOVEI DD,DDTAB ;PT TO BEGINNING OF PRIVATE SYMTAB
DUABLP:
SKIPN 0(DD) ;IS A SYM IN THIS SLOT?
JRST DUABLE ;NO, INCR PTR
MOVE PB,DD.VAL(DD) ;PT TO NAME'S ARGBLK
$FETCH T1,BID,(PB) ;DISPATCH ON THIS
CASES TYP,MX%INF
$CASE (INF%DAT)
CAIE T1,DA$TYP ;MATCH?
JRST DUABLE ;NO
$CALL SY.WID,<0(DD),[^D15]> ;RET SPT & TABS TO OUTPUT
DMOVEM T1,ISYMBP ;PT TO SYM TO OUTPUT
LOAD TAP,UF.POS(PB) ;GET POSITION
LOAD T4,UF.SIZ(PB) ;SIZ
LOAD T5,UF.TYP(PB) ;DATA TYPE CODE
CAIL T5,DFT%INT ;NUMERIC?
$SKIP ;NO
ADD T4,TAP ;POS+SIZ=END POS +1
SUBI T4,1 ;FIX IT
$CALLB TX$TOUT,<INFDAS,[ISYMBP],T3,DATTYP(T5),TAP,T4>
;PUT OUT "NAME TYPE"
JRST L$IFX
$NOSKIP
$CALLB TX$TOUT,<INFDAI,[ISYMBP],T3,DATTYP(T5),TAP>
;PUT OUT "NAME TYPE"
$ENDIF
JRST DUABLE
$CASE (INF%AR)
CAIE T1,XA$TYP ;MATCH?
JRST DUABLE ;NO
$FETCH T1,COD,(PB) ;CHK CODE TOO
CAIE T1,XB$ALL
JRST DUABLE ;NO MATCH
$CALL SY.WID,<0(DD),[^D15]> ;RET SPT & TABS TO OUTPUT
DMOVEM T1,ISYMBP ;PT TO SYM TO OUTPUT
$FETCH T2,BKZ,(PB) ;GET ITS BKT SIZE
TT$OUT (INFAREA,<[ISYMBP],T3,T2>)
JRST DUABLE
$CASE (INF%KEY)
CAIE T1,DA$TYP ;DATA FLD?
$SKIP ;YES
SKIPN PB,UF.KEY(PB) ;KEY AS WELL?
JRST DUABLE ;NO
JRST INKOUT ;YES
$ENDIF
CAIE T1,XA$TYP ;MATCH?
JRST DUABLE ;NO
$FETCH T1,COD,(PB) ;CHK CODE TOO
CAIE T1,XB$KEY
JRST DUABLE ;NO MATCH
INKOUT:
$CALL SY.WID,<0(DD),[^D15]> ;RET SPT & TABS TO OUTPUT
DMOVEM T1,ISYMBP ;PT TO SYM TO OUTPUT
TT$OUT (INFKEY,<[ISYMBP],T3>) ;PUT OUT KEY NAME
$CALL INFKAT ;PUT OUT KEY ATTR
TT$OUT ([[0]]) ;CRLF
JRST DUABLE
$CASF
ERRU (IUE)
DUABLE:
ADDI DD,SZ%DD ;HOP TO NEXT ENTRY
CAML DD,DDCURR ;HIT LIMIT?
RETURN ;YES
JRST DUABLP ;NO
$ENDUTIL
$ENDSCOPE(INFO)
SUBTTL PROCESS THE OPEN COMMAND
$PROC (C.OPEN)
;
; C.OPEN - OPEN THE SPECIFIED RMS!REPORT FILE
;
$P (KEYW)
CASES T1,MX%OPE
$CASE (OPE%REP) ;OPEN REPORT FILE
MOVE T5,UTLFLG ;CHECK IF A REPORT FILE ALREADY OPEN
TXNE T5,UT%RFO
ERRU (FAO) ;ONLY 1 RPT FILE CAN BE OPEN AT A TIME
$CALL INITAB,<FAA1> ;SETUP FAB FOR AN STREAM ASCII REPORT FILE
$CALL M.TOK ;PICK UP FILE NAME
$STORE T1,FNA,(PB)
MOVEM PB,OUTFAB ;SAVE FAB ADDR FOR RAB USE
OPAOPN: ;CREATE (OR OPEN) FILE AND CONNECT A RECORD STREAM
$CALL P$SWIT ;GET SWITCH
LOADX T1,FB$SUP ;ASSUME NOT APP
SKIPF ;IS /APP THERE?
LOADX T1,FB$CIF ;CR ONLY IF NECES
$STORE T1,FOP,(PB) ;PUT IT AWAY
$CREATE 0(PB)
$CHKERR (?UTLCOF could not open file)
OPACON:
$CALL INITAB,<RAA1>
MOVE T1,OUTFAB ;MOVE FAB ADDR TO RAB
$STORE (T1,FAB,(PB))
$FETCH T5,FOP,(T1) ;GET FOP BACK
TXNN T5,FB$CIF ;OPENED IF POSSIB?
$SKIP ;YES, SO APPEND
LOADX T2,RB$EOF ;SET TO EOF.
$STORE (T2,ROP,(PB))
$ENDIF
$CONNECT 0(PB)
$CHKERR (?UTLCOF could not open file)
HRRZ T1,OV.DSIG## ;BUFFER ADDR TO RAB
$STORE (T1,RBF,(PB))
MOVEM PB,OUTRAB ;SAVE RAB ADDR FOR $PUT's
$FLAGO (UTLFLG,UT%RFO) ;SET REPORT FILE OPN FLG
RETT
$CASE (OPE%RMS) ;*** CASE 1. RMS FILE
MOVE T5,UTLFLG ;CHECK IF A RMS FILE ALREADY OPEN
TXNE T5,UT%FOP
ERRU (RAO) ;ONLY ONE RMS FILE CAN BE OPEN AT A TIME
$CALL INITAB,<FABINI> ;SETUP A FAB FOR RMS FILE
$CALL M.TOK ;PICK UP FILE NAME
$STORE (T1,FNA,(PB)) ;PUT PTR TO FILE SPEC AWAY
MOVEM PB,FAB ;SAVE FAB ADDR FOR USE IN RAB
ORMACC: ;CHECK OPEN FOR INPUT OR OUTPUT
$P (KEYW)
LOADX T2,FB$NIL ;DEFAULT ACCESS IS TRANSPAR INPUT
CAIE T1,OP%INP ;DID USER SPECIFY INPUT?
LOADX T2,FB$DEL!FB$UPD ;NO. OUTPUT
$STORE (T2,FAC,(PB)) ;STORE IN FAB
LOADX T2,FB$NIL ;SHR FIELD.
$STORE (T2,SHR,(PB)) ;NEVER SHARE
MOVE T2,UTLFLG ;SET UP TO SET PATCHING FLAG
CAIE T1,OP%PAT ;PATCHING?
TXZA T2,UT%PAT ;NO
TXO T2,UT%PAT ;YES
MOVEM T2,UTLFLG ;PERMANIZE IT
ORMJSY: ;DO RMS OPERATIONS FOR DATA FILE
$OPEN 0(PB) ; OPEN THE FILE
$CHKERR (?UTLCOF could not open file)
$FETCH T1,IFI,(PB) ;GET PTR TO RMS'S FILE STRUCT
MOVEM T1,FST ;PERMANIZE IT
$FETCH T1,ORG,(PB) ;!!! V1 SUPPORTS ONLY IDX !!!
CAIN T1,FB$IDX ;IS IT AN INDEX FILE
$SKIP ;NO
$CALL CLORMS ;CLEAN UP
JRST L$ERRU(NRF)
$ENDIF
$CALL P$SWIT ;REC SIZE SWIT?
JUMPT L$JUMP ;JUMP IF MRS ON CMD LINE
$FETCH T1,MRS,(PB) ;GET MAX REC SIZE
SKIPN T1 ;WAS THERE MRS?
MOVEI T1,4000 ;NO, DEFAULT TO FULL PAGE
JRST L$IFX
$JUMP ;PICK UP CMD LINE VAL
$P (NUM) ;REQUIRED
$ENDIF
$FETCH T2,BSZ,(PB) ;GET FILE'S BYTE SIZE
MOVEI T3,^D36 ;GET BITS/WD
IDIV T3,T2 ;CALC BYTES/WD
ADDI T1,-1(T3) ;INSURE ROUND UP
IDIV T1,T3 ;BYTES-PER-REC/BYTES-PER-WD=WD/REC
MOVEM T1,BUFSIZ ;SAVE IT
$CALL M.ALC,<BUFSIZ> ;ALLOC THE BUF
MOVEM T1,BUFADR ;SAVE IT
$CALL INITAB,<RABINI> ;SETUP RAB FOR $CONNECT
MOVE T1,FAB ;MOVE FAB ADDR TO RAB
$STORE (T1,FAB,(PB))
MOVE T1,BUFADR ;GET ADDR OF USER BUF ALLOCATED
$STORE T1,UBF,(PB) ;PUT IT IN RAB
MOVE T1,BUFSIZ ;WDS IN REC BUF
$STORE T1,USZ,(PB) ;PUT IN RAB
$CONNECT 0(PB)
$CHKERR (?UTLCOF could not open file)
MOVEM PB,RAB ;PERMANIZE ADDR OF RAB
ORM.EN: ;SET CONTEXT FOR THIS FILE
$FETCH T1,ISI,(PB) ;GET PTR TO RMS'S REC STRUCT
MOVEM T1,RST ;PERMANIZE IT
$FLAGZ (UTLFLG,UT%EMP!UT%PCH) ;PROL NOT CHGED YET &ASSUME DATA IN FILE
$CALLB M$USET,<RAB> ;SET ENVIR FOR $UTLINT
$CALLB BK$PROL ;SET P_IN_FILE IN UTLIO (GETBKT CONSIS)
JUMPLE T1,L$UNW ;OOPS, UNABLE TO READ PROLOG
ORM.FL:
MOVE PB,FAB ;GET FAB PTR BACK
$FETCH T1,FAC,(PB) ;SEE HOW OPENED TO SET FLAG
CAIE T1,FB$NIL ;RETRIEVAL?
$SKIP ;YES
$FLAGO UTLFLG,UT%IN ;SET FLAG
JRST L$IFX
$NOSKIP
$FLAGO UTLFLG,UT%OUT ;SET OUTPUT
$ENDIF
ORM.KY:
$FETCH T5,BSZ,(PB) ;FIND BYTE SIZE OF FILE
HRLI T1,444400 ;ASSUME OCTAL DUMP
SETZB T2,T3 ;ASSUME NO CONV
CAIE T5,7 ;ASCII?
$SKIP ;YES
MOVEI T4,40 ;ASCII BLANK
HRLI T1,440700 ;GET BP VAL
JRST OKYDON ;SET VARS
$ENDIF
CAIE T5,6 ;SIXBIT?
$SKIP ;YES
MOVEI T4,0 ;SIXBIT BLANK
MOVEI T3,S.TO.A ;FOR DISPLAY
MOVEI T2,A.TO.S ;KEY CONV TABLE TO USE
HRLI T1,440600 ;GET BP VAL
JRST OKYDON ;SET VARS
$ENDIF
CAIE T5,9 ;EBCDIC?
$SKIP ;YES
MOVEI T4,100 ;EBCDIC BLANK
MOVEI T3,E.TO.A ;FOR DISPLAY
MOVEI T2,A.TO.E ;KEY CONV TABLE TO USE
HRLI T1,441100 ;GET BP VAL
; JRST OKYDON ;SET VARS
$ENDIF
OKYDON:
MOVEM T1,STRIPT ;DONE SETTING BYTE SIZE
MOVEM T2,STCAIN ;TAB TO CONV CMD LINE STRINGS
MOVEM T3,STCINA ;FOR DISPLAY OF STRINGS
MOVEM T4,STFILL ;SAVE FILL CHAR TOO
ORM.CU: ;SET CURRENCY INDICS
$EH (ORMCAB) ;SET DEFAULT CURRENCY IF ABORT
SETZM CU.KRF ;START WITH PRIM KEY
$CALL US.INIT ;INIT ENVIR FOR CURRENCY
JUMPT L$IFX ;ANY ERRORS?
ORMCAB:
SETZM CU.REC ;INDIC CURR REC NOT SET
$COPY CU.BKT,I 1 ;PT AT ROOT 0 AS USUAL
$ENDIF
$CALL CS.NEW ;PERMANIZE NEW CURRENCY
RETT
$ENDPROC
SUBTTL COMMON UTILITIES
$UTIL (INITAB,<INIBLK>)
;
; INITAB - ALLOCATE A BLOCK OF STORAGE FOR
; FAB/RAB AND COPY INITIAL VALUES TO IT
; ARGUMENT:
; INIBLK = INITIALIZED COPY OF BLK
; RETURNS:
; PB = PTR TO ALLOCATED BLK
MOVEI PB,@INIBLK(AP)
$FETCH (T5,BLN,(PB)) ;GET LENGTH OF BLK
$CALL M.ALC,<T5> ;ALLOCATE MEM
EXCH T1,PB ;PRESERVE PTR TO BLK
$FETCH (T2,BLN,(T1)) ;GET ARGBLK'S LEN BACK
HRL T1,PB ;GET ADDR OF ALLOC VALUES
MOVSS T1 ;BLT INIT,,ALLOC
ADDI T2,-1(PB) ;GET LAST WORD OF BLK
BLT T1,0(T2) ;COPY INIT VALUES TO ALLOCATED BLK
RETURN
$ENDUTIL
SUBTTL MEMORY MGT
$PROC (M.INIT)
RESET ;START WITH CLEAN SLATE
$COPY DDCURR,I DDTAB ;INIT SYMTAB
RETT
$ENDPROC
$PROC (M.ALC,<WORDS>)
;
; M.ALC - ALLOCATES SPECIFIED NUMBER OF WORDS
; ARGUMENTS:
; WORDS = # OF WDS TO ALLOC
; RETURNS:
; T1 = PTR TO WHAT ALLOC
MOVE T2,@WORDS(AP) ;GET AMT TO ALLOC
$ENDARG
$CALLB (GETMEM,T2); ;CALL RMS MEM MANAGER TO ALLOCATE
RETT
$ENDPROC
$PROC (M.RMSF)
;
; M.RMSF - FREE ALL MEMORY ACQUIRED FOR CURRENTLY OPEN RMS FILE
;
SKIPN T1,BUFADR ;WAS A BUFFER ALLOCATED?
$SKIP
$CALLB (FREMEM,<T1,BUFSIZ>) ;FREE BUFFER
SETZM BUFADR
$ENDIF
SKIPN PB,FAB ;FREE FAB
$SKIP
$FETCH (T1,BLN,(PB)) ;LENGTH OF FAB
$CALLB (FREMEM,<FAB,T1>) ;FREE IT
SETZM FAB
$ENDIF
SKIPN PB,RAB ;FREE RAB
$SKIP
$FETCH (T1,BLN,(PB))
$CALLB (FREMEM,<RAB,T1>)
SETZM RAB
$ENDIF
RETT
$ENTRY (M.REPF)
;
; M.REPF - FREE MEM ACQ FOR REPORT FILE
;
MOVE PB,OUTFAB
SETZM OUTFAB
$FETCH (T1,BLN,(PB))
$CALLB (FREMEM,<PB,T1>)
MOVE PB,OUTRAB
SETZM OUTRAB
$FETCH (T1,BLN,(PB))
$CALLB (FREMEM,<PB,T1>)
RETT
$ENDPROC
$SCOPE (M.TOK)
$LREG (BS) ;BLT SOURCE
$LREG (TLEN) ;TOK LEN IN WDS
$PROC (M.TOK)
;
; M.TOK - ALLOC SPACE FOR AND COPY STRING TO SPACE ALLOCATED
; RETURNS:
; T1 = PTR TO ALLOCATED BLK
$CALL P$NFLD ;GET DATA FOR CURR FIELD
MOVSI BS,TK.VAL(T2) ;SAVE ADDR AND PREP TO BLT
LOAD TLEN,TK.LEN(T2) ;GET WD LEN OF TOK (INCL HDR)
MOVEI TLEN,-1(TLEN) ;REMOVE HDR WD FROM LEN
$CALL M.ALC,<TLEN> ;GRAB THE SPACE
HRRM T1,BS ;FINISH SETTING UP BLT AC
ADDM T1,TLEN ;END OF BLT
BLT BS,-1(TLEN) ;MOVE THE DATA
RETT ;WITH T1 = PTR TO BLK
$ENDPROC
$ENDSCOPE(M.TOK)
SUBTTL OPEN TTY: (OPEN THE DEFAULT OUTPUT DEVICE)
$PROC (RP.INIT)
;
;RP.INIT -OPEN THE DEFAULT OUTPUT DVC.
;
;
$CALL INITAB,<FAA1> ;BUILD A FAB
MOVEM PB,TTYFAB
MOVEM PB,OUTFAB ;SAVE ITS ADDR
$OPEN @TTYFAB
$CHKERR (?UTLCOF could not open TTY:)
$CALL INITAB,<RAA1> ;BUILD A RAB
MOVEM PB,TTYRAB
MOVEM PB,OUTRAB
MOVE T1,TTYFAB
$STORE T1,FAB,(PB) ;SAVE FAB PTR IN RAB
$CONNECT @TTYRAB ;ESTABLISH RECORD STREAM
$CHKERR (?UTLCOF could not open TTY:)
HRRZ T1,OV.DSIG## ;ADDR OF BUFFER TO RAB
$STORE T1,RBF,(PB)
RETT
$ENDPROC
SUBTTL SYMBOL PROCESSOR
$PROC (SY.CHK,<CHKTYP>)
;
; SY.CHK - FIND SYMBOL & SEE IF IT IS OF DESIRED TYPE
; ARGUMENTS:
; CHKTYP = TYPE SYM MUST BE (IMM FMT)
; RETURNS:
; T1 = PTR TO THE ARGBLK
; T2 = ADDRESS OF SYMTAB NODE
; NOTES:
; DOES ERRU(NNK), ERRU(NWT) IF NECES
; XAB TYPE IS DENOTED BY A NEGATIVE ARG
MOVE PB,CHKTYP(AP) ;MATER TYPE CODE (MISUSE PB)
$ENDARG
$CALL SY.GET ;PARSE IT
JUMPF L$ERRU(NNK,VASZPT) ;BAD NAME
LOAD T3,UF.BID(T1) ;GET ITS TYPE
JUMPG PB,L$IFX ;NO JUMP IF XAB SPECIAL CASE
CAIE T3,XA$TYP ;DOES IT MATCH
ERRU (WTN,VASZPT) ;NO
$FETCH T3,COD,(T1) ;GET TYPE OF XAB
MOVMS PB ;GET SIGN RIGHT
$ENDIF
CAME T3,PB ;DOES IT MATCH?
ERRU (WTN,VASZPT) ;NO
RETT ;WITH ARGBLK & SYM ENT PTRS
$ENDPROC
$PROC (SY.GET)
;
; SY.GET - PICK UP FIELD TOKEN AND FIND IN SYMTAB
; RETURNS AS FOR SY.FIND
$P (FLD) ;GET TOKEN
MOVEM T1,T5 ;PUT PDB PTR IN COMM SPOT
JRST SYFMRG ;DO THE WORK
;
$ENTRY (SY.FIND,<CURTOK>)
;
; SY.FIND - FIND A SYMBOL
; ARGUMENTS:
; CURTOK = THE CURR TOK'S PDB
; RETURNS:
; TF = -1 IF SYMBOL FOUND
; 0 IF NOT FOUND
; T1 = VALUE OF SYMBOL
; T2 = ADDRESS OF SYMTAB NODE
MOVEI T5,@CURTOK(AP) ;PT TO STRING
$ENDARG
SYFMRG:
$CALL SYMASZ ;BUILD RADIX50 VALUE INTO VASZPT
$CALL SYMFND ;SEARCH PRIVATE SYMBOL TABLE
JUMPF L$RET ;FAIL IF NOT THERE EITHER
MOVEM T1,T2 ;PRESERVE SYMTAB ADDR
RETURN (DD.VAL(T1)) ;TRAN RET SUCC WITH VAL
$ENDPROC
$PROC (SY.STOR)
;
; SY.STOR - STORE SYMBOL IN PRIVATE TABLE
; ARGUMENTS:
; CURR TOKEN TO PARSE
; RETURNS:
; TF = TRUE IF SYMBOL NOT ALREADY IN TABLE, FALSE OTHERWISE
; T1 = SYMBOL NODE ADDRESS
$P (FLD) ;PICK UP FIELD BEING DEFINED
MOVEM T1,T5 ;MAKE PTR TO FLDNAME PASSABLE
$CALL SYMASZ ;CLEAN UP ASZ NAME & SETUP VASZPT
$CALL SYMFND ;SEARCH PRIVATE SYMBOL TABLE
JUMPT L$RETF ;FAIL IF ALREADY THERE
$CALL P$PREV ;BACK UP TO FLD NAM
$CALL M.TOK ;ALLOC SPACE FOR & COPY TOKEN
MOVE T3,DDCURR ;CURR SPOT IN PRIVATE TABLE
CAIL T3,DDTAB+SZ%DDT ;HIT LIMIT
ERRU (TFU) ;YES, TAB FULL
MOVEM T1,DD.NAM(T3) ;PUT SYMBOL IN TABLE
MOVEI T1,SZ%DD(T3) ;HOP TO NEXT FREE SLOT
EXCH T1,DDCURR ;SAVE NEW 1ST FREE & SETUP RETVAL
RETT ;RET SUC
$ENDPROC
$PROC (SY.WID,<BPSYM,MAXLEN>)
;
; SY.WID - INSURES FIELD IS ACCEP LEN IN TABULAR DISPLAY
; ARGUMENTS:
; BPSYM = BYTE PTR TO SYM (LH=0 IMPLIES 440700)
; MAXLEN = MAX LEN TABLE CAN HANDLE
; RETURNS:
; T1/T2 = STRING PTR OF STRING TO DISPLAY
; T3 = PTR TO ASCIZ STRING OF TABS TO GET TO NEXT TAB STOP
; IF TRUNCATION OF MAXLEN NECES, FAILURE RET TAKEN TO DISTING
MOVE T4,@MAXLEN(AP) ;MATER MAX LEN
MOVE T5,@BPSYM(AP) ;GET PTR TO SYM NAME
$ENDARG
TLNN T5,-1 ;BP INFO ALREADY THERE?
HRLI T5,440700 ;NO, MAKE IT BP
MOVEM T5,T1 ;SET BP PART OF RET VAL
SETZM T2 ;INIT LEN CNT
MOVEI T3,[ASCIZ/ /] ;INIT TAB INFO
SYW.LP:
LC TAP,T5 ;LOOP TO FIND LEN BY BRUTE FORCE
JUMPE TAP,SYWTAB ;EXIT IF SHORT NAME, RET WITH ITS SP
CAML T2,T4 ;IN RANGE?
RETF ;RET WITH TRUNCATED NAME
AOJA T2,SYW.LP ;KEEP TABULATING
SYWTAB:
SUB T4,T2 ;GET DIFF BETW MAX & ACT
CAIGE T4,^D32 ;WITHIN 4?
MOVEI T3,[ASCIZ/ /]
CAIGE T4,^D24 ;WITHIN 3?
MOVEI T3,[ASCIZ/ /]
CAIGE T4,^D16 ;WITHIN 2?
MOVEI T3,[ASCIZ/ /]
CAIGE T4,^D8 ;WITHIN 1 TAB STOP?
MOVEI T3,[ASCIZ/ /] ;YES
RETT
$ENDPROC
SUBTTL SYMBOL TABLE SUBROUTINES
$UTIL (SYMASZ)
;
; SYMASZ - CLEAN UP ASCII SYMBOL
; ARGUMENTS:
; T5 = PTR TO FLD'S PDB
; RETURNS:
; VASZPT = RADIX50 VAL
$COPY VASZPT,I TK.VAL(T5),T2 ;SAVE PTR TO FLD NAME
LOAD T1,TK.LEN(T5) ;GET # OF WDS IN ENTRY
ADDI T2,-2(T1) ;REMOVE HDR WD & PT TO LAST WD OF NAME
HRLI T2,440700 ;PT TO THIS WORD
MOVEI T3,5 ;PREP TO LOOP THRU ITS BYTES
MOVE T4,[LC T1,T2] ;START BY GETTING CHARS FROM IT
SASZLP:
XCT T4 ;DO LC/DC
SKIPN T1 ;HIT NUL BYTE YET?
MOVE T4,[DC T1,T2] ;YES, DEPOSIT LATER BYTES
SOJG T3,SASZLP ;TIL WORD EXHAUSTED
RETURN
$ENDUTIL
$UTIL (SYMFND)
;
; SYMFND - SEARCH SYMBOL TABLE FOR @VASZPT
; RETURNS:
; TF = TRUE IF SYMBOL FOUND
; T1 = PTR TO SYMBOL NODE
MOVEI T5,DDTAB ;PT TO START OF TABLE
MOVE T4,DDCURR ;CURR END OF TABLE
SUBM T5,T4 ;GET NEG TABLE SIZE IN LH
JUMPGE T4,L$RETF ;PRIVATE SYMTAB EMPTY
HRL T5,T4 ;NOW AOBJ PTR
SYFOLP:
MOVE T3,DD.NAM(T5) ;PT TO 1ST WD OF NAME IN SYMTAB
MOVE T2,VASZPT ;DITTO, SYM BEING SEARCHED FOR
SYFILP:
MOVE T1,0(T3) ;GET CURR WD OF 1 STRING
XOR T1,0(T2) ;= OTHER? ISOL EFFECT OF RANDOM B35'S
TRZ T1,1 ;B35 GUARAN OFF NOW
JUMPN T1,SYFILX ;EXIT INNER LOOP IF WORDS DIF
LDB T1,[POINT 7,0(T3),34] ;IS LAST CHAR OF WD NUL?
JUMPE T1,SYMEX ;YES, HAVE REACHED END STILL =, SO SUCC
ADDI T2,1 ;MOVE TO NEXT WD OF SEARCH SYM
AOJA T3,SYFILP ;DITTO NAME IN SYMTAB
SYFILX:
AOBJN T5,.+1 ;2ND WORD IN TAB ENTRY
AOBJN T5,SYFOLP ;LOOP IF MORE TO CHK
RETF ;SYM NOT FND
SYMEX:
HRRZ T1,T5 ;ISOL SYM NODE PTR
RETT ;RET SUC
$ENDUTIL
$ENDSCOPE (TOP-LEVEL)
END