Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/carl.mac
There are 2 other files named carl.mac in the archive. Click here to see a list.
SEARCH SIMMAC,SIMMC2
sall
CTITLE CARL
SUBTTL CARL - READ DECLARATIONS FROM DF1
COMMENT; === ROUTINE CARL ===
UPDATE: 4 [36,40,136,140,214,322]
PURPOSE: READ A SEGMENT OF THE DECL. FILE INTO THE DECL. STACK.
THE SEGMENT IS DELIMITED BY ZHE(ZHB) RECORDS, AND IS INPUT BY O2D1.
THE DECLARATION STRUCTURE IS CHECKED AND COMPLETED BY
FILLING PREFIX LINKS, CHECKING QUALIFICATIONS AND VIRTUAL
MATCHES, ETC.
NOTE THE SPECIAL TREATMENT OF LINE NUMBERS FOR DIAGNOSTICS
ENTRY: EXEC CARL
NORMAL EXIT: RETURN
ERROR EXITS: NONE
USES: O2D1
;
TWOSEG
RELOC 400K
EXTERN YELIN1,YELIN2,YCADLV,YOLINE
EXTERN YDICTB,YDCSTP,CAUD,YRDSTP,YBKSTP,CAUS,CADS,O2D1,YUNDEC,YZHET
EXTERN CAPROT,CAUNPR ;[40]
EXTERN CADISP,CAUNDI,O2LN3,EXQC
EXTERN YCALID,YCATYE,YCAZHE,YCA1SC,YCAPLE,YCAVRT,YORZHB
INTERN CABSTU,CARL
CARL.E: RFAIL IMPROPER DF1 STRUCTURE
OPDEF ECADF1 [PUSHJ XPDP,CARL.E]
DEFINE $$$DO <GOTO FALSE>
DEFINE $$$THEN <GOTO FALSE>
DEFINE ON(A) <IFOFF A>
OPDEF DISPLAY [PUSHJ XPDP,CADS]
OPDEF UNDISP [PUSHJ XPDP,CAUD]
QMXBLEN=1777 ;MAX BLOCK LENGTH
MACINIT
;UPDATE BLOCK STACK
CABSTU: L X1,YBKSTP
PUSH X1,XZHE
ST X1,YBKSTP
L YRDSTP
HRLM (X1)
RETURN
DSW SCATYE,YCATYE,36 ;TYPE ERROR SWITCH
DSW SCAN1,YCA1SC,36 ;FIRST SCAN SWITCH
CARL: PROC
SAVE <X2,X3,X4,X5,X6>
STACK YOLINE
HRRZ XZHE,YDCSTP ;CURRENT TOP OF STACK
EXEC O2D1 ;READ ZHE OR ZHB, FOLLOWED BY ZQU LIST, AND FOR
;EACH DECLARED CLASS OR PROCEDURE ZQU,
;ITS ZHB WITH ZQU SUBLIST, ETC.
STACK YDCSTP ;ITS A MIRACLE THIS WORKS
ASSERT <CAMN XZHE,YDCSTP
ECADF1
WHEN XZHE,ZQU
ECADF1>
WHEN XZHE,ZHB
ZF ZHBZHB(XZHE) ; FIELD IS NOT CLEARED FOR INSPECT PASS 1
ST XZHE,YCAZHE ;SAVE XZHE
SETON SCAN1 ;FIRST SCAN
SETZM YCAPLE
SETZM YCAVRT
; CHECK FOR UPDATE OF BLOCK QUANTS (REDUCED INTO PREFIXED BLOCK)
LF X1,ZHETYP(XZHE)
IF CAIE X1,QRBLOCK
THEN
L X1,YBKSTP
LOOP ; FIND ENCLOSING BLOCK WHICH IS UNREDUCED
POP X1,X4
LF ,ZHETYP(X4)
AS CAIE QFOR
CAIN QRBLOCK
GOTO TRUE
ASSERT<CAIN QINSPE
RFAIL REDUCTION TO INSPECT
>
SA
IF CAIE QPBLOCK
THEN ; UPDATE ZQU:S
ASSERT< LF ,ZHEDLV(XZHE)
LF X1,ZHEDLV(X4)
CAME X1,X0
RFAIL INVALID DLV ALLOCATION
; THIS MAY EASILY SHOW UP IF A PREFIXED
; BLOCK OCCURS IN A FOR STATEMENT OR INSPECTION
>
LF X4,ZHBZHB(X4) ; PREFIX TO BLOCK
L X2,XZHE
SKIPE X4
EXEC CARLSD
FI
FI
CARL.1: L X2,XZHE
LF() ZHETYP(X2)
IF ;PROCEDURE ZHE FIRST IN LIST?
CAIE QPROCB
THEN ;DISPLAY PARAMETERS, FILL IN ZHBZE POINTER
L XZHE,YORZHB ; INVALID OR UNKNOWN PREFIX, OR OUTERMOST BLOCK
DISPLAY
SF(X2) ZHBZE(XZHE)
GOTO CARL.L
FI;
IF ;PREFIXED BLOCK?
SKIPE X4,YORZHB
CAIE QPBLOCK
THEN
LF X1,ZHBZQU(X4)
LF ,ZQULID(X1)
ST YCALID
SF(X4) ZHBZHB(X2)
GOTO CARL.P
FI
WHEN X2,ZHB
GOTO CARL.D
GOTO CARL.L
CARL.S: ;--- BEGIN SCAN HERE ---
L YELIN1
ST YELIN2
IFON SCERFL
ERRLI
SETOFF SCERFL
LF(X1) ZDETYP(X2)
CAIE X1,ZQU%V
GOTO [JUMPN X1,CARL.H
GOTO CARL.X]
;--- ZQU RECORD ---
IF IFON ZQUIVA(X2) ;[40] ON IF HIDDEN
THEN
LF ,ZQULNE(X2)
ST YELIN1
IF
ON SCAN1
THEN
SETZ X1,
IF
LF() ZQUKND(X2) ;KIND=SIMPLE OR KIND=ARRAY
CAILE QARRAY
GOTO FALSE
LF() ZQUTYP(X2) ;AND TYPE =/= LABEL
CAIN QLABEL
THEN
L X1,YCAPLE
ELSE
IFEQF X2,ZQUMOD,QVIRTUAL
L X1,YCAVRT
FI
;/UPDATE OFFSET OR VIRTUAL INDEX/
ADDM X1,OFFSET(ZQUIND)(X2)
SF(XZHE)ZQUZHE(X2) ;LINK TO SURROUNDING BLOCK
LF(X1) ZQUZQU(X2) ;QUALIFICATION?
IF
JUMPN X1,TRUE
THEN ;TRANSLATE FROM ID TO ZQU
LF() ZDCZQU(X1,YDICTB)
IF ;No ZQU exists for this id
SKIPE
THEN ;Usually an error, except for param to MACRO-10
edit(322)
LF X1,ZQUZHE(X2) ;[322] Check type of block we are in
IF ;[322] Not within declaration of MACRO-10 procedure
LF ,ZDETYP(X1)
CAIE ZHB%V
GOTO TRUE
IFNEQF X1,ZHETYP,QPROCB
GOTO TRUE
LF ,ZHBMFO(X1)
CAIE QEXMAC
CAIN QEXMQI
THEN ;Error
LF X1,ZQUZQU(X2)
ERROR1 1,X1,Qualifier XXXX is not a class
FI
LI X0,YUNDEC
LF X1,ZQUKND(X2)
CAIN X1,QCLASS
SETZ X0, ; Remove prefix if class
FI
SF() ZQUZQU(X2)
FI;
ELSE ;SECOND SCAN
IF ;Qualification is not class
IFNEQF X2,ZQUTYP,QREF
GOTO FALSE
LF(X4) ZQUZQU(X2)
JUMPE X4,FALSE
LF() ZQUKND(X4)
CAIN QCLASS
GOTO FALSE
CAIN X4,YUNDEC
THEN
LF(X1) ZQULID(X4)
ERROR1 1,X1,<QUALIF NOT CLASS>
LI X1,YUNDEC ;MAKE QUALIF UNDEFINED
SF(X1) ZQUZQU(X2)
FI;
;//CHECK FOR REDECLARATION OR VIRTUAL MATCH//
LF(X3) ZQULID(X2)
ST X3,YCALID
LF(X4) ZDCZDC(X3,YDICTB)
IF
IFOFF ZQUDD(X2) ;[140]
JUMPN X4,TRUE ;Old decl or specification exists
THEN
LF(X6) ZDCZQU(X4)
LF(X5) ZQUZHE(X6)
IF ;SAME BLOCK LEVEL
LF() ZHESOL(X5)
LF(X1) ZHESOL(XZHE)
CAME X1
THEN
;[140]
L X1,YCALID
LI X4,YDICTB(X3)
WHILE
LF X6,ZDCZQU(X4)
CAMN X6,X2
DO ;SCAN PAST REDECLARATIONS
IF IFEQF X2,ZQUMOD,QVIRTUAL
THEN
LF X5,ZQULNE(X6)
ST X5,YELIN1
IF IFNEQF X6,ZQUMOD,QVIRTUAL
THEN
ERRI1 QE,424 ;ILL VIRT SPEC
ELSE
ERROR1 8,YCALID,<DOUBLE DECL.>
FI
ST X5,YELIN2
ERRLI
SETON ZQUDD(X2)
SETON ZQUDD(X6)
SETF YUNDEC,ZDCZQU(X4)
FI
LF X4,ZDCZDC(X4)
OD
IF IFOFF ZQUDD(X2)
THEN
SETF YUNDEC,ZDCZQU(X4)
ELSE
LF X5,ZDCZDC(X4)
LF X6,ZDCZQU(X5)
IF JUMPE X5,FALSE
IFNEQF X6,ZQUMOD,QVIRTUAL
THEN ;Old is virtual
IF ;Current also virtual
IFNEQF X2,ZQUMOD,QVIRTUAL
THEN ;Illegal virtual spec
ERRI1 QE,424
SETON ZQUDD(X2)
SETF YUNDEC,ZDCZQU(X4)
ELSE
EXEC CARLVI
FI FI FI
REPEAT 0,<;[140]
IFON ZQUSYS(X2)
GOTO L2
IFON ZQUGLOB(X2)
GOTO L2
IF ;OLD WAS A VIRTUAL
LF() ZQUMOD(X6)
CAIE QVIRTUAL
THEN
CAIE X2,(X6)
EXEC CARLVI
ELSE
L2(): IF ;SAME BLOCK
CAME X5,XZHE
THEN
LF X6,ZDCZQU(X3,YDICTB)
SETON ZQUDD(X6) ;[136]
LF X5,ZQULNE(X6)
CAML X5,YELIN1
EXCH X5,YELIN1 ; FIRST ID LNE TO YELIN1
; for good diagnostic msg
ERROR1 8,YCALID,<DOUBLE DECL.>
L YELIN1
ST YELIN2
ERRLI
L X4,(X4) ; TAKE OLD DICTIONARY ENTRY
HRRI X4,YUNDEC
ST X4,YDICTB(X3) ; AND REPLACE CURRENT ENTRY WITH IT
FI FI
;[140]>
FI FI
FI ;(SECOND SCAN)
FI ;[40] HIDDEN SPEC
STEP X2,ZQU
GOTO CARL.S
CARL.H: ;--- HEADER RECORD (ZHE OR ZHB), OR END OF SEGMENT ---
SETZM YCAPLE ;ASSUME NO PREF
SETZM YCAVRT ;AND NO VIRTUALS
; UNDISPLAY TO ENCLOSING LEVEL
LF X3,ZHESOL(X2)
WHILE LF ,ZHESOL(XZHE)
CAMGE ,X3
DO
EXEC CAUNDI
EXEC CAPROT ;[40]
EXEC CAUS
OD
ASSERT<SOS X3
CAIE (X3)
JUMPN CARL.E
>
LF(X1) ZHETYP(X2)
IF
ON SCAN1
THEN
;FOR CLASS/PROCEDURE, UPDATE ZQU POINTER
IF
CAIE X1,QCLASB
CAIN X1,QPROCB
GOTO TRUE
THEN ;LINK ZHB TO ZQU
LF(X3) ZHBZQU(X2)
ADD X3,YCAZHE
ASSERT<WHENNOT X3,ZQU
RFAIL ZQU EXPECTED AT ZHBZQU
>
SF(X3) ZHBZQU(X2)
SF(X2) ZQUZB(X3) ;Reverse the link
LF ,ZQULNE(X3)
ST YELIN1
FI;
IFON ZQUEXT(X3)
XEC O2LN3
IF ;Class block
CAIE X1,QCLASB
THEN ;Prefix link
LF(X4) ZQUZQU(X3)
ZF ZQUZQU(X3) ;CLEAR ZQUZQU FIELD AFTER USE
IF ;Prefix exists
JUMPN X4,TRUE
THEN
LF ,ZQULID(X4)
ST YCALID
IF ; Prefix not previously declared
CAMGE X4,X3
THEN
STACK X2
L X1,YCALID
LF X2,ZHBZQU(X2)
LF X2,ZQULID(X2)
ERRI2 QE,<Q2.ERR+^D40>
ASSERT<NOP [ASCIZ/PREFIX %ID TO %ID IS NOT PREVIOUSLY DECLARED/]
>
UNSTK X2
ZF ZHBZHB(X2) ; DELETE PREFIX
GOTO CARL.D
FI
LF X4,ZQUZB(X4)
SF X4,ZHBZHB(X2)
CARL.P: IFOFF SCAN1
GOTO CARL.D
LF(X5) ZHBZQU(X4) ;GET PREFIX ZQU IN X5
IF ;Prefix not a class
LF() ZHETYP(X4)
CAIE QCLASB
GOTO TRUE
LF ,ZQUTYP(X5)
JUMPE FALSE
CAIN QNOTYP
THEN
SEVER1 3,YCALID,PREF NOT A CLASS
ZF ZHBZHB(X2) ;CLEAR PREF LINK
ELSE
LF ,ZHBSZD(X4)
LF X1,ZHBSZD(X2)
CAML X1
SF ,ZHBSZD(X2) ; BACK UP DISPLAY SIZE FROM PREFIX
IF IFOFF ZHBKDP(X4)
THEN ; BACK DOWN ZHBKDP
SETON ZHBKDP(X2)
FI
IF IFOFF ZHBLOC(X4)
THEN ; BACK DOWN ZHBLOC
SETON ZHBLOC(X2)
FI
LF() ZHEDLV(X2)
LF(X1) ZHEDLV(X4)
IF
CAME X1
GOTO TRUE
IFOFF ZQUIS(X5)
THEN
IF SKIPN X1
THEN ; INVALID PREFIX LEVEL
SEVER1 4,YCALID,PREF NOT ON SAME LEVEL
ELSE ; FIRST OCCURRENCE OF SIMSET/SIMULATION
EXEC CASDL ; SET DLV:S
LF ,ZHEDLV(X4)
SKIPN
SEVER1 4,YCALID,PREF NOT ON SAME LEVEL
FI
ELSE ; CHECK PREFIX SOURCE LEVELS
IF IFON ZQUSYS(X5)
THEN ; OFF
LF ,ZHESOL(X2)
LF X1,ZHESOL(X4)
CAME X1
SEVER1 4,YCALID,PREFIX NOT ON SAME LEVEL
FI
FI
EXEC CARLSD
FI
FI
FI
CARL.D: ;DISPLAY LEVEL (INITIAL VALUE)
LF() ZHEDLV(X2) ;STD := SZD := - DLV
MOVN
AOJ ,
SF() ZHBSTD(X2)
LF X1,ZHBSZD(X2)
HRRZ
CAMLE X1
SF() ZHBSZD(X2)
ELSE ;SECOND SCAN
FI
;ADD NEW LEVEL
CARL.L: ST XZHE,YZHET
L XZHE,X2
; NOTE OPTIMIZATION POSSIBILITY
; IT IS NOT NECESSARY TO DISPLAY PROCEDURE
; PARAMETERS WHEN THEIR ZHB IS READ
EXEC CABSTU
IF
LF() ZDETYP(X2)
CAIE ZHE%V
THEN
DISPLAY
STEP X2,ZHE
ELSE
EXEC CAUNPR,<[1]> ;[40]
EXEC CADISP
STEP X2,ZHB
FI
GOTO CARL.S
;***************************************************
CARL.X: L X4,YDCSTP ;SAVE YDCSTP
WHILE
CAMG XZHE,YCAZHE
DO
EXEC CAUNDI
EXEC CAPROT ;[40]
EXEC CAUS
OD
IF
ON SCAN1
THEN
EXEC CAUNDI
EXEC CAPROT ;[40]
LF ,ZHETYP(XZHE)
IF CAIE QPROCB
THEN ; UNDISPLAY PARAMETERS
L XZHE,YORZHB
UNDISPLAY
FI
EXEC CAUS
L XZHE,YCAZHE
ST XZHE,YZHET
ST X4,YDCSTP
SETOFF SCAN1
GOTO CARL.1
FI
ST X4,YDCSTP
L 0(XPDP)
UNSTK YDCSTP
UNSTK YOLINE
LF ,ZHETYP(XZHE)
IF CAIE QFOR
THEN ; RESET ZQUZHE:S TO ENCLOSING NON-FOR RECORD
L X1,YBKSTP
POP X1,X2
WHILE LF,ZHETYP(X2)
CAIE QFOR
DO
POP X1,X2
OD
LI X1,ZHE%S(XZHE)
WHILE RECTYPE(X1) IS ZQU
DO
SF X2,ZQUZHE(X1)
STEP X1,ZQU
OD
FI
EXEC EXQC
RETURN
EPROC
COMMENT;
PURPOSE: SET ZHEDLV, ZHEEBL AND ZHBSBL IN SIMSET/SIMULATION AND THEIR ATTRIBUTE CLASSES
ENTRY: CASDL
INPUT: X0 DLV OF SIMSET/SIMULATION
OUTPUT: ZHEDLV ETC. OF SIMSET,SIMULATION,LINKAGE,LINK,HEAD AND PROCESS ZHB
X0 IS NOT DESTROYED
;
CASDL: PROC
SAVE <X2,X3,X4>
ST YCADLV
MOVN X4,X0
SUBI X4,1
L X2,X0
L X3,[QIDSET,,QIDSIM] ; ZQULID FOR SIMSET AND SIMULATION
WHILE SKIPN X3
DO
LF X1,ZDCZQU(X3,YDICTB)
HRRI X3,YDICTB(X3)
WHILE
IFON ZQUSYS(X1) ; STANDARD CLASS HAS BEEN REDECLARED
DO
HLR X3,(X3)
LF X1,ZDCZQU(X3)
OD
LF X1,ZQUZB(X1)
SF X2,ZHEDLV(X1) ; PARENT DLV
SF X4,ZHBSBL(X1)
AOJ X4,
SOJ X2,
STEP X1,ZHB
WHILE WHENNOT X1,ZQU
DO
LF ,ZQUKND(X1)
IF CAIE QCLASS
THEN ; UPDATE SON ZHEDLV
LF X1,ZQUZB(X1)
SF X2,ZHEDLV(X1)
SF X4,ZHBSBL(X1)
MOVN X2
SF ,ZHEEBL(X1)
LF X1,ZHBZQU(X1)
FI
STEP X1,ZQU
OD
AOJ X2,
SOJ X4,
HLRZ X3,X3
OD
L X2
RETURN
EPROC
COMMENT;
PURPOSE: SET YCAVRT AND YCAPLE FOR UPDATING OF ZQUIND FIELDS
TO ACCOUNT FOR PREFIXES
ENTRY: CARLSD
INPUT: X2 THIS ZHE RECORD
X4 PREFIX ZHB RECORD
OUTPUT: YCAVRT,YCAPLE,ZHELEN(X2) AND ZHBVRT(X2)
;
CARLSD: LF() ZHELEN(X4)
LF X1,ZHELEN(X2)
ST YCAPLE
ADD X1
SF() ZHELEN(X2)
CAILE QMXBLEN
ERROR2 34,BLOCK TOO LARGE
WHENNOT X2,ZHB
RET
;UPDATE ZHBVRT
LF(X1) ZHBVRT(X4)
ST X1,YCAVRT
LF() ZHBVRT(X2)
ADD X1
SF() ZHBVRT(X2)
RETURN
COMMENT; === ROUTINE CARLVI ===
PURPOSE: TO CHECK FOR POSSIBLE VIRTUAL MATCH WHEN SCANNING
A DSTACK SEGMENT. CALLED FROM CARL WHEN A
(RE)DECLARATION IS ENCOUNTERED ON THE SAME LEVEL
AS A PREVIOUS DECLARATION OR SPECIFICATION WHICH HAS
MODE VIRTUAL.
ENTRY: EXEC CARLVI
INPUT: X2 POINTS TO ZQU OF MOST RECENT POSSIBLE MATCH
X6 POINTS TO ZQU OF NEXT OLDER POSSIBLE MATCH
EXIT: RETURN
;
CARLVI: PROC
SAVE <X2>
LF() ZQUKND(X6)
LF(X1) ZQUKND(X2)
IF
CAMN X1 ;KINDS DO NOT MATCH
THEN
ERROR1 5,YCALID,<VIRT. MATCH, WRONG KIND>
ELSE ;CHECK TYPES
SETOFF SCATYE
LF(X3) ZQUTYP(X2) ;CURRENT TYPE
LF(X1) ZQUTYP(X6) ;TYPE OF OLDER MATCH OR SPEC
IF
CAMN X1,X3 ;UNEQUAL TYPES?
THEN
CAIE X1,QNOTYPE ;OK IF NOTYPE TO TYPE
SETON SCATYE
ELSE ;EQUAL TYPES, CHECK FOR REF
IF
CAIE X3,QREF ;[36]
THEN ;ENSURE EQUAL OR SUBORD. QUAL.
LF() ZQUZQU(X6)
LF(X1) ZQUZQU(X2)
LOOP
CAIE X1,YUNDEC ;[214] Accept undeclared
CAMN X1
GOTO L1
AS
LF(X1) ZQUZB(X1)
LF(X1) ZHBZHB(X1)
JUMPE X1,FALSE
LF(X1) ZHBZQU(X1)
JUMPN X1,TRUE
SA
SETON SCATYE ;LOOP EXIT WITHOUT MATCH
L1(): FI
FI
IFON SCATYE
ERROR1 6,YCALID,<VIRT. MATCH, WRONG TYPE OR QUAL.>
SETF(1) ZQUNSB(X2) ;MARK THIS ZQU AS VIRTUAL MATCH
SETF(QVIRTUAL) ZQUMOD(X2)
IF IFOFF ZQUPTD(X2) ;[140]
GOTO FALSE
LF ,ZQUZHE(X6) ;[140]
LF X1,ZQUZHE(X2) ;[140]
CAMN X1 ;[140]
THEN ;[140]
SETOFF ZQUPTD(X2)
L X1,YCALID
ERRI1 QE,425 ;VM PROTECTED
FI
IF IFOFF ZQUPTD(X6) ;[40]
THEN
SETON ZQUPTD(X2) ;[40]
FI
FI
RETURN
EPROC
LIT
RELOC 0
VAR
END;*** CARL