Google
 

Trailing-Edge - PDP-10 Archives - cobol12c - squirl.mac
There are 7 other files named squirl.mac in the archive. Click here to see a list.
; UPD ID= 2999 on 7/1/80 at 9:07 AM by WRIGHT                           
TITLE	SQUIRL FOR COBOL V12C
SUBTTL	SYNTAX TREE TRACER	W.NEELY/CAM/SEB



	SEARCH	COPYRT
	SALL

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;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.

	SEARCH	P
	%%P==:%%P
	MCS==:MCS
	TCS==:TCS
	DBMS==:DBMS
	DEBUG==:DEBUG
	RPW==:RPW
	XPNTST==:XPNTST

;EDITS
;NAME	DATE		COMMENTS

;V12*****************
;JSM	28-MAR-79	[670] FIX NESTED IF . ELSE PROBLEM

;V10*****************
;EHM	11-AUG-77	[506] ADD TEST FOR OVERFLOW OF DATTAB ETC. AND MAKE A CLEAN EXIT.
;	5-JAN-77	[415] ADD TEMTAB TABLE FOR USE
;SSC	MAR-5-75	PLACED 6A EDIT %316 DIRECTLY IN V10
;DBT	4/17/75		STRAIGHTEN OUT TABLES INDEXED BY TABLE
;			INDICES
;********************


TWOSEG
	.COPYRIGHT		;Put COPYRIGHT statement in .REL file.

RELOC	400000
SALL

;THIS ROUTINE READS THE SOURCE PROGRAM AND TRACES IT
;THROUGH THE SYNTAX TREES.
;THE SYNTAX TREES ARE:
;	IDTREE & EDTREE IN COBOLB.MAC,
;	DDTREE IN COBOLC.MAC
;	PDTREE IN COBOLD.MAC
;THE STANDARD FORMAT OF A TREE ENTRY (CALLED A NODE) IS:
;NAME:	XWD	ACTION-ADDRESS,MISC-CODES
;	THE REMAINDER OF THE ENTRY CONSISTS OF HALF WORDS
;	WHICH CONTAIN THE ADDRESSES OF OTHER NODES (CALLED SONS)
;	TO WHICH SQUIRL CAN NOW BRANCH. THE LAST SON IS
;	CALLED THE DEFAULT NODE.
;THE MISC-CODES ARE AS FOLLOWS:
;BITS 18-23	NUMBER OF BRANCHES AT THIS NODE (MINUS 1)
;BIT  24	1 IF THIS IS A PUSH-DOWN NODE
;BIT  25	1 IF THIS ITEM MUST BEGIN AT THE A-MARGIN
;BITS 26-35	THE ITEM-TYPE WHICH GOT SQUIRL TO THIS NODE

;SQUIRL STARTS AT THE FIRST NODE IN THE TREE. IT CALLS GETITM TO
;SCAN THE NEXT SOURCE ITEM AND DETERMINE ITS TYPE (E.G., DATA-NAME,
;RESERVED WORD, LITERAL). SQUIRL THEN COMPARES THIS TYPE-CODE WITH
;THE CODE OF EACH NODE TO WHICH THE CURRENT NODE CAN BRANCH. IF
;IT GETS A MATCH, THE ACTION SPECIFIED BY THAT BRANCH NODE IS
;EXECUTED, THEN THAT SON BECOMES THE CURRENT NODE AND THE PROCESS
;REPEATS.
;IF NO MATCH IS MADE, THE ACTION AT THE LAST (DEFAULT) NODE IS
;EXECUTED, AND THE DEFAULT NODE IS MADE THE CURRENT NODE.
;IF THERE IS ONLY 1 SON (DEFAULT), GETITM IS NOT CALLED.
;IN CERTAIN CASES SQUIRL USES A PART OF THE TREE AS A SUBTREE
;(ARITHMETIC EXPRESSIONS, CONDITIONAL EXPRESSIONS). IN THESE
;CASES THE CALLING NODE IS REFERRED TO AS A PUSH-DOWN NODE. ONCE
;THE SUBTREE IS EXHAUSTED, CONTROL RETURNS TO THE CURRENT NODE.
ENTRY	SQURL.

