Trailing-Edge
-
PDP-10 Archives
-
BB-JF18A-BM
-
sources/rms/debact.mac
There are 7 other files named debact.mac in the archive. Click here to see a list.
;
; COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
; ALL RIGHTS RESERVED.
;
; 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 THAT IS NOT SUPPLIED BY DIGITAL.
;
TITLE DEBACT - ACTION ROUTINES FOR RMSDEB
SUBTTL S. COHEN/DAW
SEARCH RMSMAC,RMSINT
$PROLOG(DEB)
DEFINE $$CPON(X)<DB.> ;;FORCE MSG NAME DOTTED
OPDEF PJRST [JRST]
C$MAXB==^D17 ;AAAA Highest supported block type
COMMENT \
Revision history
edit Why
------- ---------------------------
(2) (DAW,19-Feb-82) Allocate 6 words for KNM in case $DISPLAY is done
RMS assumes you have allocated 6 words for the key name.
(3) (AWN,16-Feb-83) Add new FAB fields & bits
(4) (AWN,12-Jul-83) Handle TOPS-20 DDT symbol table pointer (@770001)
510(5) (AWN,24-Sep-84) Handle $PARSE and $SEARCH
10/3/85 asp - add Tops-10 conditionals
610(6) (TGS,7-Mar-86) Allocate 7 words always for KNM field and chop
long KNMs to 30-characters.
\ ;End comment
EXTERN A.TO.E, E.TO.A
; $RF - MACRO TO ALLOCATE RMS ARGBLK-FIELD DESCRIPTOR
;
DEFINE $RF (PREFIX,NAME,VALUE),<
ZZ==0
IRP VALUE,<ZZ==ZZ+1> ;;COUNT # OF VALUES
IFNDEF RF.'NAME,<RF.'NAME::>
F$$'NAME(PB) ;;BYTE PTR TO FLD
XWD ZZ,F.'NAME ;;COUNT,,FMT INFO
ASCIZ/NAME/ ;;SO NAME OF FIELD CAN BE PRINTED
IRP VALUE,<XWD [ASCIZ/VALUE/],PREFIX'$'VALUE>
>
; $RBF - MACRO TO ALLOCATE RMS ARGBLK-BITFIELD DESCRIPTOR
; This stores bit number (bit 0 is low-order) instead of bit,
; so longer-than-18 bit bitfields are possible
; VALUE is still a bit mask, the macro converts it
DEFINE $RBF (PREFIX,NAME,VALUE),<
ZZ==0
IRP VALUE,<ZZ==ZZ+1> ;;COUNT # OF VALUES
IFNDEF RF.'NAME,<RF.'NAME::>
F$$'NAME(PB) ;;BYTE PTR TO FLD
XWD ZZ,F.'NAME ;;COUNT,,FMT INFO
ASCIZ/NAME/ ;;SO NAME OF FIELD CAN BE PRINTED
IRP VALUE,<XWD [ASCIZ/VALUE/],<43-^L<PREFIX'$'VALUE>>>
>
DEFINE $SH(FLD$)<<RF%'FLD$_9>> ;;KLUDGE TO SET TYP/FLAG AT SAME TIME
;COMMON $RF FIELDS
;
F.STS==DT%OCT
F.STV==DT%OCT
F.BID==$SH(INV)
F.BLN==$SH(INV)
SUBTTL IMPURE STORAGE
SZ%KBUF==<^D255/5>+1 ;WDS IN KEY BUF
SZ%ARB==1600
SZ%DDT==200
RSSIZE==200
ESSIZE==200
$IMPURE
$DATA (ARBCURR) ;CURR ADDRESS IN PRIVATE ARGBLK TABLE
$DATA (ARBTAB,SZ%ARB) ;SPACE FOR PRIVATE ARGBLK TABLE
$DATA (ARYNAM) ;PTR TO ARRAY NAME
$DATA (ARYIDX) ;CURR EL OF ARRAY TO DISP
$DATA (CRABNM) ;CURR RAB'S NAME IN R50
$DATA (CURRAB) ;PTR TO LAST PROCESSED RAB
$DATA (CPOSIT) ;CURR POSITION FOR DATAFLDS
$DATA (CSTYPE) ;CURR STRING DATA TYPE
$DATA (DDCURR) ;CURR ADDRESS IN PRIVATE SYMTAB
$DATA (DDTAB,SZ%DDT) ;SPACE FOR PRIVATE SYMTAB
$DATA (POSIT) ;CURR POS FOR DEFINE DATAFIELD
$DATA (R50VAL) ;SYMBOL IN RADIX50
$DATA (STRIPT,3) ;SPACE FOR STRING PTR
$DATA (TYPBLK) ;TYPE OF BLOCK IN INFO COMMAND
$DATA (INIBLK) ;PTR TO INITIAL BLOCK (FOR ALCBLK)
$DATA (BUFADD) ;ADDRESS OF BUFF TO USE IN EATDAT
$DATA (CHADAT) ;ON IF CHANGE DATA FLD
$DATA (SVP1T)
$DATA (RSAREA,RSSIZE) ;Resultant String Area ;a511
$DATA (ESAREA,ESSIZE) ;Expanded String Area ;a511
KEYINI:
$INIT (UF)
$SET (UF.BID,DA$TYP) ;SO COMPAT WITH ARGBLKS
$SET (UF.BLN,SZ%UF) ;SO COMPAT WITH ARGBLKS
$SET (UF.POS,0) ;ALWAYS BEGINNING OF KEY BUF
$ENDINIT
$PURE
;Messages
DB.FNU: [ASCIZ/%DEBFNU FAB name unknown -- proceeding with initial-value FAB/]
DB.NND: [ASCIZ/%DEBNND ^5 not defined/]
ASCSTR: [ASCIZ/^A/]
DISSTR: [ASCIZ/^S/]
FNACOL: [ASCIZ/^A: ^N/]
FABINF: [ASCIZ/^5 FAB ^A^A/]
RABINF: [ASCIZ/^5 RAB ^A/]
XABINF: [ASCIZ/^5 ^A XAB/]
DAIINF: [ASCIZ/^5 ^A at W^1/]
DASINF: [ASCIZ/^5 ^A B^1 thru B^1/]
CONFCR: [ASCIZ/Current RAB is ^5/]
CONFNC: [ASCIZ/No current RAB/]
CONFDD: [ASCIZ/DEFINE DATA default is ^A at ^1/]
ARYFMT: [ASCIZ/^A^1: ^1/]
DABDEC: [ASCIZ/^1/] ;Decimal number
DABOCT: [ASCIZ/^2/] ;Octal number
DABDAT: [ASCIZ/^D/] ;Date
DABFLO: [ASCIZ/^F/] ;Floating
DABDOU: [ASCIZ/^E/] ;Double
DABGFL: [ASCIZ/^G/] ;G-Floating
DABPAC: [ASCIZ/^P/] ;Packed
DABLON: [ASCIZ/^8/] ;Long integer
DABUNS: [ASCIZ/^U/] ;Unsigned Integer
ISSTRT: ^B010000001111 ;Bit mask, on for string types
; UPLGDFOD6FEA
BPWVEC: EXP 5,0,6 ;BYTES/WD BY STRING TYPE
XABTYP:
[ASCIZ/KEY/]
[ASCIZ/AREA/]
[ASCIZ/DATE/]
[ASCIZ/SUMMARY/]
DATTYP:
[ASCIZ/ASCII/]
[ASCIZ/F-BYTES/]
[ASCIZ/SIXBIT/]
[ASCIZ/DECIMAL/]
[ASCIZ/OCTAL/]
[ASCIZ/FLOATING/]
[ASCIZ/DOUBLE_FLOATING/]
[ASCIZ/GFLOATING/]
[ASCIZ/LONG_INTEGER/]
[ASCIZ/PACKED/]
[ASCIZ/8-BIT-ASCII/]
[ASCIZ/UNSIGNED/]
SUBTTL FAB FIELD DESCRIPTORS
FB$ALL==FB$ALL ;GET+PUT+DEL+TRN+UPD
FABTAB:
$RF (FB,BID)
$RF (FB,BLN)
$RF (FB,STS)
$RF (FB,STV)
$RF (FB,BKS)
$RF (FB,BSZ)
$RF (FB,DEV,<AVL,CCL,IDV,MDI,MNT,NET,ODV,REC,RMT,SQD,SPL,TRM>);M501
$RF (FB,FAC,<DEL,GET,PUT,TRN,UPD,BIO,BRO,APP>) ;M501
$RF (FB,FNA)
$RF (FB,FOP,<CIF,DFW,DRJ,SUP,WAT,SPL,SCF,DLT,NAM,CTG,LKO,TMP,MKD,OFP>) ;m501
$RF (FB,FSZ) ;m501
$RF (FB,IFI)
$RF (FB,JFN)
$RF (FB,JNL)
$RF (FB,MRN)
$RF (FB,MRS)
$RF (FB,ORG,<SEQ,REL,IDX>)
$RF (FB,NAM) ;m501
$RF (FB,RAT,<BLK,FTN,CR,PRN,EMB,CBL>) ;m501
$RF (FB,RFM,<VAR,STM,LSA,FIX,VFC,UDF,SCR,SLF>) ;m572
$RF (FB,SHR,<DEL,GET,PUT,TRN,UPD,BIO,BRO,APP>) ;m501
$RF (FB,TYP) ;m501
$RF (FB,XAB)
$RF (FB,ALQ) ;m501
Z ;END OF TABLE
;FLAGS FOR $RFS IN FAB
F.FOP==DT%SYB ;OPT IS DEFINED IN CALL
F.ORG==DT%SYV ;SAME
F.FAC==DT%SYB
F.SHR==DT%SYB
F.RAT==DT%SYB
F.MRS==DT%DEC
F.BSZ==DT%DEC
F.BKS==DT%DEC
F.DEV==DT%SYB
F.JFN==DT%OCT
F.IFI==DT%SYA
F.FNA==DT%STR
F.MRN==DT%DEC
F.RFM==DT%SYV
F.JNL==$SH(INV)
F.XAB==DT%SYA
F.FSZ==DT%DEC ;M501
F.ALQ==DT%DEC ;M501
F.TYP==DT%SYA ;M501
F.NAM==DT%SYA ;M501
SUBTTL $RF DESCRIPTORS FOR RAB
RABTAB: $RF (RB,BID)
$RF (RB,BLN)
$RF (RB,STS)
$RF (RB,STV)
$RF (RB,BKT)
$RF (RB,ELS)
$RF (RB,FAB)
$RF (RB,ISI)
$RF (RB,KBF)
$RF (RB,KRF)
$RF (RB,KSZ)
$RF (RB,LSN)
$RF (RB,MBF)
$RF (RB,PAD)
$RF (RB,RAC,<SEQ,KEY,RFA,TRA,BLK,BFT>)
$RF (RB,RBF)
$RF (RB,RFA)
$RF (RB,ROP,<EOF,FDL,KGE,KGT,LOA,LOC,NRP,PAD,RAH,WBH>)
$RF (RB,RSZ)
$RF (RB,UBF)
$RF (RB,USZ)
Z ;END OF TABLE
;FLAGS FOR $RF MACROS IN RAB
F.ROP==DT%SYB
F.USZ==DT%DEC
F.RSZ==DT%DEC
F.KBF==$SH(BUF)!DT%OCT
F.UBF==$SH(BUF)!DT%OCT
F.RAC==DT%SYV
F.RFA==DT%OCT
F.RBF==$SH(BUF)!DT%OCT
F.ISI==DT%OCT
F.FAB==DT%SYA
F.KRF==DT%DEC
F.KSZ==DT%DEC
F.MBF==DT%DEC
F.LSN==DT%DEC
F.BKT==DT%DEC
F.ELS==DT%STR
F.PAD==DT%OCT
SUBTTL $RF DESCRIPTORS FOR NAM
NAMTAB:
$RF (NA,BID) ;! BLOCK TYPE
$RF (NA,BLN) ;! BLOCK LENGTH
$RF (NA,ESA) ;! ADDRESS FOR EXPANDED STRING
$RF (NA,ESS) ;! BUFFSIZE FOR EXPANDED STRING
$RF (NA,ESL) ;! LENGTH OF EXPANDED STRING
$RF (NA,RLF) ;! ADDRESS OF RELATED NAM BLOCK
$RF (NA,NOP,<PWD,SYN>) ;! NAME OPTION BITS
$RF (NA,RSA) ;! ADDRESS FOR RESULTANT STRING
$RF (NA,RSL) ;! LENGTH OF RESULTANT STRING
$RF (NA,RSS) ;! BUFSIZE FOR RESULTANT STRING
$RBF (NA,FNB,<INV,GND,TFS,ACT,PRO,ULV,NHV,UHV,VER,EXT,NAM,DIR,UNT,DEV,NOD,QUO,EDE,EDI,ENA,ETY,EVE,MUL,WLD>) ;! NAME OPTION BITS
$RF (NA,WCC) ;! WILDCARD CONTEXT
$RF (NA,WCT) ;! NUMBER OF FILES FOUND
$RF (NA,WNX) ;! NUMBER OF FILES FOUND
$RF (NA,CHA,<CEX,CNA,CDI,CDE>) ;! WHAT FIELDS $SEARCH CHANGED
$RF (NA,NDL) ;! LENGTH OF NODEID
$RF (NA,DVL) ;! LENGTH OF DEVICE
$RF (NA,DRL) ;! LENGTH OF DIRECTORY
$RF (NA,NML) ;! LENGTH OF FILENAME
$RF (NA,TPL) ;! LENGTH OF EXTENSION
$RF (NA,VRL) ;! LENGTH OF DEVICE
$RF (NA,NDA) ;! POINTER TO NODEID
$RF (NA,DVA) ;! POINTER TO DEVICE
$RF (NA,DRA) ;! POINTER TO DIRECTORY
$RF (NA,NMA) ;! POINTER TO FILENAME
$RF (NA,TPA) ;! POINTER TO EXTENSION
$RF (NA,VRA) ;! POINTER TO DEVICE
Z
F.ESA==DT%SYA
F.RSA==DT%SYA
F.ESS==DT%DEC
F.RSS==DT%DEC
F.NOP==DT%SYB
F.ESL==DT%DEC
F.RSL==DT%DEC
F.RLF==DT%SYA
F.NDL==DT%DEC
F.DVL==DT%DEC
F.DRL==DT%DEC
F.NML==DT%DEC
F.TPL==DT%DEC
F.VRL==DT%DEC
F.NDA==DT%OCT
F.DVA==DT%OCT
F.DRA==DT%OCT
F.NMA==DT%OCT
F.TPA==DT%OCT
F.VRA==DT%OCT
F.FNB==DT%SBV
F.WCC==DT%OCT
F.WCT==DT%DEC
F.WNX==DT%DEC
F.CHA==DT%SYB
SUBTTL $RF DESCRIPTORS FOR TYP
TYPTAB:
$RF (TY,BID) ;! BLOCK TYPE
$RF (TY,BLN) ;! BLOCK LENGTH
$RF (TY,CLA) ;! FILE CLASS
$RF (TY,FDT) ;! FIELD DATA TYPE
$RF (TY,FLN) ;! FIELD LENGTH
$RF (TY,FSC) ;! SCALE FACTOR
$RF (TY,NEX) ;! NEXT FIELD
$RF (TY,MOR) ;! NEXT VARIANT
F.CLA==DT%OCT
F.FDT==DT%OCT
F.FLN==DT%DEC
F.FSC==DT%DEC
F.NEX==DT%SYA
F.MOR==DT%SYA
SUBTTL $RF DESCRIPTORS FOR XAB
XABTAB: ;FOR DISPLAY ENTIRE-ARGLBK DISPATCH
XABKEY
XABAREA
XABDAT
XABSUM
XABCFG
XABKEY: $RF (XB,BID)
$RF (XB,BLN)
$RF (XB,COD,<SUM,KEY,AREA,DATE>)
$RF (XB,NXT)
$RF (XB,DAN)
$RF (XB,DFL)
$RF (XB,DTP,<STG,EBC,SIX,PAC,IN4,FL1,FL2,GFL,IN8,AS8,UN4>)
$RF (XB,FLG,<CHG,DUP>)
$RF (XB,IAN)
$RF (XB,IFL)
$RF (XB,KNM)
$RF (XB,POS)
$RF (XB,PS1)
$RF (XB,PS2)
$RF (XB,PS3)
$RF (XB,PS4)
$RF (XB,PS5)
$RF (XB,PS6)
$RF (XB,PS7)
$RF (XB,REF)
$RF (XB,SIZ)
$RF (XB,SZ1)
$RF (XB,SZ2)
$RF (XB,SZ3)
$RF (XB,SZ4)
$RF (XB,SZ5)
$RF (XB,SZ6)
$RF (XB,SZ7)
BLOCK SZ%RF ;END OF XAB KEY TAB (WHOLE BLK TO TERM ARR DISP)
RF.PS0==:RF.POS
RF.SZ0==:RF.SIZ
XABARE: $RF (XB,BID)
$RF (XB,BLN)
$RF (XB,COD,<SUM,KEY,AREA,DATE>)
$RF (XB,NXT)
$RF (XB,AID)
$RF (XB,BKZ)
Z ;END OF XAB ALL TABLE
XABDAT: $RF (XB,BID)
$RF (XB,BLN)
$RF (XB,COD,<SUM,KEY,AREA,DATE>)
$RF (XB,NXT)
$RF (XB,CDT)
$RF (XB,EDT)
$RF (XB,RDT)
Z ;END OF XAB DAT TABLE
;FILE SUMMARY XAB DEFINITIONS
XABSUM: $RF (XB,BID)
$RF (XB,BLN)
$RF (XB,COD,<SUM,KEY,AREA,DATE>)
$RF (XB,NXT)
$RF (XB,NOA) ;NUMBER OF AREAS
$RF (XB,NOK) ;NUMBER OF KEYS
Z ;END OF XAB DAT TABLE
;FILE SUMMARY XAB DEFINITIONS
XABCFG: $RF (XB,BID)
$RF (XB,BLN)
$RF (XB,COD,<SUM,KEY,AREA,DATE,CFG>)
$RF (XB,NXT)
$RF (XB,BFS) ;! BUFFER SIZE
$RF (XB,OST) ;! OPERATING SYSTEM TYPE
$RF (XB,FIL) ;! FILE SYSTEM TYPE
$RF (XB,VER) ;! DAP VERSION NUMBER
$RF (XB,ECO) ;! DAP ECO NUMBER
$RF (XB,USN) ;! USER VERSION NUMBER
$RF (XB,DSV) ;! SOFTWARE VERSION NUMBER ;m555
$RF (XB,USV) ;! USER SOFTWARE VERSION NUMBER ;m555
$RF (XB,CAP,<PRE,SQO,RLO,DRO,EXT,SQT,RRE,RVB,RKE,RHA,RRF,IMK,SWA,APA,SBA,CMP,MDS,DIS,BLR,BLU,XLN,CHK,KEM,ALM,SMM,DIR,DTM,PRO,ACL,FPR,FSB,FDE,DFS,SQA,REC,BIT,WAR,REN,WLD,GO,NAM,SEG,CAT,CDT,CPR,CNA,MAT,D3N,RAT,RDT,RPR,BCS,OVN>)
; $RF (XB,CAP) ;! SYSCAP BITS
; $RF (XB,CA1) ;! CONTINUATION OF SYSCAP BITS
; $RF (XB,CA2) ;! CONTINUATION OF SYSCAP BITS
Z ;END OF XAB DAT TABLE
;FLAGS FOR FIELDS IN XAB
F.AID==DT%DEC
F.COD==DT%SYV
F.NXT==DT%SYA
F.DTP==DT%SYV
F.FLG==DT%SYB
F.REF==DT%OCT
F.IAN==DT%OCT
F.DAN==DT%OCT
F.IFL==DT%DEC
F.DFL==DT%DEC
F.NOA==DT%DEC
F.NOK==DT%DEC
F.KNM==DT%ST6
F.POS==$SH(ARY)!DT%DEC
F.SIZ==$SH(ARY)!DT%DEC
F.PS1==$SH(ARY)!$SH(INV)!DT%DEC
F.PS2==$SH(ARY)!$SH(INV)!DT%DEC
F.PS3==$SH(ARY)!$SH(INV)!DT%DEC
F.PS4==$SH(ARY)!$SH(INV)!DT%DEC
F.PS5==$SH(ARY)!$SH(INV)!DT%DEC
F.PS6==$SH(ARY)!$SH(INV)!DT%DEC
F.PS7==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ1==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ2==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ3==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ4==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ5==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ6==$SH(ARY)!$SH(INV)!DT%DEC
F.SZ7==$SH(ARY)!$SH(INV)!DT%DEC
F.BKZ==DT%DEC
;FLAG DEFINITIONS FOR DATE XAB:
F.CDT==DT%DAT ;THIS IS A DATE FIELD
F.RDT==DT%DAT ;THIS IS A DATE FIELD
F.EDT==DT%DAT ;THIS IS A DATE FIELD
;FLAG DEFINITIONS FOR CONFIG XAB:
F.BFS==DT%DEC ;! BUFFER SIZE
F.OST==DT%DEC ;! OPERATING SYSTEM TYPE
F.FIL==DT%DEC ;! FILE SYSTEM TYPE
F.VER==DT%DEC ;! DAP VERSION NUMBER
F.ECO==DT%DEC ;! DAP ECO NUMBER
F.USN==DT%DEC ;! USER VERSION NUMBER
F.DSV==DT%DEC ;! SOFTWARE VERSION NUMBER ;m555
F.USV==DT%DEC ;! USER SOFTWARE VERSION NUMBER ;m555
F.CAP==DT%SBV ;! SYSCAP BITS
F.CA1==$SH(INV) ;! SYSCAP BITS
F.CA2==$SH(INV) ;! SYSCAP BITS ;A554^^
SUBTTL DISPLAY DESCRIPTORS FOR INTERNAL BLOCKS
LALL
FSTTAB:
$RF (FS,BID)
$RF (FS,BLN)
$RF (FS,FLI)
$RF (FS,BLI)
$RF (FS,ADB)
$RF (FS,JFN)
$RF (FS,BKT)
$RF (FB,IOR,<SEQ,REL,IDX>)
$RF (FS,IFG,<LKF,LOK,UDF,NEW,ILK,REO,RMT>) ;m501
$RF (FS,IDV)
$RF (FB,IRF,<VAR,STM,LSA,FIX,VFC,UDF,SCR,SLF>) ;m572
$RF (FB,ISH,<GET,UPD,PUT,DEL,TRN,BIO,BRO,APP,SMU>)
$RF (FB,IFA,<GET,UPD,PUT,DEL,TRN,BIO,BRO,APP,SMU>)
$RF (FS,IRS)
$RF (FS,MBS)
$RF (FS,BFN)
$RF (FS,BMN)
$RF (FS,BLO)
$RF (FS,IRN)
$RF (FB,IFO,<WAT,CIF,DRJ,DFW,SUP,SPL,SCF,DLT,NAM,CTG,LKO,TMP,MKD,OFP>)
$RF (FS,KBS)
$RF (FS,KDB)
$RF (FB,IRA,<BLK,FTN,CR,PRN,EMB,CBL>)
$RF (FS,IBS)
$RF (FS,DLA)
$RF (FS,ICT)
$RF (FS,SZF)
Z
F.FLI==DT%SYA
F.BLI==DT%SYA
F.ADB==DT%SYA
F.IJF==DT%OCT
F.IBK==DT%SYA
F.IOR==DT%SYZ
F.IFG==DT%SYB
F.IDV==DT%DEC
F.IRF==DT%SYV
F.ISH==DT%SYB
F.IFA==DT%SYB
F.IRS==DT%DEC
F.MBS==DT%DEC
F.BFN==DT%DEC
F.BMN==DT%DEC
F.BLO==DT%DEC
F.IRN==DT%DEC
F.IFO==DT%SYB
F.KBS==DT%DEC
F.KDB==DT%SYA
F.IRA==DT%SYB
F.IBS==DT%DEC
F.DLA==DT%SYA
F.ICT==DT%OCT
F.SZF==DT%DEC
RSTTAB:
$RF (RS,BID)
$RF (RS,BLN)
$RF (RS,FLI)
$RF (RS,BLI)
$RF (RS,SFG,<PAR,EOF,LOK,SUC,UPD,SEQ,TRN>)
$RF (RS,FST)
$RF (RS,RSW)
$RF (RS,RSB)
$RF (RS,PTR)
$RF (FB,SRF)
$RF (RS,NRP)
$RF (C,OPR,<OPEN,CLOSE,GET,PUT,UPDATE,DELETE,FIND,TRUNCATE,CONNECT,DISCONNECT,CREATE,DEBUG,RELEASE,FLUSH,MESSAGE,NOMESSAGE,DISPLAY,ERASE,FREE,UTLINT,NXTVOL,REWIND,WAIT,READ,SPACE,WRITE,PARSE,SEARCH,ENTER,EXTEND,REMOVE,RENAME>)
$RF (RS,HSZ)
$RF (RS,BDC)
$RF (RS,SKB)
$RF (RS,BKB)
$RF (RS,BKA)
$RF (RS,BKS)
$RF (BK,BKF,<LOK>)
$RF (RS,BKN)
$RF (RS,HBY)
$RF (RS,BYC)
$RF (RS,KRN)
$RF (RS,SKR)
$RF (RS,SRR)
$RF (RS,SDR)
$RF (RS,SDT)
$RF (RS,BFP)
$RF (RS,BFU)
$RF (ZZ,BFO,<MODIFIED>)
$RF (RS,BFZ)
$RF (RS,BFN)
Z
F.SFG==DT%SYB
F.FST==DT%SYA
F.RSW==DT%DEC
F.RSB==DT%DEC
F.PTR==DT%OCT
F.SRF==DT%OCT
F.NRP==DT%DEC
F.OPR==DT%SYV
F.HSZ==DT%DEC
F.BDC==DT%DEC
F.SKB==DT%SYA
F.BKD==$SH(INV)
F.BKB==DT%SYA
F.BKA==DT%SYA
F.BKS==DT%DEC
F.BKF==DT%SYB
F.BKN==DT%DEC
F.HBY==DT%DEC
F.BYC==DT%DEC
F.KRN==DT%DEC
F.SKR==DT%DEC
F.SRR==DT%DEC
F.SDR==DT%OCT
F.SDT==DT%OCT
F.BFP==DT%OCT
F.BFU==DT%DEC
F.BFO==DT%SYB
F.BFZ==DT%DEC
F.BFN==DT%OCT
ZZ$MODIFIED==1
KDBTAB:
$RF (KD,BID)
$RF (KD,BLN)
$RF (KD,KKR)
$RF (KD,ROO)
$RF (KD,IDB)
$RF (XB,KDT,<STG,EBC,SIX,PAC,IN4,FL1,FL2,GFL,IN8,AS8,UN4>)
$RF (KD,HSZ)
$RF (KD,KNX)
$RF (KD,KFG,<NIX,CHD,DUP,CHG,HSH>)
$RF (KD,KDA)
$RF (KD,KIA)
$RF (KD,DBK)
$RF (KD,IBK)
$RF (KD,MNR)
$RF (KD,LEV)
$RF (KD,KBZ)
$RF (KD,DFL)
$RF (KD,IFL)
$RF (KD,KSW)
$RF (KD,KSB)
Z
F.KKR==DT%DEC
F.ROO==DT%DEC
F.IDB==DT%SYA
F.KDT==DT%SYV
F.HSZ==DT%DEC
F.KNX==DT%SYA
F.KFG==DT%SYB
F.KDA==DT%DEC
F.KIA==DT%DEC
F.DBK==DT%DEC
F.IBK==DT%DEC
F.MNR==DT%DEC
F.LEV==DT%DEC
F.KBZ==DT%DEC
F.DFL==DT%OCT
F.IFL==DT%OCT
F.KSW==DT%DEC
F.KSB==DT%DEC
SALL
SUBTTL INITIALIZED STORAGE FOR EACH TYPE OF ARG BLK
FLDINI:
$INIT (UF)
$SET (UF.BID,DA$TYP) ;SO COMPAT WITH ARGBLKS
$SET (UF.BLN,SZ%UF) ;SO COMPAT WITH ARGBLKS
$ENDINIT
FABINI:
FAB$B
F$SHR FB$NIL
F$MRS ^D250
F$BSZ 7
FAB$E
RABINI:
RAB$B
R$KSZ ^D30
RAB$E
NAMINI:
NAM$B
N$ESA ESAREA
N$RSA RSAREA
N$ESS ESSIZE
N$RSS RSSIZE
NAM$E
TYPINI:
TYP$B
TYP$E
XKINI:
XAB$B (KEY)
X$DTP XB$STG
X$SIZ 1
XAB$E
XAINI:
XAB$B (ALL)
X$BKZ 1
X$AID 1
XAB$E
XDINI:
XAB$B (DAT)
XAB$E
XSINI:
XAB$B (SUM)
XAB$E
XCINI:
XAB$B (CFG)
XAB$E
XABINI: ;INIT BLK ACCESSED INDEXED THRU XABINI
XKINI
XAINI
XDINI
XSINI
XCINI
SUBTTL PROCESS ASSIGN, CHANGE, AND DEFINE DEFINE CMD
$SCOPE (DEFINE-BLOCK)
;Some registers
P1==6
P2==7
DD==10 ;Ptr to entry in (DDT-like) symtab
PB==11 ;Ptr to curr RMS arg blk
RF==12
; DO.ASSIGN = INIT BLK FROM ADDRESS RATHER THAN BY ALLOCATION
; NOTES:
; ASSIGN (NAME) name (TO ADDRESS) octal-number
DO.ASSIGN::
$P (FLD) ;PICK UP FIELD BEING DEFINED
MOVEI T1,TK.VAL(T1) ;Point to ASCIZ string of name.
PUSHJ P,SY.STOR ;Put in table if not already there
JUMPF L$ERRU(NAD) ;NAME ALREADY DEFINED
PUSH P,T1 ;PRESERVE DD SYMBLK PTR
$P (NUM) ;GET THE ADDRESS
POP P,T2
MOVEM T1,DD.VAL(T2) ;PUT IT AWAY
$FETCH T2,BID,(T1) ;CHK IF RAB
CAIE T1,RA$TYP ;IS IT?
JRST RTRUE ;NO, DONE
MOVEM T1,CURRAB ;SAVE PTR TO IT
MOVE T1,R50VAL ;SAVE ITS NAME
MOVEM T1,CRABNM
JRST RTRUE
SUBTTL PROCESSOR FOR CHANGE CMD
; DO.CHANGE - CHANGE VALUE OF ARGBLK OR DATA FIELD
; CHANGE <argblk-NAME> [argblk-fld-list]
; CHANGE [argblk-name] KEY-BUFFER!datfld-list
; WHERE EACH LIST IS FORM: FIELD VALUE, FIELD VALUE, ...
;
DO.CHANGE::
PUSHJ P,%SAVEP ;SAVE PERM AC'S
MOVE PB,CURRAB ;PRESUME DEFAULT RAB
$CALL P$KEYW ;KEY-BUFFER?
JUMPT CHGKED ;YES IF JUMP
$CALL SY.GET ;GET PTR TO ARGBLK
JUMPF L$ERRU(NNK) ;NAME NOT KNOWN
$FETCH T2,BID,(T1) ;GET TYPE OF FLD
CAIE T2,DA$TYP ;DATA FLD?
JRST NOTDAF ;NO
JUMPE PB,L$ERRU(NRC) ;NO RAB CURR
JRST CHGDAT ;MERGE THE DATA PATH
NOTDAF: MOVEM T1,PB ;PERMANIZE ARGBLK PTR
CHG.LP: $CALL P$KEYW ;CHK IF ARGBLK FLD
JUMPT CHGKWD ;YES IF JUMP
$CALL SY.GET ;NO, IS DATAFLD
JUMPT CHGDAT ;PROCEED
$CALLB TX$OUT,<R50VAL,DB.NND> ;TELL USER
$CALL P$NFLD ;HOP OVER VALUE
JRST CHGPCM ;PROCEED TO NEXT FLD (OR EOL)
CHGDAT: MOVEM T1,RF ;PERMANIZE FLD PTR
$CALL EATDAT ;PROCESS IT
JRST CHGPCM
;ARGBLK data
CHGKWD: JUMPE T1,CHGKEY ;ACTU NO, IS KEY-BUFFER
MOVEM T1,RF ;PERMANIZE IT
$CALL EATRFV ;EAT ARGBLK VALUE
;Here when done with field
CHGPCM: $CALL P$COMMA ;MORE IN LIST?
JUMPT CHG.LP ;YES
JRST RTRUE ;RETURN
;"CHANGE KEY-BUFFER"
CHGKED: JUMPE PB,L$ERRU(NRC) ;NO RAB CURR
CHGKEY:
MOVEI RF,KEYINI ;USE DUMMY UF
$CALL EATKEY ;DO THE WORK
JRST RTRUE
;
; EATDAT - EAT USER DATA FLD VALUE
;
EATDAT: SETZM BUFADD ;USE RBF BELOW
LOAD T2,UF.TYP(RF) ;GET TYPE OF FLD
CASES T2,MX%DFT
$CASE (DFT%SIX)
MOVEI TAP,40 ;CONV FACTOR
MOVSI T5,(POINT 6,) ;SIXBIT BYTE INFO
EATSTR:
$P (QSTR,WDT) ;PICK UP THE STRING
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
SKIPN T1,BUFADD ;USE KBF?
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
HRR T5,T1 ;MAKE BP
LOAD T4,UF.POS(RF) ;GET RELAT POSITION
ADJBP T4,T5 ;GET THERE
EATOKC:
LOAD T5,UF.SIZ(RF) ;GET LENGTH
ADJBP T5,T4 ;GET TO END OF COPY
HRRZS T5,T5 ;ISOL ENDING ADDR OF COPY
$FETCH T2,USZ,(PB) ;ASSUME REC BUFF SIZE
SKIPE BUFADD ;CHK CASE THAT APPS
MOVEI T2,SZ%KBUF ;KEY BUFF SIZE
ADD T1,T2 ;GET TO WD PAST END
CAMG T1,T5 ;OUT OF BNDS?
ERRU (VOF) ;VAL OVFLOWS BUFFER
LOAD T5,UF.SIZ(RF) ;GET LENGTH FOR LOOP CNT
EASCLP:
ILDB T1,T3 ;GET A CHAR
JUMPE T1,EASCLE ;END?
JUMPGE TAP,EASCL1 ;EBCDIC? ;M501
ROT T1,-1 ;TABLE HAS 2 PER WORD
JUMPL T1,EASCL0
HLRZ T1,A.TO.E(T1) ;GET TRANSLATED CHARACTER
JRST EASCL1
EASCL0: HRRZ T1,A.TO.E(T1) ;GET TRANSLATED CHARACTER
EASCL1: JUMPE TAP,EASCL2 ;SEE IF SIXBIT-ISH CONVERSION ;A575
CAIL T1,140 ;IT IS, MAKE SURE CHAR UPPERCASE;A575
MOVEI T1,-40(T1) ;MAKE IT SO ;A575
SUB T1,TAP ;CONV IF NECES
EASCL2: IDPB T1,T4 ;NO, PUT IT AWAY
SOJG T5,EASCLP ;MORE LEFT?
POPJ P, ;FILLED FLD
EASCLE:
$FETCH T1,ROP,(PB) ;SEE IF PAD REQUESTED ;A575
TXNN T1,RB$PAD ;BY CHECKING BIT IN ROP ;A575
SKIPA T1,[" "] ;PAD WITH SPACES ;M575
$FETCH T1,PAD,(PB) ;PAD WITH PAD CHAR IF SPECIFIED ;A575
SUB T1,TAP ;CONVERT IF NECES
IDPB T1,T4 ;PUT IT AWAY
SOJG T5,.-1 ;DONE YET
POPJ P,
$CASE (DFT%PAC) ;Packed Decimal data ;A411
$P (FLD,WDT) ;Parses as Field
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
SKIPN T1,BUFADD ;USE KBF?
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
HRR T5,T1 ;MAKE BP
LOAD T4,UF.POS(RF) ;GET RELAT POSITION
ADJBP T4,T5 ;GET THERE
LOAD T5,UF.SIZ(RF) ;GET LENGTH
ADJBP T5,T4 ;GET TO END OF COPY
HRRZS T5,T5 ;ISOL ENDING ADDR OF COPY
$FETCH T2,USZ,(PB) ;ASSUME REC BUFF SIZE
SKIPE BUFADD ;CHK CASE THAT APPS
MOVEI T2,SZ%KBUF ;KEY BUFF SIZE
ADD T1,T2 ;GET TO WD PAST END
CAMG T1,T5 ;OUT OF BNDS?
ERRU (VOF) ;VAL OVFLOWS BUFFER
LOAD T5,UF.SIZ(RF) ;GET LENGTH OF FIELD
$CALLB CVTZP,<T3,T4,T5> ;Convert it
POPJ P, ;FILLED FLD
$CASE (DFT%EBC) ;EBCDIC ;A501
SKIPA TAP,[-40] ;CONVERSION FACTOR FOR SPACE
;AND FLAG FOR EBCDIC TRANSLATION
$CASE (DFT%ASC) ;A411
$CASE (DFT%FIL)
EATFIL: SETZM TAP ;NO CONVERSION ;a501
$FETCH T4,FAB,(PB) ;GET FAB
JUMPE T4,L$ERRU(RNC) ;DOESNT PT TO FAB
$FETCH T1,BSZ,(T4) ;GET FILE BYTE SIZE
CAIN T1,6 ;SIXBIT?
JRST L$CASE(DFT%SIX) ;YES
CAIG T1,9 ;9-Bit ASCII? ;M501
CAIGE T1,7 ;ASCII? ;M501
ERRU (BSI) ;BYTE SIZE ILLEGAL FOR INPUT ;M501
SKIPA T5,T1 ;Yes. Get byte size in T5 ;M501
;8-bit ASCII OK too ; 501
;Field is either 7-bit, 8-bit or 9-bit ASCII
$P (QSTR,WDT) ;PICK UP THE STRING ;d501
LSH T5,^D24 ;Move byte size to correct place ;A411
TLO T5,440000 ;Set position field ;A411
JRST EATSTR ;MERGE
$CASE (DFT%UNS)
$P (UQSTR,WDT) ;Parses as unquoted string ;A411
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
$CALLB CVTZU##,<T3,T1> ;Convert it
POPJ P, ;FILLED FLD
$CASE (DFT%DOU) ;DOUBLE FLOATING ;A411
$P (UQSTR,WDT) ;Parses as unquoted string ;A411
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
$CALLB CVTZD##,<T3,T1> ;Convert it
POPJ P, ;FILLED FLD
$CASE (DFT%GFL) ;GFLOATING ;A411
$P (UQSTR,WDT) ;Parses as unquoted string ;A411
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
$CALLB CVTZG##,<T3,T1> ;Convert it
POPJ P, ;FILLED FLD
$CASE (DFT%LON)
$P (UQSTR,WDT) ;Parses as unquoted string ;A411
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,(POINT 7,) ;SETUP BP TO IT
$FETCH T1,RBF,(PB) ;NO, GET RECORD BUFFER PTR
$CALLB CVTZL##,<T3,T1> ;Convert it
POPJ P, ;FILLED FLD
$CASE (DFT%DEC)
$CASE (DFT%OCT)
$P (NUM,WDT) ;GET THE NUMBER
$FETCH T3,RBF,(PB) ;GET RECORD PTR
$INCR T3,UF.POS(RF) ;GET TO RIGHT WORD
MOVEM T1,0(T3) ;PUT IT AWAY
POPJ P,
$CASE (DFT%FLO) ;Single Floating Point ;A411
$P (FLOT,WDT) ;GET THE NUMBER
$FETCH T3,RBF,(PB) ;GET RECORD PTR
$INCR T3,UF.POS(RF) ;GET TO RIGHT WORD
MOVEM T1,0(T3) ;PUT IT AWAY
POPJ P,
$CASX
;
;
; EATKEY - ENTER DATA IN KEY BUFFER
;
EATKEY: $FETCH T3,KBF,<(PB)> ;SET UP BUFF LOC IMMED
JUMPN T3,EATK1 ;IS THERE 1?
MOVEI T1,SZ%KBUF ;KEY BUFFER SET FROM CONSTANT
PUSHJ P,M.ALC ;...KSZ MAY BE SMALL FOR GENERIC KEY
$STORE T1,KBF,<(PB)> ;PUT AWAY PTR
MOVE T3,T1 ;SO CAN BE USED AFTER P$NUM
EATK1: $CALL P$NUM ;THE EASY CASE?
JUMPF EATK2 ;NO, IF JUMP
MOVEM T1,0(T3) ;PUT IT AWAY
POPJ P, ;DONE
EATK2: MOVEM T3,BUFADD ;PERMANIZE START ADDR
$CALL P$CURR ;PREP TO COMPUTE LEN OF ENTERED STRING
MOVEI T1,TK.VAL(T1) ;PT TO STRING
HRLI T1,(POINT 7,) ;...AND MAKE IT A BP
SETZM T3 ;INIT CNT
ILDB T2,T1 ;GET A CHAR
SKIPE T2 ;DONE YET?
AOJA T3,.-2 ;NO, EAT ANOTHER
$STORE T3,KSZ,(PB) ;STORE FLD LEN IN ARGBLK
STOR T3,UF.SIZ(RF) ;ALSO IN PSEUDO-DATFLD BLK
JRST EATFIL ;PASSING BUFADD
;
; DO.DEFINE - PROCESS DEFINE CMD
;
DO.DEFINE::
PUSHJ P,%SAVEP ;SAVE PERM AC'S
$P (KEYW) ;PICKUP THE KEYWORD VAL
CASES T1,MX%DEF ;DISPATCH OFF TYPE OF BLK
$CASE (DEF%DAT)
MOVEI T1,FLDINI ;Data field desc init vals
MOVEM T1,INIBLK
PUSHJ P,ALCBLK ;ALLOCATE A BLOCK
$P (KEYW) ;PICK UP DATA TYPE
STOR T1,UF.TYP(PB) ;STORE DATA TYPE
MOVEI T2,1 ;Test ;A411
LSH T2,(T1) ; stringness ;A411
TDNN T2,ISSTRT ; data type is string if lit ;A411
JRST [$CALL DEDINT ;YES, PROC INTEGER
JRST RTRUE]
$CALL DEDSTR ;NO, PROC STRING
JRST RTRUE
$CASE (DEF%RAB)
MOVEI T1,RABINI ;SETUP A RAB
MOVEM T1,INIBLK
PUSHJ P,ALCBLK
PUSH P,R50VAL ;SAVE ITS NAME
POP P,CRABNM
MOVEM PB,CURRAB ;SAVE PTR TO IT
$CALL SY.GET ;GET FAB PTR
JUMPT OKFABP ;JUMP IF FAB OK
$CALLB TX$OUT,<DB.FNU> ;FAB NAME UNKNOWN, CON WITH INIT VAL FAB
MOVEI T1,FABINI ;USE INIT VALUES FAB RATHER THAN ABORT
OKFABP: $STORE T1,FAB,(PB) ;PUT AWAY PTR
$CALL DEFSWIT
$FETCH T1,USZ,(PB) ;GET SIZE TO ALLOC
JUMPN T1,OKUSZ ;SPECIFY USER BUF SIZ?
$FETCH T4,FAB,(PB) ;GET FAB PTR
$FETCH T1,MRS,(T4) ;USE MAX REC SIZ AS DEFAULT
$FETCH T3,BSZ,(T4) ;GET BYTE SIZE FOR CONVERSION
MOVEI T2,^D36 ;GET BITS WORD
IDIV T2,T3 ;GET BYTES/WORD (IN T2)
IDIV T1,T2 ;GET WDS/MRS
MOVEI T1,1(T1) ;ADJ FOR POSSIB TRUNC
$STORE T1,USZ,(PB) ;PUT IT AWAY
;Here with T1= # words to allocate for user's buffer
OKUSZ: PUSHJ P,M.ALC ;GET USER BUFFER
$STORE T1,UBF,(PB) ;PUT AWAY PTR
$STORE T1,RBF,(PB) ;PUT AWAY PTR
$FETCH T5,RSZ,(PB) ;GET SIZE TO ALLOC
JUMPN T5,DFRABD ;SPECIFY CURR REC SIZ?
$FETCH T4,FAB,(PB) ;GET FAB PTR
$FETCH T5,MRS,(T4) ;USE MAX REC SIZ AS DEFAULT
$STORE T5,RSZ,(PB) ;PUT IT AWAY
DFRABD: JRST RTRUE
$CASE (DEF%NAM)
MOVEI T1,NAMINI ;SETUP A RAB
MOVEM T1,INIBLK
PUSHJ P,ALCBLK
PUSH P,R50VAL ;SAVE ITS NAME
POP P,CRABNM
$CALL DEFSWIT
$FETCH T1,ESS,(PB) ;GET SIZE TO ALLOC
JUMPE T1,DEFNA1 ;NOTHING
ADDI T1,4 ;
IDIVI T1,5 ;MAKE INTO WORDS
PUSHJ P,M.ALC ;GET USER BUFFER
HRLI T1,440700 ;MAKE BYTE POINTER ;m544
$STORE T1,ESA,(PB) ;STORE IN NAM BLOCK
DEFNA1: $FETCH T1,RSS,(PB) ;GET SIZE TO ALLOC
JUMPE T1,RTRUE ;NOTHING
ADDI T1,4 ;
IDIVI T1,5 ;MAKE INTO WORDS
PUSHJ P,M.ALC ;GET USER BUFFER
HRLI T1,440700 ;MAKE BYTE POINTER ;m544
$STORE T1,RSA,(PB) ;STORE IN NAM BLOCK
JRST RTRUE
$CASE (DEF%FAB)
MOVEI T1,FABINI ;SETUP A FAB
MOVEM T1,INIBLK
PUSHJ P,ALCBLK
$CALL ALCSTR ;ALC ROOM AND COPY FILE STRING
$STORE T1,FNA,<(PB)> ;PUT PTR TO FILE SPEC AWAY
$CALL DEFSWIT
$FETCH T1,BSZ,<(PB)> ;GET MAX REC SIZ
JRST RTRUE
$CASE (DEF%XAB)
SETZM INIBLK ;INDIC INIBLK DET IN ALCBLK
PUSHJ P,ALCBLK
$CALL DEFSWIT ;PROCESS SWITCHES
JRST RTRUE
$CASE (DEF%TYP) ;TYPE BLOCK ;A510 VV
MOVEI T1,TYPINI ; SET UP PROTOTYPE
MOVEM T1,INIBLK ; SO ALCBLK CAN FIND IT
PUSHJ P,ALCBLK
$CALL DEFSWIT ;PROCESS SWITCHES
JRST RTRUE ;A510 ^^
SUBTTL SUBROUTINES COMMON TO ASSIGN, DEFINE, AND CHANGE
;
; 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
; DD = DDT SYMBLK PTR
ALCBLK: $P (FLD) ;PICK UP FIELD BEING DEFINED
MOVEI T1,TK.VAL(T1) ;Get ptr to ASCIZ name
PUSHJ P,SY.STOR ;Put in table if not already there
JUMPF L$ERRU(NAD) ;NAME ALREADY DEFINED
MOVEM T1,DD ;PRESERVE DD SYMBLK PTR
SKIPE T1,INIBLK ;Did user tell us an initial block?
JRST GOTIB ;Yes
$P (KEYW) ;NO, PICK UP XAB TYPE
MOVE T1,XABINI(T1) ;GET INIT ARGBLK ADDR
;Here with T1 = initial block ptr.
GOTIB: PUSH P,T1 ;Save it..
$FETCH T1,BLN,<(T1)> ;GET LEN OF ARGBLK NEEDED
PUSHJ P,M.ALC ;ALLOC A BLK
MOVEM T1,PB ;PRESERVE PTR TO BLK
MOVEM T1,DD.VAL(DD) ;SET VALUE OF SYMBOL TO ADDR OF ARGBLK
POP P,T2 ;T2= initial block ptr.
HRL T1,T2 ;GET ADDR OF INIT VALS
$FETCH T2,BLN,<(T2)> ;GET ARGBLK'S LEN BACK
ADDI T2,-1(PB) ;GET LAST WORD OF BLK
BLT T1,0(T2) ;COPY INIT VALS TO ALLOC BLK
POPJ P, ;RETURN
; ALCSTR - ALLOC SPACE FOR AND COPY STRING TO SPACE ALLOCATED
; RETURNS:
; T1 = PTR TO ALLOCATED BLK
ALCSTR: $CALL P$NFLD ;GET DATA FOR CURR FIELD
PUSHJ P,%SAVEP ;Save perm ac's.
MOVSI P1,TK.VAL(T2) ;SAVE ADDR AND PREP TO BLT
LOAD P2,TK.LEN(T2) ;GET WD LEN OF TOK (INCL HDR)
MOVEI T1,-1(P2) ;REMOVE HDR WD FROM LEN
PUSHJ P,M.ALC ;GRAB THE SPACE
HRRM T1,P1 ;FINISH SETTING UP BLT AC
ADDM T1,P2 ;END OF BLT
BLT P1,-1(P2) ;MOVE THE DATA
POPJ P, ;RETURN WITH T1 = PTR TO BLK
;[610]
; ALCST6 - ALLOC SPACE FOR AND COPY STRING TO SPACE ALLOCATED
; GUARANTEED MINIMUM OF 6 WORDS+1
; RETURNS:
; T1 = PTR TO ALLOCATED BLK
ALCST6: $CALL P$NFLD ;GET DATA FOR CURR FIELD
PUSHJ P,%SAVEP ;Save perm ac's
MOVSI P1,TK.VAL(T2) ;SAVE ADDR AND PREP TO BLT
LOAD P2,TK.LEN(T2) ;GET WD LEN OF TOK (INCL HDR)
MOVEI P2,-1(P2) ;REMOVE HDR WD FROM LEN
MOVEI T1,7 ;[610] ALLOCATE SEVEN WORDS
PUSHJ P,M.ALC ;[610]
HRRM T1,P1 ;FINISH SETTING UP BLT AC
CAILE P2,6 ;[610] IF GREATER THAN 6...
MOVEI P2,6 ;[610] MOVE ONLY 6
ADDM T1,P2 ;[610] END OF BLT
BLT P1,-1(P2) ;MOVE THE DATA
POPJ P, ;RETURN WITH T1 = PTR TO BLK
;
; DEDINT - PROCESS INTEGER DATA FIELD
;
;Input:
; PB/ ptr to block
; DD/ symblk ptr
DEDINT: $CALL P$NUM ;WORD OFFSET SPEC?
MOVE T3,CSTYPE ;GET STRING TYPE
MOVE T3,BPWVEC(T3) ;GET BYTES PER WORD
JUMPT DEDIN1 ;POSIT SPEC
JUMPE T3,DEDERR ;NO DEFAULT, TELL USE
MOVE T1,CPOSIT ;GET DEFAULT POS
ADDI T1,-1(T3) ;SETUP FOR TRUNCATING DIVIDE
IDIV T1,T3 ;GET WD OFFSET
DEDIN1: STOR T1,UF.POS(PB) ;STORE WORD OFFSET
ADDI T1,1 ;HOP PAST IT
IMUL T1,T3 ;RECONVERT TO CHARS
MOVEM T1,CPOSIT ;PERMANIZE IT
$CALL P$SWIT ;IS THERE A SWITCH?
JUMPF RTRUE ;NO, DONE
$CALL P$KEYW ;IS THERE A VALUE?
JUMPF RTRUE ;NO, DONE
STOR T1,UF.TYP(PB) ;JUST EXPLODE INT TO DEC/OCT
POPJ P, ;DONE
; DEDSTR - PROCESS STRING DATA FIELD
;
;Input:
; PB/ address of block
; DD/ symblk ptr
DEDSTR: $P (NUM) ;GET THE LENGTH
STOR T1,UF.SIZ(PB) ;STORE SIZE
$CALL P$NUM ;CHK FOR POS
JUMPT DEDST1 ;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
DEDST1: STOR T1,UF.POS(PB) ;PUT IT AWAY
$INCR T1,UF.SIZ(PB) ;HOP OVER CURR FLD
MOVEM T1,CPOSIT ;PERMANIZE NEW DEFAULT
LOAD T2,UF.TYP(PB) ;UPDATE CURR STRING TYPE
MOVEM T2,CSTYPE
POPJ P,
;Here if error in DEDINT or DEDSTR
DEDERR: SETZM 0(DD) ;CLEAR OUT ABORTED DEF
ERRU (NPS) ;TELL USER
; DEFSWIT - SCANS PARSER OUTPUT TILL EOL
;
DEFSWIT:
ESW.LP:
$CALL P$CFM ;IS IT EOL?
JUMPT [POPJ P,] ;YES, ALL DONE
$P (SWIT) ;EAT A SWITCH
MOVEM T1,RF ;PT TO THE RF RETURNED
$CALL EATRFV ;EAT RMS FLD VALUE
JRST ESW.LP ;CHK FOR ANOTHER SWITCH
; EATRFV - EAT RMS FIELD VALUE
;
EATRFV: SETZM P1 ;START WITH CLEAN SLATE
LOAD T1,RF%TYP(RF) ;SEE WHAT KIND OF VALUE FOLLOWS
CASES T1,MX%DT ;DISPATCH OFF IT
$CASE (DT%DATE) ;INTERNAL DATE/TIME
$CASE (DT%DEC) ;DECIMAL VALUE
$CASE (DT%OCT) ;OCTAL VALUE
$CALL P$NFLD ;PICK VALUE AND STORE VERBATIM
MOVE T1,TK.VAL(T2) ;GET THE PARSED VAL
DPB T1,RF%BP(RF) ;PUT IT AWAY
$CALL P$TOK ;SEE IF MORE ELEMS SPEC
JUMPF [POPJ P,] ;NO
ADDI RF,SZ%RF ;SEE IF MORE LEFT
LOAD T1,RF%FLAG(RF) ;CHK IF ARRAY ELEM
TXNN T1,RF%ARY ;NEXT ELEM ARRAY TOO?
ERRU (TMV) ;TOO MANY VALUES SPECIFIED
JRST L$CASE(DT%DEC) ;PROC IT
$CASE (DT%STR) ;VAR LEN STRING
$CALL ALCSTR ;GRAB SPACE AND COPY
DPB T1,RF%BP(RF) ;PUT AWAY PTR
POPJ P,
$CASE (DT%ST6) ;Same, except 6 words minimum
$CALL ALCST6 ;GRAB SPACE AND COPY
DPB T1,RF%BP(RF) ;PUT AWAY PTR
POPJ P,
$CASE (DT%SYA) ;SYMBOLIC ADDR
$CALL SY.GET ;PICK UP BLK NAME
JUMPF L$ERRU(NNK) ;NAME NOT KNOWN
DPB T1,RF%BP(RF) ;PUT FOUND SYMBOL AWAY
POPJ P,
$CASE (DT%SYV) ;SYMBOLIC VALUE
$CASE (DT%SYB) ;SYMBOLIC BITS
$P (KEYW) ;GET SYM VALUE SPECIFIED
IOR P1,T1 ;MERGE IN VALUE
$CALL P$TOK ;CHK FOR PLUS
JUMPT L$CASE(DT%SYB) ;GET NEXT VALUE
DPB P1,RF%BP(RF) ;STORE AWAY ACCUM VAL
POPJ P, ;CHK FOR EOL
$CASE (DT%SBV) ;SYMBOLIC BITVECTOR ;A511vv
$P (KEYW) ;GET SYM VALUE SPECIFIED
MOVEI T2,1 ;MAKE A BIT
LSH T2,(T1) ;SHIFT IT LEFT TO MAKE A BIT MASK
IOR P1,T2 ;MERGE IN VALUE
$CALL P$TOK ;CHK FOR PLUS
JUMPT L$CASE(DT%SBV) ;GET NEXT VALUE
DPB P1,RF%BP(RF) ;STORE AWAY ACCUM VAL
POPJ P, ;CHK FOR EOL ;a511^^
$CASF
ERRU (IER) ;INTERNAL ERROR
SUBTTL PROCESS DISPLAY COMMAND
; DO.DISPLAY - DISPLAY USER FIELD OR ARG BLK
; NOTES:
; DISPLAY <argblk-NAME> [argblk-fld-list]
; DISPLAY [argblk-name] DATA!KEY-BUFFER!datfld-list
;
DO.DISPLAY::
PUSHJ P,%SAVEP ;SAVE PERM AC'S
MOVE PB,CURRAB ;PRESUME USE CURRENT RAB
$CALL P$KEYW ;CHK FOR DATA or KEY-BUFFER
JUMPF DSP1 ;FALL THRU IF KYWD & DEFAULT RAB
JUMPE PB,L$ERRU(NRC) ;NO CURR RAB
JUMPN T1,DSPKEY ;DO KEY VALUE
JRST DSPDAA ;DISP WHOLE RECORD
DSP1: $CALL SY.GET ;GET USER'S FLD
JUMPF L$ERRU(NNK) ;ACTU IMPOS
$FETCH T2,BID,(T1) ;GET TYPE OF FLD
CAIE T2,DA$TYP ;DATA FLD?
JRST DSP2 ;NO
JUMPE PB,L$ERRU(NRC) ;YES, NO CURRENT RAB?
JRST DSPDL1 ;MERGE THE DATA-LIST PATH
DSP2: MOVEM T1,PB ;PERMANIZE ARGBLK PTR
DISPAB:
$CALL P$CFM ;ENTIRE USER BLK CASE?
JUMPT DSPABA ;YES, GO DO IT
DSPABL:
$CALL P$KEYW ;MUST BE AB FLD LIST, "DATA", OR DATFLD
JUMPF DSPDAL ;NOT A KEYWORD, SO ENTER DATA-LST PATH
JUMPE T1,DSPDAA ;DATA-ALL PATH
CAIN T1,DISD%K ;KEY-BUFFER?
JRST DSPKEY ;YES
CAIG T1,MX%DSN ;SMALL NUMBER ;a577
JRST DSPFSP ;YES. DISPLAY FILESPEC FROM NAME BLOCK ;a577
MOVEM T1,RF ;PERMANIZE RMS FIELD DESCRIPTOR
$CALL DABVAL ;DISPLAY ONE VALUE
$CALL P$COMMA ;MORE IN LIST?
JUMPT DSPABL ;YES
JRST RTRUE ;NO
DSPABA: ;DISPLAY ARGBLK
$FETCH T1,BID,(PB) ;GET ID
CASES T1,C$MAXB ;DISPATCH OFF IT ;AAAA
$CASE (FA$TYP)
MOVEI RF,FABTAB ;SETUP APPROP FIELD TABLE
JRST L$CASX
$CASE (RA$TYP)
MOVEI RF,RABTAB ;DITTO
JRST L$CASX
$CASE (XA$TYP)
IFE <XA$TYP-FS$TYP>,< ; Same value was used for both ;AAAA
$FETCH T1,BLN,(PB) ; Get length of block ;AAAA
CAIN T1,FS$LNG ; Same as FST? ;AAAA
JRST [MOVEI RF,FSTTAB ; Yes. it is an FST ;AAAA
JRST L$CASX] ; ;AAAA
> ;AAAA
$FETCH T1,COD,(PB) ;GET CODE FIELD
MOVE RF,XABTAB(T1) ;PICKUP FLD TABLE FOR APPROP XAB TYPE
JRST L$CASX
IFN <XA$TYP-FS$TYP>,< ; Unfortunately, these are the same ;AAAA
MOVEI RF,FSTTAB ; Get desc for FST ;AAAA
JRST L$CASX ; ;AAAA
> ; ;AAAA
$CASE (RS$TYP) ; RST ;AAAA
MOVEI RF,RSTTAB ; ;AAAA
JRST L$CASX ; ;AAAA
$CASE (KD$TYP) ; KDB ;AAAA
MOVEI RF,KDBTAB ; ;AAAA
JRST L$CASX ;AAAA
$CASE (NA$TYP)
MOVEI RF,NAMTAB ; NAM ;A510
JRST L$CASX ; ;A510
$CASE (TY$TYP)
MOVEI RF,TYPTAB ; NAM ;A510
JRST L$CASX ; ;A510
$CASF
ERRU (IER)
$CASX
DABALP:
SKIPN 0(RF) ;THRU?
JRST RTRUE ;YES
$CALL DABVAL ;PUT OUT CURR VAL
LOAD T1,RF%CNT(RF) ;GET VAR LEN SIZ
ADDI RF,SZ%RF(T1) ;GET TO NEXT RF
JRST DABALP ;CHK IF MORE
DSPFSP: ; DISPLAY FILESPEC FROM NAM BLOCK ;A577
CASES T1,MX%DSN ;DISPATCH OFF IT
$CASE (DSN%DA)
$CASE (DSN%KE)
RET ;HANDLED ELSEWHERE
$CASE (DSN%EX)
$FETCH T2,ESA,(PB) ;GET EXP STRING PTR
$FETCH T3,ESL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%RE)
$FETCH T2,RSA,(PB) ;GET RESULTANT STRING PTR
$FETCH T3,RSL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%NO)
$FETCH T2,NDA,(PB) ;GET NODE STRING PTR
$FETCH T3,NDL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%DE)
$FETCH T2,DVA,(PB) ;GET DEV STRING PTR
$FETCH T3,DVL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%DI)
$FETCH T2,DRA,(PB) ;GET DIR STRING PTR
$FETCH T3,DRL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%NA)
$FETCH T2,NMA,(PB) ;GET NAME STRING PTR
$FETCH T3,NML,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%TY)
$FETCH T2,TPA,(PB) ;GET TYPE STRING PTR
$FETCH T3,TPL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASE (DSN%VE)
$FETCH T2,VRA,(PB) ;GET VERSION STRING PTR
$FETCH T3,VRL,(PB) ;ITS LEN
JUMPE T2,RTRUE ;NO BUFF
JRST DSPFS1 ;MERGE TO OUTPUT STRING
$CASX
DSPFS1:
DMOVEM T2,STRIPT ;Store byte pointer & length in block
MOVEI T3,1 ;ASCII
MOVEM T3,STRIPT+2 ;Save string datatype
$CALLB TX$OUT,<[STRIPT],DISSTR> ;PUT OUT STRING
JRST RTRUE
DSPKEY: $FETCH T2,KBF,(PB) ;GET KEY BUFF PTR
JUMPE T2,RTRUE ;NO KEY BUFF
$FETCH T3,KSZ,(PB) ;ITS LEN
MOVE T1,0(T2) ;GET 1ST WORD OF KEY BUFFER
TXNE T1,777B8 ;START WITH 0 BITS?
JRST DSPDAK ;NO, MERGE TO OUTPUT STRING
$CALLB TX$OUT,<T1,DABDEC> ;Output number
JRST RTRUE
DSPDAL: $CALL SY.GET ;DERIVE FLD PTR FROM CURR TOKEN
JUMPT DSPDL1 ;VALID NAME
$CALLB TX$OUT,<R50VAL,DB.NND> ;TELL USER
JRST DSPDL2 ;PROCEED
;Here with T1= valid symbol value
DSPDL1: MOVEM T1,RF ;TREAT AS ARGBLK FLD (USE RF TO PT AT IT)
$CALL DDAVAL ;DISP DATA VAL
DSPDL2: $CALL P$COMMA ;CHK IF MORE IN LIST
JUMPF RTRUE ;NO
JRST DSPDAL ;YES
DSPDAA: $FETCH T2,RBF,(PB) ;GET REC LOCATION
$FETCH T3,RSZ,(PB) ;GET REC SIZE (IN BYTES)
DSPDAK: $FETCH T4,FAB,(PB) ;GET FAB PTR
JUMPE T4,L$ERRU(RNC) ;DOESNT PT TO FAB
HRLI T2,440000 ;WORD-ALIGNED BP
$FETCH T1,BSZ,(T4) ;FIND BYTE SIZE OF FILE
STOR T1,BP.SIZ+T2 ;MERGE BYTE SIZE WITH BP
DMOVEM T2,STRIPT
;Datatype, right now, is a function of byte size only.
MOVEI T3,1 ;Assume ASCII
CAIN T1,6 ;Sixbit?
MOVEI T3,0 ;Yes
CAIN T1,^D9 ;EBCDIC? ;????
MOVEI T3,2 ;Yes
MOVEM T3,STRIPT+2 ;Save string datatype
$CALLB TX$OUT,<[STRIPT],DISSTR> ;PUT OUT STRING
JRST RTRUE
;
; DABVAL - DISPLAY THE CURRENTLY IDENTIFIED ARGBLK FIELD
;
DABVAL: LOAD T1,RF%FLAG(RF) ;SEE IF ARRAY
TXNE T1,RF%INV ;INVISIBLE?
POPJ P, ;YES, JUST RET IMMED
TXNE T1,RF%ARY ;IS IT?
JRST ARYVAL ;YES
LDB P1,RF%BP(RF) ;GET THE VALUE
LOAD T1,RF%TYP(RF) ;PICK UP TYPE OF CURR RF
CAIE T1,DT%SYV ;SHOW SYM VALS OF 0
JUMPE P1,[POPJ P,] ;SKIP NULL VALUES
MOVEI T5,RF%NAM(RF) ;GET PTR TO TEXT
$CALLB TX$OUT,<T5,FNACOL> ;PUT OUT XXX:#
LOAD T1,RF%TYP(RF) ;PICK UP TYPE OF CURR RF
CASES T1,MX%DT ;DISPATCH ON DATA TYPE
$CASE (DT%DATE)
$CALLB TX$OUT,<P1,DABDAT>
POPJ P,
$CASE (DT%DEC) ;DECIMAL NUMBER
$CALLB TX$OUT,<P1,DABDEC>
POPJ P,
$CASE (DT%OCT)
$CALLB TX$OUT,<P1,DABOCT>
POPJ P,
$CASE (DT%STR)
$CALLB TX$OUT,<P1> ;Output string
POPJ P,
$CASE (DT%SYA)
$CALLB TX$OUT,<P1,DABOCT>
POPJ P,
LALL
$CASE (DT%ST6)
SALL
$CALLB TX$OUT,<P1> ;Simple string
POPJ P,
$CASE (DT%SYB)
LOAD T1,RF%CNT(RF) ;GET NUM OF SYM OPTS
MOVNS T1 ;MAKE NEG
HRLI T1,SZ%RF(RF) ;GET TO WHERE SYM WDS STORED
MOVSM T1,DD ;NOW AOBJ PTR TO SYM VALS
;Loop through symbol table looking for value
; If not found, give error
DSYBLP: LOAD T1,SYV.VL(DD) ;GET CURR SYM'S VAL
TDZN P1,T1 ;IS CURR VAL SUBSET OF ACTU VALUE?
JRST NOTSBS ;NO
LOAD T5,SYV.NM(DD) ;GET PTR OF NAME
MOVEI T4,[ASCIZ/^A/] ;Presume last one
SKIPE P1 ;MORE OPTIONS TO PUT OUT
MOVEI T4,[ASCIZ/^A+^N/] ;More follow
$CALLB TX$OUT,<T5,T4> ;PUT OUT SYM VAL
JUMPE P1,[POPJ P,] ;ALL BITS ACCOUNTED FOR
NOTSBS: AOBJN DD,DSYBLP ;CHK NEXT SYM
ERRU (IVF) ;INVALID VALUE IN FIELD
$CASE (DT%SBV) ;a511vv
; This can handle up to 72-bit bitvectors
LOAD T1,RF%CNT(RF) ;GET NUM OF SYM OPTS ;M554
MOVE T3,RF%BP(RF) ;Get the byte pointer ;a554
CAIG T1,^D36 ;How many words worth of them (less 1)? ;a554
TDZA T4,T4 ;Clear additional P that ;a554
ILDB T4,T3 ;Get next byte (word) ;a554
MOVEM T4,P2 ;Save it in P2 ;a554
MOVN T1,T1 ;MAKE NEGATIVE ;m554
HRLI T1,SZ%RF(RF) ;GET TO WHERE SYM WDS STORED
MOVSM T1,DD ;NOW AOBJ PTR TO SYM VALS
;Loop through symbol table looking for value
; If not found, give error
DSBVLP: LOAD T2,SYV.VL(DD) ;GET CURR SYM'S VAL
IDIVI T2,^D36 ;Make word & bit offset
MOVEI T1,1 ;MAKE A BIT
LSH T1,(T3) ;SHIFT INTO POSITION
TDNN T1,P1(T2) ;IS CURR VAL SUBSET OF ACTU VALUE?;m554
JRST NOTSVS ;NO
ANDCAM T1,P1(T2) ;Clear it ;a554
LOAD T5,SYV.NM(DD) ;GET PTR OF NAME
MOVEI T4,[ASCIZ/^A/] ;Presume last one
SKIPN P2 ;a554
SKIPE P1 ;MORE OPTIONS TO PUT OUT
MOVEI T4,[ASCIZ/^A+^N/] ;More follow
$CALLB TX$OUT,<T5,T4> ;PUT OUT SYM VAL
SKIPN P2 ;Check both Ps ;a554
JUMPE P1,[POPJ P,] ;ALL BITS ACCOUNTED FOR
NOTSVS: AOBJN DD,DSBVLP ;CHK NEXT SYM
ERRU (IVF) ;INVALID VALUE IN FIELD ;A511^^
$CASE (DT%SYZ) ; Symbolic value or zero ;A4
JUMPE P1,[POPJ P,] ;Type nothing if zero. ;A4
;Fall into DSYSYV if nonzero. ;A4
$CASE (DT%SYV) ; Symbolic value
LOAD T1,RF%CNT(RF) ;GET NUM OF SYM OPTS
MOVNS T1 ;MAKE NEG
HRLI T1,SZ%RF(RF) ;GET TO WHERE SYM WDS STORED
MOVSM T1,DD ;NOW AOBJ PTR
;Loop through symbols looking for the value.
; If found, print it. If not found, give error.
;DD/ AOBJ ptr to sym table.
;P1/ value to compare against.
DSYVLP: LOAD T1,SYV.VL(DD) ;GET CURR SYM'S VAL
CAME T1,P1 ;DOES ACTU VALUE MATCH?
JRST DSYABJ ;NO
LOAD T5,SYV.NM(DD) ;GET PTR OF NAME
MOVEI T4,[ASCIZ/^A/] ;Presume last 1
$CALLB TX$OUT,<T5,T4> ;PUT OUT SYM VAL
POPJ P,
DSYABJ: AOBJN DD,DSYVLP ;CHK NEXT SYM
ERRU (IVF) ;INVALID VALUE IN FIELD
ARYVAL:
MOVEI T1,RF%NAM(RF) ;PREP TO OUTPUT NAME
MOVEM T1,ARYNAM
SETZM ARYIDX ;INIT INDEX
ARYVLP:
LDB T4,RF%BP(RF) ;GET CURR VALUE
JUMPE T4,ARYVL1 ;NOTHING
$CALLB TX$OUT,<ARYNAM,ARYIDX,T4,ARYFMT> ;OUTPUT IT
ARYVL1: AOS ARYIDX ;HOP INDEX
ADDI RF,SZ%RF ;GET TO NEXT
LOAD T1,RF%FLAG(RF) ;MORE ENTRIES
TXNN T1,RF%ARY ;CHK IT?
POPJ P, ;DONE
JRST ARYVLP ;NO, PROC ANOTHER
;
; DDAVAL - DISPLAY THE CURRENTLY IDENTIFIED DATAFIELD
;
DDAVAL: LOAD T4,UF.TYP(RF) ;GET DATA TYPE TO USE
CASES T4,MX%DFT
$CASE (DFT%SIX) ;SIXBIT DATA
MOVEI TAP,6 ;SIXBIT BYTES
JRST DDAVSTR ;STRING MERGE
$CASE (DFT%EBC) ;EBCDIC DATA ;M501vv
MOVNI TAP,40 ;EBCDIC BYTES -- NETATIVE VALUE IS FLAG
JRST DDAVSTR ;STRING MERGE
$CASE (DFT%AS) ;ASCII DATA ;M411
$CASE (DFT%FIL) ;FILE BYTES
$FETCH T4,FAB,(PB) ;GET FAB PTR
JUMPE T4,L$ERRU(RNC) ;DOESNT PT TO FAB
$FETCH TAP,BSZ,(T4) ;FIND BYTE SIZE OF FILE
DDAVSTR:
$FETCH T1,RBF,(PB) ;GET REC LOCATION
HRLI T1,440000 ;WORD-ALIGNED BP
STOR TAP,BP.SIZ+T1 ;MERGE BYTE SIZE WITH BP
LOAD T2,UF.POS(RF) ;SELECT BYTE TO POSIT TO
ADJBP T2,T1 ;POSIT TO RIGHT BYTE
LOAD T3,UF.SIZ(RF) ;GET FIELD SIZE
DMOVEM T2,STRIPT
;Find datatype (from byte size at the moment...)
MOVEI T3,1 ;Assume ASCII
CAIN TAP,6 ;Sixbit?
MOVEI T3,0
CAIN TAP,^D9 ;EBCDIC?
MOVEI T3,2
MOVEM T3,STRIPT+2 ;Save
$CALLB TX$OUT,<[STRIPT],DISSTR> ;TYPE VALUE OUT
POPJ P,
$CASE (DFT%PAC) ;PACKED DECIMAL DATA ;A411
MOVEI TAP,9 ;9-BIT BYTES
$FETCH T1,RBF,(PB) ;GET REC LOCATION
HRLI T1,440000 ;WORD-ALIGNED BP
STOR TAP,BP.SIZ+T1 ;MERGE BYTE SIZE WITH BP
LOAD T2,UF.POS(RF) ;SELECT BYTE TO POSIT TO
ADJBP T2,T1 ;POSIT TO RIGHT BYTE
LOAD T3,UF.SIZ(RF) ;GET FIELD SIZE
; DMOVEM T2,STRIPT
; MOVEI T3,3
; MOVEM T3,STRIPT+2 ;Save
$CALLB TX$OUT,<T2,DABPAC> ;TYPE VALUE OUT
POPJ P,
$CASE (DFT%DEC) ;INTEGER
$FETCH T2,RBF,(PB) ;GET REC LOCATION
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD
$CALLB TX$OUT,<0(T2),DABDEC> ;OUTPUT IT
POPJ P,
$CASE (DFT%OCT) ;OCTAL NUMBER
$FETCH T2,RBF,(PB) ;GET REC LOCATION
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD
$CALLB TX$OUT,<0(T2),DABOCT>
POPJ P,
$CASE (DFT%FLO) ;FLOATING POINT ;A411
$FETCH T2,RBF,(PB) ;GET REC LOCATION
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD
$CALLB TX$OUT,<0(T2),DABFLO>
POPJ P,
$CASE (DFT%DOU) ;DOUBLE FLOATING POINT ;A411
$FETCH T2,RBF,(PB) ;GET REC LOCATION ;A411
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD ;A411
$CALLB TX$OUT,<T2,DABDOU> ;A411
POPJ P, ;A411
$CASE (DFT%GFL) ;GFLOATING POINT ;A411
$FETCH T2,RBF,(PB) ;GET REC LOCATION ;A411
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD ;A411
$CALLB TX$OUT,<T2,DABGFL> ;A411
POPJ P, ;A411
$CASE (DFT%LON) ;LONG INTEGER ;A411
$FETCH T2,RBF,(PB) ;GET REC LOCATION ;A411
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD ;A411
$CALLB TX$OUT,<T2,DABLON> ;OUTPUT IT ;A411
POPJ P, ;A411
$CASE (DFT%UNS) ;UNSIGNED INTEGER ;A411
$FETCH T2,RBF,(PB) ;GET REC LOCATION ;A411
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD ;A411
$CALLB TX$OUT,<(T2),DABUNS> ;OUTPUT IT ;A411
POPJ P, ;A411
SUBTTL PROCESS EXIT CMD
; DO.DDT - ENTERS DDT (DO RMSDEB$G TO RETURN TO RMSDEB)
; NOTES:
; TO RETURN TO RMSDEB FROM DDT, THE USER TYPES RMSDEB$G
DO.DDT::
IFN TOP$10,<MOVE T1,.JBDDT##> ;GET LOC OF DDT
IFN TOP$20,<MOVE T1,770000> ;DITTO
JUMPN T1,RTRUE ;Return if there is a DDT there ;M###
IFN TOP$20,< ;A###
MOVEI T1,.FHSLF ;Set up to save original ;A###
GEVEC% ; entry vector (returned in T2) ;A###
MOVEM T2,T3 ;A###
MOVSI T1,(GJ%SHT+GJ%OLD) ;Set up for GTJFN% ;A###
HRROI T2,[ASCIZ /SYS:UDDT.EXE/];
GTJFN% ;
ERJMP NODDT ;Catch errors ;A###
HRLI T1,.FHSLF ;Set up for GET% ;A###
GET% ;Merge DDT into address space ;A###
MOVEI T1,.FHSLF ;Set up to restore ;A###
MOVE T2,T3 ; original ;A###
SEVEC% ; entry vector ;A###
MOVE T1,116 ;Get symbol table ptr ;A###
MOVEM T1,@770001 ;Save it for DDT ;A###
MOVE T1,117 ;Get undef symbol table ptr ;A###
MOVEM T1,@770002 ;Save it too ;A###
JRST DO.DDT ;There is a DDT now. ;A###
NODDT: HRROI T1,[ASCIZ /?Can't Find SYS:UDDT.EXE
/] ;A###
PSOUT% ;A###
HALTF% ;A###
JRST DO.DDT ;Try again. ;A###
> ;A###
; DO.EXIT - EXIT TO MONITOR
;
DO.EXIT::
IFN TOP$10,<EXIT 1,>
IFN TOP$20,<HALTF%>
JRST RTRUE ;HE CONTINUED
SUBTTL HELP COMMAND
DO.HELP::
$CALLB TX$OUT,<[HLPMSG],ASCSTR> ;Don't worry about up-arrows.
JRST RTRUE
HLPMSG:
ASCIZ ?The RMSDEB commands are:
$name executes the corresponding RMS command
ASSIGN gives specified name to block at specified address
CHANGE changes a field to the value specified in the command
DDT enters DDT (to return type RMSDEB$G)
DEFINE initializes block and gives it the specified name
DISPLAY outputs the specified fields to the terminal
EXIT returns to the EXEC (you may CONTINUE)
HELP outputs this message
INFO describes state of RMSDEB
TAKE executes the RMSDEB commands in specified file
UNDEFIN removes a name created by DEFINE
?
SUBTTL PROCESS THE INFO CMD
; DO.INFO - LIST OUT SPECIFIED TYPE OF INFO
; NOTES:
; INFO DATAF!FABS!RABS!XABS!ALL
DO.INFO::
$P (KEYW)
CASES T1,MX%INF
$CASE (INF%CON)
INFCON: SKIPN CURRAB ;A CURR RAB?
JRST [$CALLB TX$OUT,<CONFNC> ;NO, "no current RAB"
JRST CONN1]
$CALLB TX$OUT,<CRABNM,CONFCR> ;PUT IT OUT
CONN1: MOVE T4,CSTYPE ;GET STRING DAT TYPE
;"Current RAB is <data-type> at <position>"
$CALLB TX$OUT,<DATTYP(T4),CPOSIT,CONFDD>
JRST RTRUE
$CASE (INF%XAB)
MOVEI T1,XA$TYP ;PICK UP ONLY XABS
JRST GODUMP
$CASE (INF%RAB)
MOVEI T1,RA$TYP ;PICK UP ONLY RABS
JRST GODUMP
$CASE (INF%FAB)
MOVEI T1,FA$TYP ;PICK UP ONLY FABS
JRST GODUMP
$CASE (INF%DAT)
MOVEI T1,DA$TYP ;INDIC DATA FIELDS
GODUMP: MOVEM T1,TYPBLK ;SAVE TYPE OF BLOCK
PUSHJ P,DUMPAB ;DUMP THE BLOCKS
JRST RTRUE
$CASE (INF%ALL)
SETOM TYPBLK ;INDIC ALL
PUSHJ P,DUMPAB ;DUMP 'EM
$CALLB TX$OUT,<[[0]]> ;BLANK LINE
JRST INFCON ;PUT OUT CONTEXT INFO TOO
; DUMPAB - SCAN PRIVATE SYM TAB, PICKING OUT INDICATED TYPE BLKS
; ARGUMENTS:
; TYPBLK = -1 OR TYPE TO SCAN FOR
DUMPAB: PUSHJ P,%SAVEP ;Save some acs.
MOVE P1,TYPBLK ;GET ARGBLK TYPE
MOVEI DD,DDTAB ;PT TO BEGINNING OF PRIVATE SYMTAB
;(Local section ptr)
DUABLP: SKIPN 0(DD) ;IS THE CELL OCCUPIED?
JRST DUABLE ;NO
MOVE PB,DD.VAL(DD) ;GET ARGBLK PTR
$FETCH T1,BID,(PB) ;GET TYPE
JUMPL P1,DUADSP ;IS A TYPE SPECIFIED?
CAME T1,P1 ;YES, A MATCH?
JRST DUABLE ;NO
;We want to see this entry. Dispatch on its type.
DUADSP: CASES T1,XA$TYP ;TYPE RIGHT MSG
$CASE (FA$TYP)
$FETCH T2,FNA,(PB) ;GET FILE SPEC PTR
SKIPN T2 ;IS THERE A FILE PTR?
MOVEI T2,[ASCIZ/None/] ;NO
$FETCH T1,JFN,(PB) ;GET JFN FIELD
MOVEI T3,[0] ;PRESUME NOT OPEN
SKIPE T1 ;CHK NOW
MOVEI T3,[ASCIZ/ (Open)/] ;OPEN
$CALLB TX$OUT,<0(DD),T2,T3,FABINF> ;Put out "NAME TYPE"
JRST DUABLE
$CASE (RA$TYP)
$FETCH T1,ISI,(PB) ;CHK IF CONNECTED
MOVEI T2,[0] ;ASSUME NOT
SKIPE T1 ;CHK NOW
MOVEI T2,[ASCIZ/Connected/]
$CALLB TX$OUT,<0(DD),T2,RABINF> ;PUT OUT "NAME TYPE"
JRST DUABLE
$CASE (XA$TYP)
$FETCH T5,COD,(PB) ;GET XAB TYPE
$CALLB TX$OUT,<0(DD),XABTYP(T5),XABINF> ;Put out "NAME TYPE"
JRST DUABLE
$CASE (DA$TYP)
LOAD T3,UF.POS(PB) ;GET POSITION
LOAD T4,UF.SIZ(PB) ;SIZ
LOAD T5,UF.TYP(PB) ;DATA TYPE CODE
CAIL T5,DFT%INT ;NUMERIC?
JRST TYPNUM ;YES
ADD T4,T3 ;POS+SIZ=END POS +1
SUBI T4,1 ;FIX IT
$CALLB TX$OUT,<0(DD),DATTYP(T5),T3,T4,DASINF> ;;PUT OUT "NAME TYPE"
JRST DUABLE
TYPNUM: $CALLB TX$OUT,<0(DD),DATTYP(T5),T3,DAIINF> ;PUT OUT "NAME TYPE"
;Here when we have printed out an entry.
DUABLE: ADDI DD,SZ%DD ;HOP TO NEXT ENTRY
CAMGE DD,DDCURR ;HIT LIMIT?
JRST DUABLP ;NO
POPJ P, ;YES, RETURN
SUBTTL ROUTINE TO FLUSH(DELETE) A FAB , RAB, OR XAB NAME FROM TABLE
; DO.UNDEFINE - REMOVES NAME AND STORAGE FOR A NAME CREATED BY DEFINE
; NOTES:
; UNDEFINE name, name, ...
DO.UNDEFINE::
CUNDLP:
$CALL SY.GET ;GET SYMBOL NAME
JUMPF CUNDL2
JUMPE T2,CUNDL2 ;MUST BE PRIVATE SYMBOL
SETZM 0(T2) ;KLUDGE, JUST 0 SYM NAME
CAMN T1,CURRAB ;UNDEF CURR RAB?
SETZM CURRAB ;YES, LEAVE NAME FOR INFO
JRST CUNDL3
CUNDL2: $CALLB TX$OUT,<R50VAL,DB.NND> ;TELL USER
CUNDL3: $CALL P$COMMA ;MORE IN LIST?
JUMPT CUNDLP ;YES
JRST RTRUE ;NO, ALL DONE
SUBTTL MEMORY MGR (TRIVIALIZED)
; M.INIT - SET INIT VALS FOR POINTERS
;
M.INIT::
SKIPE DDCURR ;SETUP YET?
JRST RTRUE ;YES
MOVEI T1,DDTAB ;PT TO BEGINNING OF TABLE
MOVEM T1,DDCURR
MOVEI T1,ARBTAB ;DITTO
MOVEM T1,ARBCURR
JRST RTRUE
; M.ALC - ALLOCATES SPECIFIED NUMBER OF WORDS
; ARGUMENTS:
; T1 = # OF WDS TO ALLOC
; RETURNS:
; T1 = PTR TO WHAT ALLOC
M.ALC: MOVE T2,T1 ;GET AMT TO ALLOC
MOVE T1,ARBCURR ;CURR SPOT IN PRIVATE TABLE
ADD T2,ARBCURR ;SAVE NEW 1ST FREE
CAIL T2,ARBTAB+SZ%ARB-1 ;HIT LIMIT
ERRU (TFU) ;YES, TAB FULL
MOVEM T2,ARBCURR ;SAVE NEW 1ST FREE
POPJ P,
SUBTTL SYMBOL PROCESSOR
R50TAB:
DEFINE ZW$R50(CMT$)<0> ;6 0 CODES
DEFINE IW$R50(CD$)<BYTE(6)CD$,CD$+1,CD$+2,CD$+3,CD$+4,CD$+5>
DEFINE EW$R50(A$,B$,C$,D$,E$,F$)<BYTE(6)A$,B$,C$,D$,E$,F$>
ZW$R50(0)
ZW$R50(6)
ZW$R50(14)
ZW$R50(22)
ZW$R50(30)
ZW$R50(36)
EW$R50 46,47,0,0,0,0 ;44
EW$R50 0,0,0,0,45,0 ;52
IW$R50(1) ;60
EW$R50 7,10,11,12,0,0 ;66
EW$R50 0,0,0,0,0,13 ;74
IW$R50(14) ;102=B
IW$R50(22) ;110
IW$R50(30) ;116
IW$R50(36) ;124
EW$R50 44,0,0,0,0,0 ;132
EW$R50 0,13,14,15,16,17 ;140
IW$R50(20) ;146
IW$R50(26) ;154
IW$R50(34) ;162
EW$R50 42,43,44,0,0,0 ;170
ZW$R50 ;176
; SY.STOR - STORE SYMBOL IN PRIVATE TABLE
; ARGUMENTS:
; T1 = PTR TO ASCIZ STRING TO STORE
; RETURNS:
; TF = TRUE IF SYMBOL NOT ALREADY IN TABLE, FALSE OTHERWISE
; T1 = SYMBOL NODE ADDRESS
SY.STOR:
MOVE T5,T1 ;PT TO STRING
HRLI T5,(POINT 7,) ;MAKE BP TO IT
$CALL SYMR50 ;BUILD RADIX50 VALUE INTO R50VAL
$CALL SYMPRV ;SEARCH PRIVATE SYMBOL TABLE
JUMPT RFALSE ;FAIL IF ALREADY THERE
MOVE T1,DDCURR ;CURR SPOT IN PRIVATE TABLE
CAIL T1,DDTAB+SZ%DDT ;HIT LIMIT
ERRU (TFU) ;YES, TAB FULL
MOVEI T2,SZ%DD(T1) ;HOP TO NEXT FREE SLOT
MOVEM T2,DDCURR ;SAVE NEW 1ST FREE
MOVE T2,R50VAL ;PUT SYMBOL IN TABLE
STOR T2,DD.NAM(T1)
JRST RTRUE ;RET SUC
; SY.GET - PICK UP FIELD TOKEN AND FIND IN SYMTAB
; RETURNS:
; TF = -1 IF SYMBOL FOUND
; 0 IF NOT FOUND
; T1 = VALUE OF SYMBOL
; T2 = ADDRESS OF SYMTAB NODE IF PRIV TAB OR 0 IF DDT TABLE
SY.GET: $P (FLD) ;GET TOKEN
MOVEI T5,TK.VAL(T1) ;PT TO STRING
PJRST SYFIND ;Find symbol, return with SUCC/FAIL
; SY.FIND - FIND A SYMBOL
; ARGUMENTS:
; T1 = PTR TO SYMBOL NAME
; RETURNS: (AS FOR SY.GET)
; TF = -1 IF SYMBOL FOUND
; 0 IF NOT FOUND
; T1 = VALUE OF SYMBOL
; T2 = ADDRESS OF SYMTAB NODE IF PRIV TAB OR 0 IF DDT TABLE
SY.FIND::
MOVE T5,T1 ;PT TO STRING
$CALL SYFIND ;WITH T5
JUMPF [POPJ P,] ;TRANS RET FAILURE
$FETCH T3,BID,(T1) ;CHK WHAT FND
CAIE T3,RA$TYP ;RAB?
JRST RTRUE ;NO, JUST RET SUCC
MOVEM T1,CURRAB ;SAVE PTR TO IT
PUSH P,R50VAL ;SAVE ITS NAME
POP P,CRABNM
JRST RTRUE
SUBTTL SYMBOL TABLE SUBROUTINES
; SYFIND - DOES REAL WORK OF FINDING SYMBOL
; ARGUMENTS:
; T5 = PTR TO ASCIZ STRING
; RETURNS: (AS FOR SY.GET)
; TF = -1 IF SYMBOL FOUND
; 0 IF NOT FOUND
; T1 = VALUE OF SYMBOL
; T2 = ADDRESS OF SYMTAB NODE IF PRIV TAB OR 0 IF DDT TABLE
SYFIND: HRLI T5,(POINT 7,) ;MAKE BP TO IT
$CALL SYMR50 ;BUILD RADIX50 VALUE INTO R50VAL
$CALL SYMPRV ;SEARCH PRIVATE SYMBOL TABLE
MOVE T2,T1 ;PRESERVE SYMTAB ADDR
JUMPT SYFND1 ;SUC IF ALREADY THERE
$CALL SYMDD
JUMPF [POPJ P,] ;FAIL IF NOT THERE EITHER
SETZ T2, ;DON'T PT INTO DDT TABLE
SYFND1: MOVE T1,DD.VAL(T1) ;Return with val
POPJ P,
; SYMR50 - CONVERT ASCII SYMBOL TO RADIX 50
; ARGUMENTS:
; T5 = BP TO ASCIZ STRING
; RETURNS:
; R50VAL = RADIX50 VAL
SYMR50: MOVEI T1,6 ;MAX SIGNIF CHAR
SETZ T2, ;START WITH 0 VAL
SR50LP: ILDB T3,T5 ;GET CHAR FROM SOURCE
JUMPE T3,SR50EX ;EXIT ON NUL
IMULI T2,50 ;MOVE OVER BY RADIX
ADJBP T3,[POINT 6,R50TAB] ;GET TO RIGHT ENTRY
ILDB T3,T3 ;GET MAPPED VAL
ADD T2,T3 ;MERGE IN CURR LOW-ORDER BYTE
SOJG T1,SR50LP ;KEEP SCANNING IF NOT TO 6TH CHAR
SR50EX: MOVEM T2,R50VAL ;PERMANIZE SYMBOL
POPJ P, ;RETURN
; SYMPRV - SEARCH PRIVATE SYMBOL TABLE FOR R50VAL
; RETURNS:
; TF = TRUE IF SYMBOL FOUND
; T1 = PTR TO SYMBOL NODE
SYMPRV: 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,RFALSE ;PRIVATE SYMTAB EMPTY
HRL T5,T4 ;NOW AOBJ PTR
JRST SYMERG
; SYMDD - SEARCH DDT SYMBOL TABLES FOR R50VAL
; RETURNS:
; TF = TRUE IF SYMBOL FOUND
; T1 = PTR TO SYMBOL NODE
SYMDD:
IFN TOP$20,<
SKIPE T5,770001 ;Try TOPS-20 SYMTAB location ;A4
SKIPN T5,(T5) ;It was nonzero. Fetch pointer ;A4
>; End TOP$20
SKIPN T5,116 ;Try TOPS-10 SYMTAB location (.JBSYM)
JUMPE T5,RFALSE ;NO SYMS, NO FIND ;M4
SYMERG: LOAD T1,DD.NAM(T5) ;PICK UP SYMBOL FROM TABLE
CAMN T1,R50VAL ;MATCH?
JRST SYMEX ;YES
AOBJN T5,.+1 ;2ND WORD IN TAB ENTRY
AOBJN T5,SYMERG ;LOOP IF MORE TO CHK
JRST RFALSE ;SYM NOT FND
SYMEX:
HRRZ T1,T5 ;ISOL SYM NODE PTR
JRST RTRUE ;RET SUC
; Returns, and routine to save Perm AC's.
RFALSE: TDZA TF,TF ;RETURN FALSE
RTRUE: SETO TF, ;RETURN TRUE
POPJ P,
;Routine to save perm acs, which will be restored upon POPJ
%SAVEP: MOVEM P1,SVP1T ;Save P1, get return address
EXCH P1,(P) ;SAVE P1 AND GET RETURN ADDRESS
PUSH P,P2 ;SAVE P2
PUSH P,PB ;SAVE PB
PUSH P,DD ;SAVE DD
PUSH P,RF ;SAVE RF
PUSHJ P,SVTJMP
SOS -5(P)
POP P,RF
POP P,DD
POP P,PB
POP P,P2
POP P,P1
AOS (P) ;Make skip return if needed
POPJ P, ;RETURN
SVTJMP: HRLI P1,(1B0) ;Make IFIW
EXCH P1,SVP1T ;Save ret inst, restore P1
JRST @SVP1T ;Jump to continue transfer
$ENDSCOPE (TOP-LEVEL)
END