Trailing-Edge
-
PDP-10 Archives
-
cuspbinsrc_2of2_bb-fp63b-sb
-
10,7/rms10/rmssrc/debact.mac
There are 7 other files named debact.mac in the archive. Click here to see a list.
TITLE DEBACT - ACTION ROUTINES FOR RMSDEB
SUBTTL S. COHEN
SEARCH RMSMAC,RMSINT
$PROLOG(DEB)
DEFINE $$CPON(X)<DB.> ;;FORCE MSG NAME DOTTED
; $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>
>
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==20 ;WDS IN KEY BUF
SZ%ARB==1600
SZ%DDT==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,2) ;SPACE FOR STRING PTR
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
DISSTR: $FMT(,<-CA%STP>)
FNACOL: $FMT(,<-CA%ASZ,: ,-CA%NOCR>)
FABINF: $FMT(,<-CA%R50, FAB ,-CA%ASZ,-CA%ASZ>)
RABINF: $FMT(,<-CA%R50, RAB ,-CA%ASZ>)
XABINF: $FMT(,<-CA%R50, ,-CA%ASZ, XAB>)
DAIINF: $FMT(,<-CA%R50, ,-CA%ASZ, ,at W,-CA%NUM>)
DASINF: $FMT(,<-CA%R50, ,-CA%ASZ, ,B,-CA%NUM, thru B,-CA%NUM>)
CONFCR: $FMT(,<Current RAB is ,-CA%R50>)
CONFNC: $FMT(,<No current RAB>)
CONFDD: $FMT(,<DEFINE DATA default is ,-CA%ASZ, at ,-CA%NUM>)
ARYFMT: $FMT(,<-CA%ASZ,-CA%NUM,: ,-CA%NUM>)
DABFMT: ;FMT STATS FOR SIMPLE DISPLAY CASES
;IMPORTANT: 1ST 5 ENTRIES IN DT STRUCT
DABDEC: [$FMT(,<-CA%NUM>)] ;DT%DEC
[$FMT(,<-CA%DT>)] ;DT%DATE
DABOCT: [$FMT(,<-CA%OCT>)] ;DT%OCT
[$FMT(,<-CA%ASZ>)] ;DT%STR
[$FMT(,<-CA%OCT>)] ;DT%SYA
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/]
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,<CCL,MDI,REC,SQD,TRM>)
$RF (FB,FAC,<DEL,GET,PUT,TRN,UPD>)
$RF (FB,FNA)
$RF (FB,FOP,<CIF,DFW,DRJ,SUP,WAT>)
$RF (FB,IFI)
$RF (FB,JFN)
$RF (FB,JNL)
$RF (FB,MRN)
$RF (FB,MRS)
$RF (FB,ORG,<SEQ,REL,IDX>)
$RF (FB,RAT,<BLK>)
$RF (FB,RFM,<VAR,STM,LSA,FIX>)
$RF (FB,SHR,<DEL,GET,PUT,TRN,UPD>)
$RF (FB,XAB)
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==$SH(INV)
F.FNA==DT%STR
F.MRN==DT%DEC
F.RFM==DT%SYV
F.JNL==$SH(INV)
F.XAB==DT%SYA
SUBTTL $RF DESCRIPTORS FOR RAB
RABTAB: $RF (RB,BID)
$RF (RB,BLN)
$RF (RB,STS)
$RF (RB,STV)
$RF (RB,BKT)
$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>)
$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.PAD==DT%OCT
SUBTTL $RF DESCRIPTORS FOR XAB
XABTAB: ;FOR DISPLAY ENTIRE-ARGLBK DISPATCH
XABKEY
XABAREA
XABDAT
XABSUM
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,<EBC,SIX,STG>)
$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
;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%STR
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
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
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
XABINI: ;INIT BLK ACCESSED INDEXED THRU XABINI
XKINI
XAINI
XDINI
XSINI
SUBTTL PROCESS ASSIGN, CHANGE, AND DEFINE DEFINE CMD
$SCOPE (DEFINE-BLOCK)
$LREG (DD) ;PTR TO ENTRY IN (DDT-LIKE) SYMTAB
$LREG (PB) ;PTR TO CURR RMS ARG BLK
$LREG (RF)
$LREG (P1)
$LREG (P2)
$LREG (IB)
$LOCALS
$WORD (BUFADD) ;ADDRESS OF BUFF TO USE IN EATDAT
$WORD (CHADAT) ;ON IF CHANGE DATA FLD
$ENDLOC
$PROC (DO.ASSIGN)
;
; DO.ASSIGN = INIT BLK FROM ADDRESS RATHER THAN BY ALLOCATION
; NOTES:
; ASSIGN (NAME) name (TO ADDRESS) octal-number
$P (FLD) ;PICK UP FIELD BEING DEFINED
MOVEM T1,T5 ;MAKE PTR TO FLDNAME PASSABLE
$CALL SY.STOR,<TK.VAL(T5)> ;PUT IN TABLE IF NOT ALREADY THERE
JUMPF L$ERRU(NAD) ;NAME ALREADY DEFINED
MOVEM T1,DD ;PRESERVE DD SYMBLK PTR
$P (NUM) ;GET THE ADDRESS
MOVEM T1,DD.VAL(DD) ;PUT IT AWAY
$FETCH T2,BID,(T1) ;CHK IF RAB
CAIE T1,RA$TYP ;IS IT?
RETT ;NO, DONE
$COPY CRABNM,R50VAL ;SAVE ITS NAME
MOVEM T1,CURRAB ;SAVE PTR TO IT
RETT
$ENDPROC
SUBTTL PROCESSOR FOR CHANGE CMD
$PROC (DO.CHANGE)
;
; 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, ...
;
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?
$SKIP ;YES
JUMPE PB,L$ERRU(NRC) ;NO RAB CURR
JRST CHGDAT ;MERGE THE DATA PATH
$ENDIF
MOVEM T1,PB ;PERMANIZE ARGBLK PTR
CHG.LP:
$CALL P$KEYW ;CHK IF ARGBLK FLD
JUMPT L$JUMP ;YES IF JUMP
$CALL SY.GET ;NO, IS DATAFLD
JUMPT CHGDAT ;PROCEED
$CALLB TX$TOUT,<[DB.NND##],R50VAL> ;TELL USER
$CALL P$NFLD ;HOP OVER VALUE
JRST L$IFX ;PROCEED TO NEXT FLD (OR EOL)
CHGDAT:
MOVEM T1,RF ;PERMANIZE FLD PTR
$CALL EATDAT ;PROCESS IT
JRST L$IFX
$JUMP ;YES, ARGBLK DATA
JUMPE T1,CHGKEY ;ACTU NO, IS KEY-BUFFER
MOVEM T1,RF ;PERMANIZE IT
$CALL EATRFV ;EAT ARGBLK VALUE
$ENDIF
$CALL P$COMMA ;MORE IN LIST?
JUMPT CHG.LP ;YES
RETT
CHGKED:
JUMPE PB,L$ERRU(NRC) ;NO RAB CURR
CHGKEY:
MOVEI RF,KEYINI ;USE DUMMY UF
$CALL EATKEY ;DO THE WORK
RETT
$ENDPROC
$UTIL (EATDAT)
;
; EATDAT - EAT USER DATA FLD VALUE
;
SETZM BUFADD(CF) ;USE RBF BELOW
LOAD T1,UF.TYP(RF) ;GET TYPE OF FLD
CASES T1,MX%DFT
$CASE (DFT%AS)
$P (QSTR,WDT) ;PICK UP THE STRING
SETZM TAP ;NO CONVERSION
MOVSI T5,440700 ;ASCII DEST
JRST EATSTR ;MERGE
$CASE (DFT%SIX)
$P (QSTR,WDT) ;PICK UP THE STRING
MOVEI TAP,40 ;CONV FACTOR
MOVSI T5,440600 ;SIXBIT BYTE INFO
EATSTR:
MOVEI T3,TK.VAL(T1) ;GET ADDR OF NEW VAL
HRLI T3,440700 ;SETUP BP TO IT
SKIPN T1,BUFADD(CF) ;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(CF) ;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:
LC T1,T3 ;GET A CHAR
JUMPE T1,EASCLE ;END?
SUB T1,TAP ;CONV IF NECES
DC T1,T4 ;NO, PUT IT AWAY
SOJG T5,EASCLP ;MORE LEFT?
RETURN ;FILLED FLD
EASCLE:
MOVEI T1," " ;PAD WITH SPACES
SUB T1,TAP ;CONVERT IF NECES
DC T1,T4 ;PUT IT AWAY
SOJG T5,.-1 ;DONE YET
RETURN
$CASE (DFT%FIL)
$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,7 ;ASCII?
JRST L$CASE(DFT%AS) ;YES
CAIN T1,6 ;SIXBIT?
JRST L$CASE(DFT%SIX) ;YES
ERRU (BSI) ;BYTE SIZE ILLEGAL FOR INPUT
$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
RETURN
;
$ENTRY (EATKEY)
;
; EATKEY - ENTER DATA IN KEY BUFFER
;
$FETCH T3,KBF,(PB) ;SET UP BUFF LOC IMMED
JUMPN T3,L$IFX ;IS THERE 1?
$CALL M.ALC,<[SZ%KBUF]> ;KEY BUFFER SET FROM CONSTANT
;...KSZ MAY BE SMALL FOR GENERIC KEY
$STORE T1,KBF,(PB) ;PUT AWAY PTR
MOVEM T1,T3 ;SO CAN BE USED AFTER P$NUM
$ENDIF
$CALL P$NUM ;THE EASY CASE?
JUMPF L$IFX ;NO, IF JUMP
MOVEM T1,0(T3) ;PUT IT AWAY
RETURN ;DONE
$ENDIF
MOVEM T3,BUFADD(CF) ;PERMANIZE START ADDR
$CALL P$CURR ;PREP TO COMPUTE LEN OF ENTERED STRING
MOVEI T1,TK.VAL(T1) ;PT TO STRING
HRLI T1,440700 ;...AND MAKE IT A BP
SETZM T3 ;INIT CNT
LC 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 L$CASE(DFT%FIL) ;PASSING BUFADD
$ENDUTIL
$PROC (DO.DEFINE)
;
; DO.DEFINE - PROCESS DEFINE CMD
;
$P (KEYW) ;PICKUP THE KEYWORD VAL
CASES T1,MX%DEF ;DISPATCH OFF TYPE OF BLK
$CASE (DEF%DAT)
$CALL ALCBLK,<FLDINI> ;DATA FIELD DESC INIT VALS
$P (KEYW) ;PICK UP DATA TYPE
STOR T1,UF.TYP(PB) ;STORE DATA TYPE
CAIE T1,DFT%INT ;INTEGER?
$SKIP ;YES
$CALL DEDINT ;PROC INTEGER
JRST L$IFX
$NOSKIP
$CALL DEDSTR ;PROC STRING
$ENDIF
RETT
DEDERR:
SETZM 0(DD) ;CLEAR OUT ABORTED DEF
ERRU (NPS) ;TELL USER
$CASE (DEF%RAB)
$CALL ALCBLK,<RABINI> ;SETUP A RAB
$COPY CRABNM,R50VAL ;SAVE ITS NAME
MOVEM PB,CURRAB ;SAVE PTR TO IT
$CALL SY.GET ;GET FAB PTR
JUMPT L$IFX ;JUMP IF FAB OK
$CALLB TX$TOUT,<[DB.FNU##]> ;FAB NAME UNKNOWN, CON WITH INIT VAL FAB
MOVEI T1,FABINI ;USE INIT VALUES FAB RATHER THAN ABORT
$ENDIF
$STORE T1,FAB,(PB) ;PUT AWAY PTR
$CALL DEFSWIT
$FETCH T5,USZ,(PB) ;GET SIZE TO ALLOC
JUMPN T5,L$IFX ;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 T5,1(T1) ;ADJ FOR POSSIB TRUNC
$STORE T5,USZ,(PB) ;PUT IT AWAY
$ENDIF
$CALL M.ALC,<T5> ;GET USER BUFF SIZE
$STORE T1,UBF,(PB) ;PUT AWAY PTR
$STORE T1,RBF,(PB) ;PUT AWAY PTR
$FETCH T5,RSZ,(PB) ;GET SIZE TO ALLOC
JUMPN T5,L$IFX ;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
$ENDIF
RETT
$CASE (DEF%FAB)
$CALL ALCBLK,<FABINI> ;SETUP A FAB
$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
RETT
$CASE (DEF%XAB)
$CALL ALCBLK,<0> ;INDIC INIBLK DET IN ALCBLK
$CALL DEFSWIT ;PROCESS SWITCHES
RETT
SUBTTL SUBROUTINES COMMON TO ASSIGN, DEFINE, AND CHANGE
$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
MOVEI IB,@INIBLK(AP) ;MATER PTR TO INIT VAL BLK
$P (FLD) ;PICK UP FIELD BEING DEFINED
MOVEM T1,T5 ;MAKE PTR TO FLDNAME PASSABLE
$CALL SY.STOR,<TK.VAL(T5)> ;PUT IN TABLE IF NOT ALREADY THERE
JUMPF L$ERRU(NAD) ;NAME ALREADY DEFINED
MOVEM T1,DD ;PRESERVE DD SYMBLK PTR
JUMPN IB,L$IFX ;BLK PASSED?
$P (KEYW) ;NO, PICK UP XAB TYPE
MOVE IB,XABINI(T1) ;GET INIT ARGBLK ADDR
$ENDIF
$FETCH (T5,BLN,(IB)) ;GET LEN OF ARGBLK NEEDED
$CALL M.ALC,<T5> ;ALLOC A BLK
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
$FETCH (T2,BLN,(IB)) ;GET ARGBLK'S LEN BACK
ADDI T2,-1(PB) ;GET LAST WORD OF BLK
BLT T1,0(T2) ;COPY INIT VALS TO ALLOC BLK
RETURN
$ENDUTIL
$UTIL (ALCSTR)
;
; ALCSTR - ALLOC SPACE FOR AND COPY STRING TO SPACE ALLOCATED
; RETURNS:
; T1 = PTR TO ALLOCATED BLK
$CALL P$NFLD ;GET DATA FOR CURR FIELD
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
$CALL M.ALC,<P2> ;GRAB THE SPACE
HRRM T1,P1 ;FINISH SETTING UP BLT AC
ADDM T1,P2 ;END OF BLT
BLT P1,-1(P2) ;MOVE THE DATA
RETURN ;WITH T1 = PTR TO BLK
$ENDUTIL
$UTIL (DEDINIT)
;
; DEDINIT - PROCESS INTEGER DATA FIELD
;
DEDINT:
$CALL P$NUM ;WORD OFFSET SPEC?
MOVE T3,CSTYPE ;GET STRING TYPE
MOVE T3,BPWVEC(T3) ;GET BYTES PER WORD
JUMPT L$IFX ;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
$ENDIF ;EXPLIC POS
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 L$RETT ;NO, DONE
$CALL P$KEYW ;IS THERE A VALUE?
JUMPF L$RETT ;NO, DONE
STOR T1,UF.TYP(PB) ;JUST EXPLODE INT TO DEC/OCT
RETURN ;DONE
$ENDUTIL
$UTIL (DEDSTR)
;
; DEDSTR - PROCESS STRING DATA FIELD
;
$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 FLD
MOVEM T1,CPOSIT ;PERMANIZE NEW DEFAULT
$COPY CSTYPE,UF.TYP(PB) ;UPDATE CURR STRING TYPE
RETURN
$ENDUTIL
$UTIL (DEFSWIT)
;
; DEFSWIT - SCANS PARSER OUTPUT TILL EOL
;
ESW.LP:
$CALL P$CFM ;IS IT EOL?
JUMPT L$RET ;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
$ENDUTIL
$UTIL (EATRFV)
;
; EATRFV - EAT RMS FIELD VALUE
;
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 L$RET ;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
RETURN
$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
RETURN
$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$IFX ;NO PLUS? THEN END OF SWITCH
DPB P1,RF.BP(RF) ;STORE AWAY ACCUM VAL
RETURN ;CHK FOR EOL
$ENDIF
JRST L$CASE(DT%SYB) ;GET NEXT VALUE
$CASF
ERRU (IER) ;INTERNAL ERROR
$ENDUTIL
SUBTTL PROCESS DISPLAY COMMAND
$PROC (DO.DISPLAY)
;
; DO.DISPLAY - DISPLAY USER FIELD OR ARG BLK
; NOTES:
; DISPLAY <argblk-NAME> [argblk-fld-list]
; DISPLAY [argblk-name] DATA!KEY-BUFFER!datfld-list
;
MOVE PB,CURRAB ;PRESUME USE CURRENT RAB
$CALL P$KEYW ;CHK FOR DATA or KEY-BUFFER
JUMPF L$IFX ;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
$ENDIF
$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?
$SKIP ;YES
JUMPE PB,L$ERRU(NRC) ;NO CURRENT RAB
JRST DSPDL1 ;MERGE THE DATA-LIST PATH
$ENDIF
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
MOVEM T1,RF ;PERMANIZE RMS FIELD DESCRIPTOR
$CALL DABVAL ;DISPLAY ONE VALUE
$CALL P$COMMA ;MORE IN LIST?
JUMPT DSPABL ;YES
RETT ;NO
DSPABA: ;DISPLAY ARGBLK
$FETCH T1,BID,(PB) ;GET ID
CASES T1,XA$TYP ;DISPATCH OFF IT
$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)
$FETCH T1,COD,(PB) ;GET CODE FIELD
MOVE RF,XABTAB(T1) ;PICKUP FLD TABLE FOR APPROP XAB TYPE
JRST L$CASX
$CASF
ERRU (IER)
$CASX
DABALP:
SKIPN 0(RF) ;THRU?
RETT ;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
DSPKEY:
$FETCH T2,KBF,(PB) ;GET KEY BUFF PTR
JUMPE T2,L$RETT ;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$TOUT,<DABDEC,T1> ;OUTPUT NUMBER
RETT
DSPDAL:
$CALL SY.GET ;DERIVE FLD PTR FROM CURR TOKEN
JUMPT L$JUMP ;VALID NAME
$CALLB TX$TOUT,<[DB.NND##],R50VAL> ;TELL USER
JRST L$IFX ;PROCEED
$JUMP
DSPDL1:
MOVEM T1,RF ;TREAT AS ARGBLK FLD (USE RF TO PT AT IT)
$CALL DDAVAL ;DISP DATA VAL
$ENDIF
$CALL P$COMMA ;CHK IF MORE IN LIST
JUMPF L$RETT ;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
$CALLB TX$TOUT,<[DISSTR],[STRIPT]> ;PUT OUT STRING
RETT
$UTIL (DABVAL)
;
; DABVAL - DISPLAY THE CURRENTLY IDENTIFIED ARGBLK FIELD
;
LOAD T1,RF.FLAG(RF) ;SEE IF ARRAY
TXNE T1,RF%INV ;INVISIBLE?
RETURN ;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,L$RET ;SKIP NULL VALUES
MOVEI T5,RF.NAM(RF) ;GET PTR TO TEXT
$CALLB TX$TOUT,<[FNACOL],T5> ;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)
$CASE (DT%DEC) ;DECIMAL NUMBER
$CASE (DT%OCT)
$CASE (DT%SYA)
$CASE (DT%STR)
$CALLB TX$TOUT,<DABFMT(T1),P1> ;PUT OUT THE SIMPLE CASES
RETURN
$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
DSYBLP:
LOAD T1,SYV.VL(DD) ;GET CURR SYM'S VAL
TDZN P1,T1 ;IS CURR VAL SUBSET OF ACTU VALUE?
$SKIP ;YES
LOAD T5,SYV.NM(DD) ;GET PTR OF NAME
MOVEI T4,[$FMT(,<-CA%ASZ>)] ;PRESUME LAST 1
SKIPE P1 ;MORE OPTIONS TO PUT OUT
MOVEI T4,[$FMT(,<-CA%ASZ,+,-CA%NOCR>)] ;MORE FOLLOW
$CALLB TX$TOUT,<T4,T5> ;PUT OUT SYM VAL
JUMPE P1,L$RET ;ALL BITS ACCOUNTED FOR
$ENDIF
AOBJN DD,DSYBLP ;CHK NEXT SYM
ERRU (IVF) ;INVALID VALUE IN FIELD
$CASE (DT%SYV)
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
DSYVLP:
LOAD T1,SYV.VL(DD) ;GET CURR SYM'S VAL
CAME T1,P1 ;DOES ACTU VALUE MATCH?
$SKIP ;YES
LOAD T5,SYV.NM(DD) ;GET PTR OF NAME
MOVEI T4,[$FMT(,<-CA%ASZ>)] ;PRESUME LAST 1
$CALLB TX$TOUT,<T4,T5> ;PUT OUT SYM VAL
RETURN
$ENDIF
AOBJN DD,DSYVLP ;CHK NEXT SYM
ERRU (IVF) ;INVALID VALUE IN FIELD
ARYVAL:
$COPY ARYNAM,I RF.NAM(RF) ;PREP TO OUTPUT NAME
SETZM ARYIDX ;INIT INDEX
ARYVLP:
LDB T4,RF.BP(RF) ;GET CURR VALUE
JUMPE T4,L$IFX ;NOTHING
$CALLB TX$TOUT,<[ARYFMT],ARYNAM,ARYIDX,T4> ;OUTPUT IT
$ENDIF
AOS ARYIDX ;HOP INDEX
ADDI RF,SZ%RF ;GET TO NEXT
LOAD T1,RF.FLAG(RF) ;MORE ENTRIES
TXNN T1,RF%ARY ;CHK IT?
RETURN ;DONE
JRST ARYVLP ;NO, PROC ANOTHER
$ENDUTIL
$UTIL (DDAVAL)
;
; DDAVAL - DISPLAY THE CURRENTLY IDENTIFIED DATAFIELD
;
LOAD T4,UF.TYP(RF) ;GET DATA TYPE TO USE
CASES T4,MX%DFT
$CASE (DFT%AS) ;ASCII DATA
MOVEI TAP,7 ;ASCII BYTES
JRST DDAVSTR ;STRING MERGE
$CASE (DFT%SIX) ;SIXBIT DATA
MOVEI TAP,6 ;SIXBIT BYTES
JRST DDAVSTR ;STRING MERGE
$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
$CALLB TX$TOUT,<[DISSTR],[STRIPT]> ;TYPE VALUE OUT
RETURN
$CASE (DFT%DEC) ;INTEGER
$FETCH T2,RBF,(PB) ;GET REC LOCATION
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD
$CALLB TX$TOUT,<DABDEC,0(T2)> ;OUTPUT IT
RETURN
$CASE (DFT%OCT) ;OCTAL NUMBER
$FETCH T2,RBF,(PB) ;GET REC LOCATION
$INCR T2,UF.POS(RF) ;GET TO RIGHT WORD
$CALLB TX$TOUT,<DABOCT,0(T2)>
RETURN
$ENDUTIL
SUBTTL PROCESS EXIT CMD
$PROC (DO.DDT)
;
; DO.DDT - ENTERS DDT (DO RMSDEB$G TO RETURN TO RMSDEB)
; NOTES:
; TO RETURN TO RMSDEB FROM DDT, THE USER TYPES RMSDEB$G
IFN TOP$10,<MOVE T1,.JBDDT##> ;GET LOC OF DDT
IFN TOP$20,<MOVE T1,770000> ;DITTO
RETT ;NO
$ENDPROC
$PROC (DO.EXIT)
;
; DO.EXIT - EXIT TO MONITOR
;
IFN TOP$10,<EXIT 1,>
IFN TOP$20,<HALTF%>
RETT ;HE CONTINUED
$ENDPROC
SUBTTL HELP COMMAND
$PROC (DO.HELP)
$CALLB TX$TOUT,<[RM$ASZ],[HLPMSG]>
RETT
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
?
$ENDPROC
SUBTTL PROCESS THE INFO CMD
$PROC (DO.INFO)
;
; DO.INFO - LIST OUT SPECIFIED TYPE OF INFO
; NOTES:
; INFO DATAF!FABS!RABS!XABS!ALL
$P (KEYW)
CASES T1,MX%INF
$CASE (INF%CON)
SKIPN CURRAB ;A CURR RAB?
$SKIP ;YES
$CALLB TX$TOUT,<[CONFCR],CRABNM> ;PUT IT OUT
JRST L$IFX
$NOSKIP
$CALLB TX$TOUT,<[CONFNC]> ;NO, TELL HIM
$ENDIF
MOVE T4,CSTYPE ;GET STRING DAT TYPE
$CALLB TX$TOUT,<[CONFDD],DATTYP(T4),CPOSIT>
RETT
$CASE (INF%XAB)
$CALL DUMPAB,<[XA$TYP]> ;PICK UP ONLY XABS
RETT
$CASE (INF%RAB)
$CALL DUMPAB,<[RA$TYP]> ;PICK UP ONLY RABS
RETT
$CASE (INF%FAB)
$CALL DUMPAB,<[FA$TYP]> ;PICK UP ONLY FABS
RETT
$CASE (INF%DAT)
$CALL DUMPAB,<[DA$TYP]> ;INDIC DATA FIELDS
RETT
$CASE (INF%ALL)
$CALL DUMPAB,<[-1]> ;INDIC ALL
$CALLB TX$TOUT,<[[-CA%EXIT]]> ;BLANK LINE
JRST L$CASE (INF%CON) ;PUT OUT CONTEXT INFO TOO
$UTIL (DUMPAB,<TYPBLK>)
;
; DUMPAB - SCAN PRIVATE SYM TAB, PICKING OUT INDICATED TYPE BLKS
; ARGUMENTS:
; TYPBLK = -1 OR TYPE TO SCAN FOR
MOVE P1,@TYPBLK(AP) ;GET ARGBLK TYPE
MOVEI DD,DDTAB ;PT TO BEGINNING OF PRIVATE SYMTAB
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,L$IFX ;IS A TYPE SPECIFIED?
CAME T1,P1 ;YES, A MATCH?
JRST DUABLE ;NO
$ENDIF
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$TOUT,<[FABINF],0(DD),T2,T3> ;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$TOUT,<[RABINF],0(DD),T2> ;PUT OUT "NAME TYPE"
JRST DUABLE
$CASE (XA$TYP)
$FETCH T5,COD,(PB) ;GET XAB TYPE
$CALLB TX$TOUT,<[XABINF],0(DD),XABTYP(T5)> ;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?
$SKIP ;NO
ADD T4,T3 ;POS+SIZ=END POS +1
SUBI T4,1 ;FIX IT
$CALLB TX$TOUT,<[DASINF],0(DD),DATTYP(T5),T3,T4> ;PUT OUT "NAME TYPE"
JRST L$IFX
$NOSKIP
$CALLB TX$TOUT,<[DAIINF],0(DD),DATTYP(T5),T3> ;PUT OUT "NAME TYPE"
$ENDIF
JRST DUABLE
DUABLE:
ADDI DD,SZ%DD ;HOP TO NEXT ENTRY
CAML DD,DDCURR ;HIT LIMIT?
RETURN ;YES
JRST DUABLP ;NO
$ENDUTIL
SUBTTL ROUTINE TO FLUSH(DELETE) A FAB , RAB, OR XAB NAME FROM TABLE
$PROC (DO.UNDEFINE)
;
; DO.UNDEFINE - REMOVES NAME AND STORAGE FOR A NAME CREATED BY DEFINE
; NOTES:
; UNDEFINE name, name, ...
CUNDLP:
$CALL SY.GET ;GET SYMBOL NAME
JUMPF L$JUMP
JUMPE T2,L$JUMP ;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 L$IFX
$JUMP ;UNKNOWN OR NOT PRIVATE SYMBOL
$CALLB TX$TOUT,<[DB.NND##],R50VAL> ;TELL USER
$ENDIF
$CALL P$COMMA ;MORE IN LIST?
JUMPT CUNDLP ;YES
RETT ;NO, ALL DONE
$ENDPROC
SUBTTL MEMORY MGR (TRIVIALIZED)
$PROC (M.INIT)
;
; M.INIT - SET INIT VALS FOR POINTERS
;
SKIPE DDCURR ;SETUP YET?
RETT ;YES
$COPY DDCURR,I DDTAB ;PT TO BEGINNING OF TABLE
$COPY ARBCURR,I ARBTAB ;DITTO
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
MOVE T1,ARBCURR ;CURR SPOT IN PRIVATE TABLE
ADDB T2,ARBCURR ;SAVE NEW 1ST FREE
CAIL T2,ARBTAB+SZ%ARB-1 ;HIT LIMIT
ERRU (TFU) ;YES, TAB FULL
RETT
$ENDPROC
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
$PROC (SY.STOR,<ASZVAL>)
;
; SY.STOR - STORE SYMBOL IN PRIVATE TABLE
; ARGUMENTS:
; ASZVAL = THE ASCIZ STRING TO STORE
; RETURNS:
; TF = TRUE IF SYMBOL NOT ALREADY IN TABLE, FALSE OTHERWISE
; T1 = SYMBOL NODE ADDRESS
MOVEI T5,@ASZVAL(AP) ;PT TO STRING
$ENDARG
HRLI T5,440700 ;MAKE BP TO IT
$CALL SYMR50 ;BUILD RADIX50 VALUE INTO R50VAL
$CALL SYMPRV ;SEARCH PRIVATE SYMBOL TABLE
JUMPT L$RETF ;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
$COPY DD.NAM(T1),R50VAL ;PUT SYMBOL IN TABLE
RETT ;RET SUC
$ENDPROC
$PROC (SY.GET)
;
; 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
$P (FLD) ;GET TOKEN
MOVEI T5,TK.VAL(T1) ;PT TO STRING
$CALL SYFIND ;WITH T5
RETURN ;TRANS RET SUCC/FAIL
$ENDPROC
$PROC (SY.FIND,<ASZVAL>)
;
; SY.FIND - FIND A SYMBOL
; ARGUMENTS:
; ASZVAL = THE SYMBOL NAME
; RETURNS AS FOR SY.GET
MOVEI T5,@ASZVAL(AP) ;PT TO STRING
$ENDARG
$CALL SYFIND ;WITH T5
JUMPF L$RET ;TRANS RET FAILURE
$FETCH T3,BID,(T1) ;CHK WHAT FND
CAIE T3,RA$TYP ;RAB?
RETT ;RET SUCC
$COPY CRABNM,R50VAL ;SAVE ITS NAME
MOVEM T1,CURRAB ;SAVE PTR TO IT
RETT
$ENDPROC
SUBTTL SYMBOL TABLE SUBROUTINES
$UTIL (SYFIND)
;
; SYFIND - DOES REAL WORK OF FINDING SYMBOL
; ARGUMENTS:
; T5 = PTR TO ASCIZ STRING
; RETURNS:
; SEE SY.GET
HRLI T5,440700 ;MAKE BP TO IT
$CALL SYMR50 ;BUILD RADIX50 VALUE INTO R50VAL
$CALL SYMPRV ;SEARCH PRIVATE SYMBOL TABLE
MOVEM T1,T2 ;PRESERVE SYMTAB ADDR
JUMPT L$RETV(DD.VAL(T1)) ;SUC IF ALREADY THERE
$CALL SYMDD
JUMPF L$RET ;FAIL IF NOT THERE EITHER
SETZM T2 ;DONT PT INTO DDT TABLE
RETURN (DD.VAL(T1)) ;RET WITH VAL
$ENDUTIL
$UTIL (SYMR50)
;
; SYMR50 - CONVERT ASCII SYMBOL TO RADIX 50
; ARGUMENTS:
; T5 = BP TO ASCIZ STRING
; RETURNS:
; R50VAL = RADIX50 VAL
MOVEI T1,6 ;MAX SIGNIF CHAR
SETZM T2 ;START WITH 0 VAL
SR50LP:
LC TAP,T5 ;GET CHAR FROM SOURCE
JUMPE TAP,SR50EX ;EXIT ON NUL
IMULI T2,50 ;MOVE OVER BY RADIX
ADJBP TAP,[POINT 6,R50TAB] ;GET TO RIGHT ENTRY
LC TAP,TAP ;GET MAPPED VAL
ADD T2,TAP ;MERGE IN CURR LOW-ORDER BYTE
SOJG T1,SR50LP ;KEEP SCANNING IF NOT TO 6TH CHAR
SR50EX:
MOVEM T2,R50VAL ;PERMANIZE SYMBOL
RETURN
$ENDUTIL
$UTIL (SYMPRV)
;
; SYMPRV - SEARCH PRIVATE SYMBOL TABLE FOR R50VAL
; 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
JRST SYMERG
;
$ENTRY (SYMDD)
;
; SYMDD - SEARCH DDT SYMBOL TABLES FOR R50VAL
; RETURNS:
; TF = TRUE IF SYMBOL FOUND
; T1 = PTR TO SYMBOL NODE
SKIPN T5,116 ;PICK UP SYMTAB FROM ABSOL (.JBSYM)
RETF ;NO SYMS, NO FIND
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
RETF ;SYM NOT FND
SYMEX:
HRRZ T1,T5 ;ISOL SYM NODE PTR
RETT ;RET SUC
$ENDUTIL
$ENDSCOPE (TOP-LEVEL)
;XPUNGE
END