SQURL.:	MOVE	NODE,(NODPTR)	;GET ADDRESS OF CURRENT NODE
IFN DEBUG,<
	PUSHJ	PP,PTNOD.##	;IF TRACING, LIST NODE+ACTION+ITEM
	PUSHJ	PP,PTACT.##
	PUSHJ	PP,PTTYP.##
>
	HLRZ	TA,(NODE)	;GET ACTION ADDRESS
	JUMPE	TA,SQGET	;JUMP IF NULL
	CAIG	TA,4000		;IS IT AN ERROR OR AN ACTION?
	JRST	SQEUUO		;ERROR
	PUSHJ	PP,(TA)		;OTHERWISE PERFORM ACTION
SQGET:	HRRZ	NODE,(NODPTR)	;RE-GET ADDRESS OF CURRENT NODE
	LDB	NSONS,[POINT 6,(NODE),23]	;GET NUMBER OF DESCENDANTS
	JUMPE	NSONS,SQSHF	;0 IMPLIES DEFAULT ONLY
	CAIN	NSONS,77
	JRST	SQG.ER		;-1 IMPLIES NO SONS --- ERROR
	MOVEM	TYPE,PRVTOK##	;[670] SAVE ASIDE PREV TOKEN FLAG
IFN DBMS,<
	SKIPN	FINVOK##	;ARE WE IN AN INVOKE?
	JRST	SQ1		;NO, PROCEED AS USUAL
	MOVEM	NODPTR,DBNODE##
	PUSHJ	PP,GETITM	;GET NEW WORD
	SKIPN	FINVOK		;RE-GET ITEM IF EOF WAS SEEN
SQ1:
	>
	PUSHJ	PP,GETITM##	;GET NEXT SOURCE ITEM
	MOVE	NODE,(NODPTR)	;GET ADDRESS OF CURRENT NODE
	HRRZ	NSONS,(NODE)	;GET # OF DESCENDANT NODES (RIGHT JUSTIFIED)
	LSH	NSONS,-14
	MOVE	TA,[POINT 18,1(NODE)]	;SET UP BYTE POINTER TO SONS
	MOVEM	TA,PNTR##	;& FALL INTO LOOP

SQ2:	ILDB	SONADR,PNTR	;GET NEXT SON'S ADDRESS
	JUMPE	SONADR,SQG.ER	;NULL ADDRESS --- ERROR
	MOVE	SON,(SONADR)	;FIRST WORD OF SON
	SOJGE	NSONS,SQ2A	;JUMP IF NOT LAST SON
	HRRZ	NSONS,TYPE	;IF DEFAULT SON, EXIT LOOP WITH SON-TYPE IN NSONS
	ANDI	NSONS,001777
SQ2.2:	SWON	FREGWD		;TURN ON REGET WORD FLAG SINCE WE LOOKED
	JRST	SQ3		;BUT DIDN'T USE IT

SQ2A:	XOR	SON,TYPE	;NOT DEFAULT --- COMPARE ITEM-TYPE & SON-TYPE
	TRNE	SON,AMRGN.	;IS MARGIN REQUIREMENT SAME IN ITEM AND SON?
	TRNE	TYPE,AMRGN.	;NO --- SKIP IF A-MARGIN REQUIRED
	TRNE	SON,AMRGN.-1	;SKIP IF SAME TYPES
	JRST	SQ2		;DIFFERENT --- TRY NEXT SON
	JRST	SQ3		;SON MATCHES --- EXIT LOOP

;ARRIVE HERE IF ONLY ONE SON

SQSHF:
	HLRZ	SONADR,1(NODE)	;GET ADDRESS OF SON'S ADDRESS
	MOVE	SON,(SONADR)	;GET SON'S ADDRESS
SQ3:	HRRZM	SONADR,(NODPTR)	;MAKE SON THE CURRENT NODE
	TRNN	SON,004000	;IS THIS A PUSHDOWN NODE?
	JRST	SQURL.		;NO
IFN DEBUG,<PUSHJ PP,PTPSH.##>	;LIST NODE PUSHING DOWN FROM
	HRRZ	SONADR,(NODPTR)	;GET ADDRESS OF CURRENT NODE
	HLRZ	TA,(SONADR)	;ACTION ADDRESS BECOMES CURRENT NODE
	PUSH	NODPTR,TA
	JRST	SQURL.		;GO TO NEW NODE
