Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

*	*	*	*	*	*	*	*	*
*	*	DECLARATIONS	*	*	*	*	*
*	*	*	*	*	*	*	*	*
*
*		LOCAL
*
	DECLARE('SNOBOL.MAIN','FASBOL')
	DECLARE('OPTION','HASHSIZE=509')
	DECLARE('OPTION','NO.STNO')
	DECLARE('PURGE.VARIABLE',ALL)
	DECLARE('PURGE.LABEL',ALL)
	DECLARE('EXTERNAL.FUNCTION','INITLZ,DECLPH,EXECPH,EACTPH,
.CROSPH')
	DECLARE('GLOBAL.VARIABLE','SRCLIN,OBJLIN,OBJCHR,LSTLIN,LSTCHR')
	DECLARE('STRING','SNUMB(5)')
	DECLARE('INTEGER','I,J,K,DIAGNO,NXTNAM,NXTLAB,MSLI,CRSFLG')
	DECLARE('ENTRY.FUNCTION','PRTOUT(MESG,TTYFLG,CHRMOD)')
	DECLARE('ENTRY.FUNCTION','PUTOUT(MESG,CHRMOD)')
	DECLARE('ENTRY.FUNCTION','NEWNAM()')
	DECLARE('ENTRY.FUNCTION','NEWLAB()')
	DECLARE('ENTRY.FUNCTION','ERRMSG(MESG)')
	DECLARE('ENTRY.FUNCTION','STXERR(MESG)')
	DECLARE('ENTRY.FUNCTION','GETSTA()')
	DECLARE('ENTRY.FUNCTION','GETATR()')
	DECLARE('ENTRY.FUNCTION','GETITM()')
	DECLARE('ENTRY.FUNCTION','PARLIT(QTYP,BRKPAT)')
	DECLARE('ENTRY.FUNCTION','SUBS(SKEL,P1,P2,P3,P4,P5)')
*
*		SYSTEM COMMON
*
*	TABLES AND LISTS
	DECLARE('ENTRY.VARIABLE',
.'SYMBTB,XNAMTB,KEYWTB,CTRLTB,DECLTB,CROSTB,CONSTB,ENTFTB,DSIZTB,
.BOPRTB,UOPRTB')
	DECLARE('ENTRY.VARIABLE',
.'ENTRLS,EXTRLS,FORTLS')
*	ARRAYS
	DECLARE('ENTRY.VARIABLE',
.'PTVRAR,PTFNAR,PRIMAR,GOTOAR,DECLAR,PROGAR,VARBAR,MACHAR,STENAR,BOPRAR,
.UOPRAR,PATRAR,EXPRAR,AROPAR,ARITAR,EACTAR')
*	PARAMETERS (STRINGS,DATATYPES)
	DECLARE('ENTRY.VARIABLE',
.'C,INDENT,SPLASH,ITNAM,ITENT,NOFAIL,SNONAM,SUBNAM,PARBLK,PRGNAM,STARTP,
.TEMLOC,P1,P2,P3,P4,P5')
*	PARAMETERS (INTEGERS)
	DECLARE('ENTRY.VARIABLE',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
	DECLARE('INTEGER',
.'P,OBJFLG,LISTSR,INTGER,ITTYP,ITATR,PRGALV,PRGALL,PRGALF,STNFLG,HSHSIZ,
.STRTIM,DMPFLG,LISTOB,STNO,MAXTMP')
	DECLARE('ENTRY.VARIABLE',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
	DECLARE('INTEGER',
.'XNATRB,VTATRB,VDATRB,LTATRB,FTATRB,FDATRB,TXATRB,VNATRB,VXATRB,VIATRB,
.VGATRB,LIATRB,LGATRB,FIATRB,FGATRB,FXATRB,SKATRB,SDATRB,BTATRB')
	DECLARE('ENTRY.VARIABLE',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
	DECLARE('INTEGER',
.'XNVATR,XNLATR,XNFATR,XNXMSK,VTVATR,VDDATR,VDPATR,VDDMSK,LTDATR,LTTMSK,
.FTFATR,FDPATR,FDIATR,FDDMSK,TXTATR,TXTMSK,VNNATR,VXXATR,VIPATR,VGGATR,
.LIPATR,LGGATR,FIPATR,FGGATR,FXXATR,FXXMSK,SKRATR,SDRATR,BTRATR')
*	SPECIAL CHARACTERS,CHARACTER SEQUENCES, AND CHARACTER CLASSES
	DECLARE('ENTRY.VARIABLE',
.'FFCHR,CRLCHR,LFCHR,CRCHR,SQCHR,DQCHR,TBCHR,LCSCHR,BLNCHR,EQLCHR,
.QTSCHR,ELTCHR,LBCHR')
*	PATTERNS AND MATCHES
	DECLARE('ENTRY.VARIABLE',
.'COMSPT,INTGPT,BLNKPT,OPBLPT,PCOMPT,PCPRMT,IDENPT,DCLCMT,RSIDPT,LABLPT,
.POPRMT,IDENMT,SQLTPT,DQLTPT,LBDCPT,IDDCPT')
*
*	MINIMAL SYMBOL TABLE
*
	DECLARE('UNPURGE.VARIABLE','PRTOUT,MESG,TTYFLG,CHRMOD,PUTOUT,
.NEWNAM,NEWLAB,ERRMSG,STXERR,GETSTA,GETATR,GETITM,PARLIT,QTYP,BRKPAT,
.SUBS,SKEL,P1,P2,P3,P4,P5,SUB1')
	DECLARE('UNPURGE.LABEL','PRTOUT PUTOUT NEWNAM NEWLAB ERRMSG
. STXERR GETSTA GETATR GETITM PARLIT SUBS SUB1 CTL1 CTL2 CTL3 CTL4
. CTL5 CTL6 CTL7 CTL8 CTL9 CTL10')
	DECLARE('PURGE.FUNCTION','DEFINE,DATA,DIFFER,TIME,IDENT,LPAD,
.RPAD,SIZE,DUPL,SUBSTR,TABLE,DATATYPE,REPLACE')

*	*	*	*	*	*	*	*	*
*	*	MAIN PROCESSING SEQUENCE	*	*	*
*	*	*	*	*	*	*	*	*
*
*	LOCAL INITIALIZATION
	DEFINE('SUB1(SKEL)')
	DATA('SYM(INAM,ATRB)')
	DATA('CRS(NEXT,CRSI)')
	DATA('NOD(FRNT,BACK)')
	NXTNAM	= 10000
	NXTLAB	= 10000
	ERRCHR	= DUPL(' ',9) SUBSTR(&ALPHABET,1,9) DUPL(' ',118)
*	INITIALIZE SYSTEM
	&DENSITY	= 90
	NXTLIN	= INITLZ()	:F(ENDMSG)
*	PROCESS DECLARATIONS
	DECLPH()
*	PROCESS EXECUTABLE STATEMENTS
	EXECPH()
*	GENERATE END-ACTION STORAGE
	EACTPH()
*	OPTIONAL CROSS-REFERENCE DICTIONARY
	(?DIFFER(CROSTB) ?CROSPH())
*	END PROCESSING
ENDMSG	PRTOUT(CRLCHR '*TOTAL COMPILATION TIME: ' TIME() - STRTIM
. ' MS., ' DIAGNO ' ERROR DIAGNOSTICS*' CRLCHR,1,1)
	&OUTPUT	=	:(END)

*	*	*	*	*	*	*	*	*
*	*	SUBROUTINES	*	*	*	*	*
*	*	*	*	*	*	*	*	*
*		PRTOUT(MESG,TTYFLG,CHRMOD) OUTPUT MESSAGE ON LISTING DEV
*	IF TTYFLG IS NON-NULL, THE MESSAGE IS ALSO OUTPUT ON THE USER
*	TTY. IF CHRMOD IS NON-NULL, THE MESSAGE IS OUTPUT IN CHAR MODE
*
PRTOUT	LSTLIN	= ?IDENT(CHRMOD) MESG	:F(PRTOU1)
	OUTPUT	= ?DIFFER(TTYFLG) MESG	:(RETURN)
PRTOU1	LSTCHR	= MESG
	OUTPUTC	= ?DIFFER(TTYFLG) MESG	:(RETURN)
*	*	*	*	*	*	*	*	*
*		PUTOUT(MESG,CHRMOD) OUTPUT MESSAGE ON OBJECT DEV
*	ALSO OUTPUTS MESSAGE ON LISTING DEVICE IF LISTOB IS NONZERO
*	IF CHRMOD IS NON-NULL, THE OBJECT DEVICE OUTPUT IS IN CHARACTER
*	MODE AND NO LISTING IS ATTEMPTED
*
PUTOUT	OBJLIN	= ?IDENT(CHRMOD) MESG	:S(PUTOU1)
	OBJCHR	= MESG	:(RETURN)
PUTOU1	MESG	?INE(LISTOB,0)  ';' ! REM $ LSTLIN	:(RETURN)
*	*	*	*	*	*	*	*	*
*		NEWNAM() NEW SYMBOL INTERNAL NAME
*	PRODUCES A 5-CHARACTER INTEGER STRING REPRESENTING THE NEXT
*	AVAILABLE INAM FOR PROGRAM SYMBOLS
*
NEWNAM	SNUMB	= NXTNAM
	NXTNAM	= NXTNAM + 1
	NEWNAM	= SNUMB	:(RETURN)
*	*	*	*	*	*	*	*	*
*		NEWLAB() NEW INTERNAL LABEL
*	PRODUCES A 6-CHARACTER STRING OF THE FORM 'QNNNNN' REPRESENTING
*	THE NEXT AVAILABLE INTERNAL LABEL
*
NEWLAB	SNUMB	= NXTLAB
	NXTLAB	= NXTLAB + 1
	NEWLAB	= 'Q' SNUMB	:(RETURN)
*	*	*	*	*	*	*	*	*
*		ERRMSG(MESG) ERROR MESSAGE
*	OUTPUTS APPRPRIATE MESSAGE AND INCREMENTS DIAGNOSTIC COUNT
*
ERRMSG	DIAGNO	= ?PRTOUT(SPLASH 'ERROR   **' LPAD(RPAD(MESG,SIZE(
. MESG) + (38 - SIZE(MESG)) / 2,' '),38,' ') '**' CRLCHR SPLASH,1)
. DIAGNO + 1	:(RETURN)
*	*	*	*	*	*	*	*	*
*		STXERR(MESG) SYNTAX ERROR
*	CALLS ERRMSG IF MESG IS NON-NULL, THEN OUTPUTS APPROPRIATE
*	SECTION OF STATEMENT WITH POINTER INDICATING POSITION OF ERROR
*	EXPECTS STATEMENT IN C AND POINTER IN P
*
STXERR	(?DIFFER(MESG) ?ERRMSG(MESG))
	I	= P
	STXERR	= C
	STXERR	BREAK(CRCHR)  @J	:S(STXER2)
STXER1	PRTOUT(STXERR CRLCHR REPLACE(SUBSTR(STXERR,I),&ALPHABET,ERRCHR)
. '^',1)	:(RETURN)
STXER2	K	=
STXER3	STXERR	= ?ILE(I,J) SUBSTR(STXERR,J - K,K)	:F(STXER4)
	I	= I - K	:(STXER1)
STXER4	K	= J + 1
	STXERR	LEN(*K)  (BREAK(CRCHR) ! REM)  @J	:(STXER3)

*	*	*	*	*	*	*	*	*
*		GETSTA() GET NEXT STATEMENT
*	RETURNS STRING CORRESPONDING TO NEXT STATEMENT, WHICH IS NOT
*	A COMMENT OR CONTROL LINE, OR FAILS IF SOURCE END-OF-FILE
*	CARRIAGE RETURN CHARACTERS ARE SUBSTITUTED FOR CONTINUATION
*	CHARACTERS IN MULTI-LINE STATEMENTS
*
GETSTA	?IEQ(MSLI,0)	:F(GETST2)
GETST1	MSLI	=
	CURLIN	= ?DIFFER(NXTLIN,1) NXTLIN	:F(FRETURN)
	NXTLIN	= SRCLIN	:S(GETST2)
	NXTLIN	= 1
* CHECK FOR COMMENT, CONTROL, PAGE EJECT
GETST2	CURLIN	COMSPT $ STR1	:F(GETST5)
* PAGE EJECT
	CURLIN	= ?IDENT(STR1,FFCHR) ?PRTOUT(FFCHR,'',1) SUBSTR(CURLIN,
.SIZE(CURLIN) - 1,1)	:S(GETST2)
	(?IEQ(MSLI,0) ?PUTOUT(';' CURLIN) ?INE(LISTSR,0) ?PRTOUT(
.INDENT INDENT CURLIN))
* COMMENT
	DIFFER(STR1,'*')	:F(GETST1)
* CONTROL
	INTGER	=
	CURLIN	LEN(1)  OPBLPT  SPAN('ABCDEFGHIJKLMNOPQRSTUVWXYZ') $
. STR1  OPBLPT  FENCE  (RPOS(0) ! INTGPT  OPBLPT  RPOS(0))
.	:F(GETST4)
	STR1	= CTRLTB[STR1]
	IDENT(STR1)	:F($STR1)
GETST4	ERRMSG('BAD CONTROL LINE')	:(GETST1)
* NEXT STATEMENT
GETST5	STNO	= ?DIFFER(CURLIN) STNO + 1	:F(GETST1)
	(?IEQ(MSLI,0) ?PUTOUT(';' CURLIN) ?INE(LISTSR,0) ?PRTOUT(INDENT
. LPAD(STNO,7,' ') ' ' CURLIN))
GETST6	(GETSTA CURLIN)	BREAKQ(';') $ GETSTA  LEN(1)  REM $ CURLIN
.	:F(GETST7)
* MULTI-STATEMENT LINE
	MSLI	= 1	:(RETURN)
GETST7	GETSTA	= GETSTA CURLIN
* CONTINUATION CHECK
	NXTLIN	ANY('.+')  REM $ STR1	:F(GETST8)
	(?PUTOUT(';' NXTLIN) ?INE(LISTSR,0) ?PRTOUT(INDENT LPAD(STNO,
.7,' ') ' ' NXTLIN))
	CURLIN	= CRCHR STR1
	NXTLIN	= SRCLIN	:S(GETST6)
	NXTLIN	= 1	:(GETST6)
GETST8	MSLI	=	:(RETURN)

*	CONTROL ACTIONS
* LIST
CTL1	LISTSR	= 1	:(GETST1)
* UNLIST
CTL2	LISTSR	=	:(GETST1)
* NOCODE
CTL3	LISTOB	=	:(GETST1)
* CODE
CTL4	LISTOB	= 1	:(GETST1)
* EJECT
CTL5	(?PRTOUT(FFCHR,'',1) ?PUTOUT(FFCHR,1))	:(GETST1)
* SPACE N
CTL6	PRTOUT(DUPL(CRLCHR,INTGER),'',1)	:(GETST1)
* FAIL
CTL7	NOFAIL	=	:(GETST1)
* NOFAIL
CTL8	NOFAIL	= GOTOAR<1>	:(GETST1)
* NOCROSS
CTL9	CRSFLG	=	:(GETST1)
* CROSREF
CTL10	CRSFLG	= 1
	CROSTB	= ?IDENT(CROSTB) TABLE(15,7)	:(GETST1)
*	*	*	*	*	*	*	*	*
*		PARLIT(QTYP,BRKPAT) PARSE LITERAL
*	PARSES LITERAL AND RETURNS STRING WITH CR'S EXTRACTED AND PAIRS
*	OF QUOTES OF QTYP REDUCED TO ONE QUOTE
*	EXPECTS P TO POINT IMMEDIATELY AFTER THE STARTING QUOTE, AND
*	LEAVES P POINTING TO JUST BEFORE THE CLOSING QUOTE OR ANY OTHER
*	CHARACTER (OTHER THAN CR) INCLUDED IN BRKPAT (A BREAK PATTERN)
*
PARLIT	C	LEN(*P)  BRKPAT $ STR1  @P  LEN(1) $ STR2
.	:F(FRETURN)
	PARLIT	= PARLIT STR1
	P	= ?IDENT(STR2,CRCHR) P + 1	:S(PARLIT)
	STR2	= ?IDENT(STR2,QTYP) SUBSTR(C,1,P + 1)	:F(RETURN)
	PARLIT	= ?IDENT(STR2,QTYP) PARLIT QTYP	:F(RETURN)
	P	= P + 2	:(PARLIT)
*	*	*	*	*	*	*	*	*
*		SUBS(SKEL,P1,P2,P3,P4,P5) SUBSTITUTE PARAMETERS
*	FORMS STRING BY SUBSTITUTING PARAMETERS P1 THROUGH P5 IN
*	SKELETON TREE SKEL. DOES NOTHING IF BOTH OBJECT CODE AND LISTING
*	OF IT ARE TURNED OFF
*
SUBS	SUBS	= ?INE(OBJFLG + LISTOB,0) SUB1(SKEL)	:(RETURN)
*	*	*	*	*	*	*	*	*
*		SUB1(SKEL) WALK TREE AND SUBSTITUTE
*	WALKS OVER SKELETON TREE FROM LEFT TO RIGHT AND BOTTOM TO TOP
*	PRODUCING STRING RECURSIVELY
*
SUB1	SUB1	= DATATYPE(SKEL)
	SUB1	= ?IDENT(SUB1,'STRING') SKEL	:S(RETURN)
	SUB1	= ?IDENT(SUB1,'NAME') $SKEL	:S(RETURN)
	SUB1	= SUB1(FRNT(SKEL)) SUB1(BACK(SKEL))	:(RETURN)

*	*	*	*	*	*	*	*	*
*		GETITM() GET ITEM FROM SYMBOL TABLE
*	EXPECTS ITTYP, ITATR, AND ITNAM SET TO THE TYPE, ATTRIBUTES,
*	AND NAME OF THE SYMBOL, AND DOES LOOKUP TO GET ITENT. CREATES
*	NEW SYM DATATYPE FOR NEW ENTRIES, OR RESETS ITATR FOR OLD ONES
*	CALLS GETATR TO SET ALL THE APPROPRIATE INDIVIDUAL ATTRIBUTES
*	AND MAKES A CROSS-REFERENCE ENTRY IF THE FLAG IS ON
*
GETITM	ITPTR	= .SYMBTB[ITNAM]
	ITENT	= $ITPTR
	$ITPTR	= ?IDENT(ITENT) SYM(NEWNAM(),ITATR)	:F(GETIT2)
	ITENT	= $ITPTR
GETIT1	(?GETATR() ?INE(CRSFLG,0))	:F(RETURN)
	ITPTR	= .CROSTB[ITNAM]
	$ITPTR	= CRS($ITPTR,LSHIFT(STNO,3) + ITTYP)	:(RETURN)
GETIT2	ITATR	= ATRB(ITENT)	:(GETIT1)
*	*	*	*	*	*	*	*	*
*		GETATR() GET ATTRIBUTES
*	ENTER WITH ITTYP AND ITATR SET, AND SETS THE INDIVIDUAL 'XXATRB'
*	ATTRIBUTES FOR THE GIVEN TYPE
*
GETATR	?INE(ITTYP,0)	:F(GETAVR)
	?INE(ITTYP,1)	:F(GETALB)
	?INE(ITTYP,2)	:F(GETAFN)
	?INE(ITTYP,3)	:F(GETAST)
	?INE(ITTYP,4)	:F(GETABT)
	?INE(ITTYP,5)	:F(GETAVX)
	?INE(ITTYP,6)	:F(GETALX)
* EXTENDED FUNCTION
	FXATRB	= AND(ITATR,FXXMSK)
	FGATRB	= AND(ITATR,FGGATR)
	FIATRB	= AND(ITATR,FIPATR)
* NORMAL FUNCTION
GETAFN	FTATRB	= AND(ITATR,FTFATR)
	FDATRB	= AND(ITATR,FDDMSK)	:(GETATX)
* EXTENDED LABEL
GETALX	LGATRB	= AND(ITATR,LGGATR)
	LIATRB	= AND(ITATR,LIPATR)
* NORMAL LABEL
GETALB	LTATRB	= AND(ITATR,LTTMSK)	:(GETAXN)
* EXTENDED VARIABLE
GETAVX	VXATRB	= AND(ITATR,VXXATR)
	VGATRB	= AND(ITATR,VGGATR)
	VIATRB	= AND(ITATR,VIPATR)
	VNATRB	= AND(ITATR,VNNATR)
* NORMAL VARIABLE
GETAVR	VTATRB	= AND(ITATR,VTVATR)
	VDATRB	= AND(ITATR,VDDMSK)
GETATX	TXATRB	= AND(ITATR,TXTMSK)
GETAXN	XNATRB	= AND(ITATR,XNXMSK)	:(RETURN)
* STRING
GETAST	SKATRB	= AND(ITATR,SKRATR)
	SDATRB	= AND(ITATR,SDRATR)	:(RETURN)
* BREAK TABLE
GETABT	BTATRB	= AND(ITATR,BTRATR)	:(RETURN)
*	*	*	*	*	*	*	*	*
END