;BAD NODE CODE

SQG.ER:
IFE DEBUG,<
	OUTSTR	[ASCIZ /?COMPILER ERROR --- IMPROPER SYNTAX TREE AT PC = /]
>
IFN DEBUG,<
	OUTSTR	[ASCIZ /?COMPILER ERROR --- IMPROPER SYNTAX TREE AT NODE = /]
	MOVE	TE,-1(NODE)	;NAME OF NODE
	MOVE	TD,[POINT 6,TE]
	HRRZI	TC,6
	ILDB	CH,TD
	ADDI	CH," "
	OUTCHR	CH
	SOJG	TC,.-3
>
IFE DEBUG,<
	MOVEI	TE,(NODE)	;ADDRESS OF NODE
	MOVE	TD,[POINT 3,TE,17]
	HRRZI	TC,6
	ILDB	CH,TD
	ADDI	CH,"0"
	OUTCHR	CH
	SOJG	TC,.-3
>
	OUTSTR	[ASCIZ /
/]
	JRST	KILL##		;"CATASTROPHE"

;PERFORM ERROR ACTION

SQEUUO:	HRLI	TA,(EWARNW)	;MAKE EWARNW BE#. INTSRUCTION
	XCT	TA		;PERFORM THE ERROR UUO
	JRST	SQGET		;CONTINUE THROUGH TREE
SUBTTL	TABLE AND STRING MANIPULATION ROUTINES

ENTRY	GETVAL,GETV2,FINDAT

;GETVAL CONVERTS AN ASCII STRING OF CHARACTERS TO THE BINARY
;	INTEGER IT REPRESENTS
;THE FIRST CHARACTER MAY BE A SIGN
;AT ENTRY TA==ABS. ADDR. OF CHARACTER STRING
;AND CTR==NUMBER OF CHARACTERS IN STRING
;AT EXIT TC==VALUE
;NO VALIDITY CHECKING OF THE INPUT IS PERFORMED

GETVAL:	MOVE	TD,[POINT 7,(TA)]
GETV2:	SETZ	TC,		;VALUE
	HRRZI	TE,1		;SIGN
	ILDB	TB,TD		;FIRST CHARACTER
	CAIN	TB,53		;+ SIGN?
	JRST	ENDLP		;YES
	CAIE	TB,55		;- SIGN?
	JRST	GO		;NO
	SETO	TE,		;YES
	JRST	ENDLP
GETLP:	ILDB	TB,TD		;DIGIT
GO:	ANDI	TB,17		;VALUE
	IMULI	TC,12		;NUMBER*10.
	ADD	TC,TB		;+ DIGIT
ENDLP:	SOSLE	CTR##
	JRST	GETLP
	IMUL	TC,TE		;SIGN
	POPJ	PP,
;FIND AN ITEM IN DATAB
;ITEM SPECIFIED IN TBLOCK AS FOLLOWS:
;TBLOCK+0:	USED TO STORE CURRENT DATAB LINK
;	1:	# OF QUALIFIERS
;	2:	INDEX TO QUALIFIERS
;	3:	LINK TO MATCHING ITEM
;	4:	W2 CONTENTS FOR DATA-NAME
;	5:	NAMTAB LINK TO 1ST QUAL.
;	6:	NAMTAB LINK TO 2ND QUAL.
;	ETC.
;RETURNS WITH DATAB LINK IN TE
;OR WITH DW, LN, CP SET IF THERE WAS AN ERROR

FINDAT:	LDB	TA,[POINT 15,TBLOCK+4,15]	;GET 1ST DATAB LINK FOR ITEM
	MOVEI	TB,CD.DAT
	PUSHJ	PP,FNDLNK##
	JRST	FINDE1		;NOT DEFINED
	SETZM	CTR		;CLR MATCH CTR
FIND11:	MOVEM	TB,TBLOCK##	;SAVE DATAB LINK OF ITEM
	HLRZ	TC,TB		;TC ALWAYS HAS LINK IN RIGHT HALF
	SETZM	TBLOCK+2	;INIT QUALIFIER INDEX
	SKIPN	TBLOCK+1	;ANY QUALIFIERS?
	JRST	FIND8		;NO, THIS IS A MATCH
FIND5:	AOS	TB,TBLOCK+2	;AIM AT NEXT QUALIFIER
	CAMLE	TB,TBLOCK+1	;FINISHED ALL QUALS?
	JRST	FIND8		;YES, WE HAVE A MATCH
	HRRZ	TD,TBLOCK+4(TB)	;NO, GET NAMTAB LINK OF NEXT QUAL
FIND6:	HRRZI	TA,(TC)		;AIM AT DATAB ENTRY
	ANDI	TA,077777
	ADD	TA,DATLOC##
	LDB	TC,DA.BRO##	;GET FATHER/BROTHER LINK
	JUMPE	TC,FIND14	;DOESN'T HAVE ONE
	LDB	TB,DA.FAL##	;IS IT A FATHER LINK?
	JUMPE	TB,FIND6	;NO, KEEP GOING
	MOVEI	TA,(TC)		;GET FATHERS NAME
	ANDI	TA,077777
	TRNN	TC,700000	;IS THIS A DATAB OR A FILTAB LINK?
	JRST	FIND3		;FILTAB
	ADD	TA,DATLOC##
	LDB	TB,DA.NAM##
	CAIE	TB,(TD)		;DOES NAME MATCH ONE WE WANT?
	JRST	FIND6		;NO
	JRST	FIND5		;YES, TRY NEXT QUAL.

FIND3:	MOVEI	TE,(TA)		;SAVE EXTRA COPY OF TA
	MOVE	TB,TBLOCK+2	;MAKE SURE NO QUALS ABOVE THIS
	CAMGE	TB,TBLOCK+1
	JRST	FIND15		;FILE CAN'T BE A MATCH SINCE THERE ARE MORE QUALS
	HRRZ	TB,FILLOC##	;OK, GET ABS. FILTAB PTR
	ADDI	TA,(TB)
	HRRZ	TB,FILNXT##	;IS PTR IN FILTAB RANGE?
	CAILE	TA,(TB)
	JRST	FIND14		;NO
	LDB	TB,FI.NAM##	;WHAT'S HIS NAME?
	CAIE	TB,(TD)		;IS IT WHAT WE WANT?
	JRST	FIND14		;NO
IFE RPW,<
FIND8:	>
	AOS	CTR		;COUNT MATCHING ITEM
	MOVE	TA,TBLOCK	;& SAVE LINK TO IT
	MOVEM	TA,TBLOCK+3
FIND14:
IFN RPW,<
	HRRZ	TA,RPWLOC##	;MAKE ABS PTR TO RPWTAB
	ADDI	TA,(TE)
	HRRZ	TB,RPWNXT##	;IS PTR IN RPWTAB RANGE?
	CAILE	TA,(TB)
	JRST	FIND15		;NO
	LDB	TB,RW.NAM##	;FIND HIS NAME
	CAIE	TB,(TD)		;DOES IT MATCH?
	JRST	FIND15		;NO
FIND8:	AOS	CTR		;COUNT MATCHING ITEM
	MOVE	TA,TBLOCK	;& SAVE LINK TO IT
	MOVEM	TA,TBLOCK+3
	>
FIND15:
	MOVE	TA,TBLOCK	;GET NEXT DATAB ITEM IN SAME-NAME CHAIN
	PUSHJ	PP,FNDNXT##
	  JRST	FIND10		;NO MORE OF THIS NAME
	JRST	FIND11		;OK, TRY THIS ONE FOR A MATCH

FIND10:	MOVE	TE,CTR
	JUMPE	TE,FINDE1	;IF CTR = 0, ITEM IS NOT DEFINED
	SOJG	TE,FINDE2	;IF CTR > 1, QUALIFICATION IS AMBIGUOUS
	HLRZ	TE,TBLOCK+3	;IF CTR = 1, GET DATAB LINK TO THE MATCH
	SETZ	DW,		;NO ERRORS
	POPJ	PP,

FINDE1:	HRRZI	DW,E.104	;UNDEFINED
FINDEX:	LDB	LN,[POINT 13,TBLOCK+4,28]
	LDB	CP,[POINT 7,TBLOCK+4,35]
	POPJ	PP,

FINDE2:	HRRZI	DW,E.332	;INSUFFICIENT QUALIFICATION
	JRST	FINDEX

	END