perm filename CNTRS.SAI[PUB,TES]1 blob sn#129295 filedate 1974-11-03 generic text, type T, neo UTF8
00100	BEGOF("CNTRS")
00200	COMMENT
00300	
00400	A counter is represented by a COUNTERTYPE declaration record on ISTK
00500	and SSTK.  Its implementation is obvious except for the trickiness
00600	necessary to get responses triggered at the "right" time, and the
00700	peculiarities of the PAGE counter.
00800	
00900	;
01000	PROCEDURES
     

00100	PUBLIC SIMPLE PROCEDURE CNTRS! ;$"#
00200	BEGIN "CNTRS!"
00300	SYMPAGE←SYMNUM("PAGE") ;
00400	CRECOUNTER(0,1,18,1,0,"1",SYMPAGE) ;
00500	IXPAGE←LDB(IXN(SYMPAGE)) ;
00600	PATPAGE←PATT!STRS(IXPAGE) ;
00700	PAGEVAL ← NULL ;
00800	! ← NULL ;
00900	END "CNTRS!" ;
     

00100	PUBLIC RECURSIVE PROCEDURE CLOSECOUNTER(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;$"#
00200	BEGIN "CLOSECOUNTER"
00300	INTEGER STRS, PP ;
00400	CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
00500	IF DISDECLAREIT THEN
00600		BEGIN
00700		IF (PP ← PARENT(ITSIX)) THEN
00800			BEGIN
00900			LLSCAN(<SON(PP)>, <BROTHER>, LLTHIS=ITSIX) ;
01000			LLSKIP(<SON(PP)>, <BROTHER>) ;
01100			END ;
01200		STRS ← PATT!STRS(ITSIX) ;
01300		PATT!VAL(STRS)←PREFIX(STRS)←INFIX(STRS)←SUFFIX(STRS)←CTR!VAL(STRS)←NULL ;
01400		IF STRS=SHED THEN SHED←SHED-5 ;
01500		END ;
01600	END "CLOSECOUNTER" ;
     

00100	PRIVATE INTEGER SIMPLE PROCEDURE CHRSALF(INTEGER INT, ALFABET) ;$"#
00200	BEGIN "CHRSALF"
00300	INTEGER LABS, LSIGN ; STRING STR ; PRELOAD!WITH [2]3,2,[5]1,[2]0 ; OWN INTEGER ARRAY L[0:9] ;
00400	LSIGN ← IF INT < 0 THEN 1 ELSE 0 ; INT ← ABS(INT) ; STR ← CVS(INT) ;
00500	CASE ALFABET DIV 2 OF
00600	BEGIN
00700	COMMENT 1 ... "1" ; LABS ← LENGTH(STR) ;
00800	COMMENT 2 ... i,I ; LABS ← 4*LENGTH(STR) - L[STR-"0"] ; comment, Believe-it-or-Not ;
00900	COMMENT 3 ... a,A ; LABS ← LENGTH(CVALF(ALFABET, INT)) ;
01000	END ;
01100	RETURN(LABS + LSIGN) ;
01200	END "CHRSALF" ;
     

00100	PUBLIC PROCEDURE CRECOUNTER(INTEGER INLINE, PFROM, PTO, PBY, PIN;
00200		STRING PPRINTING; INTEGER USYMB) ;$"#
00300	BEGIN "CRECOUNTER"
00400	INTEGER TEMP, LENPAT, PARENTCHARS, POSNALF, POSN!, PS, ALF, UIX, PINIX, PINPS, PCHARS ;
00500	STRING S!, SPAR, SPAR! ;
00600	USYMB ← DECLARE(USYMB, COUNTERTYPE) ; TEMP ← DECLARE(SYMNUM(SYM[USYMB]&"!"), PCOUNTERTYPE) ;
00700	UIX ← PUSHI(COUNTERWDS, COUNTERTYPE) ; PS ← PUSHS(5, NULL) ; PATT!STRS(UIX) ← PS ;
00800	BIND(USYMB, UIX) ; DPB(UIX, IXN(TEMP)) ;
00900	CTR!INIT(UIX) ← PFROM + TWO(14) ; CTR!STEP(UIX) ← PBY + TWO(6) ;
01000	TES 10/25/73 ;  IN!LINE(UIX) ← IF UIX=IXPAGE THEN 0 ELSE INLINE ;
01100	PINIX ← IF PIN THEN LDB(IXN(PIN)) ELSE 0 ; PARENT(UIX) ← PINIX ;
01200	IF PIN = 0 THEN PARENTCHARS ← PINPS ← 0
01300	ELSE IF LDB(TYPEN(PIN)) = COUNTERTYPE THEN
01400		BEGIN
01500		PARENTCHARS ← PATT!CHRS(PINIX) ;  PINPS ← PATT!STRS(PINIX) ;
01600		BROTHER(UIX) ← SON(PINIX) ; SON(PINIX) ← UIX ;
01700		END
01800	ELSE BEGIN WARN("=","Undeclared Parent Unit "&SYMB) ; PINPS ← 0 ; PARENTCHARS ← 2 END ;
01900	PCHARS ← LENGTH(CVS(PFROM)) MAX LENGTH(CVS(PTO)) ;
02000	IF FULSTR(PPRINTING) AND PPRINTING=0 THEN
02100		BEGIN "TEMPLATE"
02200		PREFIX(PS) ← "!←" & PPRINTING[2 TO ∞] & ";!!!;;" ;
02300		PATT!ALF(UIX) ← 0 ;
02400		IF PIN NEQ 0 AND PINPS=0 THEN TEMP ← PCHARS + PARENTCHARS comment lousy guess ;
02500		ELSE	BEGIN
02600			S! ← ! ; CTR!VAL(PS) ← CVS(PTO - PBY) ; CTR!CHRS(UIX)←PATT!CHRS(UIX)←1000 ;
02700			IF PINPS THEN BEGIN SPAR ← CTR!VAL(PINPS) ; SPAR! ← PATT!VAL(PINPS) ;
02800			CTR!VAL(PINPS) ← "999999"[1 TO CTR!CHRS(PINIX)] ;
02900			PATT!VAL(PINPS) ← ! ← "9999999999999999"[1 TO PARENTCHARS] ; END ;
03000			NEXTCOUNTER(USYMB, -UIX) ; TEMP ← LENGTH(!) ;
03100			! ← S! ; IF PINPS THEN BEGIN CTR!VAL(PINPS) ← SPAR ; PATT!VAL(PINPS) ← SPAR! END ;
03200			END ;
03300		END "TEMPLATE"
03400	ELSE	BEGIN "PATTERN"
03500		STRING PATCOPY ; LABEL FALF ; INTEGER ARRAY PCH[1:LENGTH(PPRINTING)] ;
03600		PRELOAD!WITH "1", "i", "I", "a", "A" ; OWN INTEGER ARRAY ALFS[1:5] ;
03700		PATCOPY ← PPRINTING ; LENPAT ← 0 ; WHILE FULSTR(PATCOPY) DO PCH[LENPAT←LENPAT+1]←LOP(PATCOPY) ;
03800		FOR POSNALF ← LENPAT DOWN 1 DO FOR ALF ← 1 THRU 5 DO IF ALFS[ALF]=PCH[POSNALF] THEN GO TO FALF;
03900		WARN("=",<"No 1, i, I, a, or A in pattern for "&SYM[SYMB]>) ;
04000		POSNALF ← LENPAT + 1 ; PPRINTING ← PPRINTING & "1" ;
04100		FALF: POSN! ← POSNALF - 1 ; WHILE POSN! AND PCH[POSN!] NEQ "!" DO POSN! ← POSN! - 1 ;
04200		PATT!ALF(UIX) ← ALF ; PATT!PARENT(UIX) ← IF POSN! THEN 1 ELSE 0 ;
04300		PREFIX(PS) ← PPRINTING[1 TO POSN!-1] ; INFIX(PS) ← PPRINTING[POSN!+1 TO POSNALF-1] ;
04400		SUFFIX(PS) ← PPRINTING[POSNALF+1 TO ∞] ; PATT!VAL(PS) ← NULL ;
04500		TEMP ← LENGTH(PREFIX(PS)) + PARENTCHARS + LENGTH(INFIX(PS)) + 
04600			(CHRSALF(PFROM,ALF) MAX CHRSALF(PTO,ALF)) + LENGTH(SUFFIX(PS));
04700		END "PATTERN" ;
04800	PATT!CHRS(UIX) ← TEMP ; CTR!CHRS(UIX) ← PCHARS ; PATT!VAL(PS)←CTR!VAL(PS)←NULL ;
04900	END "CRECOUNTER" ;
     

00100	PRIVATE STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL) ;$"#
00200	BEGIN "CVALF" COMMENT handles 1aAiI conversions ;
00300	STRING S, A ; INTEGER I ;
00400	PRELOAD!WITH	NULL, "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix",
00500			NULL, "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc",
00600			NULL, "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ;
00700	OWN STRING ARRAY LOWROMAN[0:2, 0:9] ;
00800	PRELOAD!WITH	NULL, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX",
00900			NULL, "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC",
01000			NULL, "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM" ;
01100	OWN STRING ARRAY UPROMAN[0:2, 0:9] ;
01200	DEFINE BEG = [WHILE VAL DO BEGIN], OOPS = [WARN(<"=">,<"I only know roman numerals up to 1000, sorry">)] ;
01300	IF VAL = 0 THEN RETURN("0") ;
01400	IF VAL<0 THEN BEGIN S ← "-" ; VAL ← ABS(VAL) END ELSE S ← NULL ;
01500	A ← NULL ; I ← -1 ;
01600	CASE ALFABET - 1 OF
01700	BEGIN
01800	COMMENT 1 ... "1" ; A ← CVS(VAL) ;
01900	COMMENT 2 ... "i" ; IF VAL < 1000 THEN BEG A ← LOWROMAN[I←I+1, VAL MOD 10]&A ;
02000			VAL← VAL DIV 10 END ELSE OOPS ;
02100	COMMENT 3 ... "I" ; IF VAL < 1000 THEN BEG A ← UPROMAN[I←I+1, VAL MOD 10]&A ;
02200			VAL← VAL DIV 10 END ELSE OOPS ;
02300	COMMENT 4 ... "a" ; BEG A ← ("a" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02400	COMMENT 5 ... "A" ; BEG A ← ("A" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02500	END ;
02600	RETURN(S & A) ;
02700	END "CVALF" ;
     

00100	PUBLIC SIMPLE PROCEDURE DCOUNT ;$"#
00200	BEGIN
00300	INTEGER USYMB, INLINE ;
00400	PRELOAD!WITH "FROM", "TO", "BY", "IN", "PRINTING" ;
00500	OWN STRING ARRAY PRE[1:5] ; OWN STRING ARRAY PAR[1:5] ;
00600	DPASS ; IF  NOT THISISID THEN BEGIN WARN("=","Unit must have a name") ; THISWD ← "!DUMMY" END ;
00700	USYMB ← SYMNUM(THISWD) ; PASS ; IF ITS(INLINE) THEN BEGIN INLINE←TRUE; PASS END ELSE INLINE←FALSE ;
00800	PAR[1]←PAR[2]←PAR[3]←PAR[5]←NULL;
00900	PAR[4] ← 0 ; PARAMS(5, PRE, PAR, NULLS) ;
01000	IF ON THEN CRECOUNTER( INLINE,
01100		IF NULSTR(PAR[1]) THEN 1 ELSE CVD(PAR[1]), comment, FROM -- ;
01200		IF NULSTR(PAR[2]) THEN 18 ELSE CVD(PAR[2]), comment, TO -- ;
01300		IF NULSTR(PAR[3]) THEN 1 ELSE CVD(PAR[3]), comment, BY -- ;
01400		IF PAR[4] = 0 THEN 0 ELSE SYMNUM(PAR[4]), comment IN -- ;
01500		IF NULSTR(PAR[5]) THEN "1" ELSE PAR[5], comment, PRINTING -- ;
01600		USYMB ) ;
01700	END "DCOUNT" ;
     

00100	PUBLIC RECURSIVE PROCEDURE DNEXT ;$"#
00200	BEGIN
00300	COMMENT Already PASSed "NEXT" ;
00400	IF  NOT THISISID OR (THISTYPE NEQ COUNTERTYPE AND THISTYPE NEQ PCOUNTERTYPE) THEN WARN("=","NEXT what?")
00500	ELSE IF ON THEN IF IX=IXPAGE THEN NEXTPAGE ELSE NEXTCOUNTER(SYMB, IX) ;
00600	PASS ;
00700	END "DNEXT" ;
     

00100	PUBLIC RECURSIVE PROCEDURE NEXTCOUNTER(INTEGER USYMB, UIX) ;$"#
00200	BEGIN "NEXTCOUNTER"
00300	INTEGER PS, PARIX, PARTYPE, SONIX, SONPS, IVAL, SVTY, SVIX, SVSY, SVTHAT ;
00400	INTEGER I;
00500	STRING PARVAL, CVAL, PVAL, SVWD ;
00600	IF UIX>0 AND  NOT IN!LINE(UIX) THEN DBREAK ;
00700	IF UIX>0 AND FULSTR(CTR!VAL(PATT!STRS(UIX))) AND FINDTRAN(USYMB, 3) THEN RESPOND(LLTHIS) ;
00800	IF UIX = IXPAGE AND OLDPGIDA THEN FINPAGE ELSE UIX ← ABS(UIX) ;
00900	PS ← PATT!STRS(UIX) ; CVAL ← CTR!VAL(PS) ;
01000	CTR!VAL(PS) ← CVAL ←
01100		CVS(IVAL←IF NULSTR(CVAL) THEN CTR!INIT(UIX)-TWO(14) ELSE CVD(CVAL)+CTR!STEP(UIX)-TWO(6)) ;
01200	PARVAL ← IF PATT!PARENT(UIX) AND (PARIX ← PARENT(UIX)) THEN
01300		EVALV("(a parent counter)", PARIX, PCOUNTERTYPE) ELSE NULL ;
01400	IF PATT!ALF(UIX) THEN
01500		PVAL ← ! ← PREFIX(PS)&PARVAL&INFIX(PS)&CVALF(PATT!ALF(UIX),IVAL)&SUFFIX(PS)
01600	ELSE	BEGIN
01700		SVTY←THISTYPE ; SVIX←IX ; SVSY←SYMB ; SVWD←THISWD ; SVTHAT←THATISFULL ;
01800		SWICH(PREFIX(PS), -1, 0) ; PASS ; PVAL ← E(NULL, NULL) ;
01900		PASS ; IF ITS(;) THEN PASS ;
02000		IF  NOT ITS(!!!) THEN WARN("=","Unbalanced COUNT Template") ;
02100		SWICHBACK ;
02200		THISTYPE←SVTY ; IX←SVIX ; SYMB←SVSY ; THISWD←SVWD ;
02300		IF SVTHAT THEN RDENTITY ELSE EMPTYTHAT;
02400		END ;
02500	IF LENGTH(CVAL) > CTR!CHRS(UIX) THEN
02600		BEGIN
02700		WARN("Counter underestimated","Underestimated counter "&SYM[USYMB]&" -- reached "&CVAL) ;
02800		CTR!CHRS(UIX) ← LENGTH(CVAL) ;
02900		END ;
03000	IF LENGTH(PVAL) > PATT!CHRS(UIX) THEN
03100		BEGIN
03200		IF PATT!STRS(UIX) THEN WARN("Pattern underestimate",
03300			"Underestimated counter "&SYM[USYMB]&": --  reached "&PVAL) ;
03400		PATT!CHRS(UIX) ← LENGTH(PVAL) ;
03500		END ;
03600	PATT!VAL(PS) ← PVAL ; SONIX ← SON(UIX) ;
03700	WHILE SONIX > 0 DO
03800		BEGIN
03900		SONPS ← PATT!STRS(SONIX) ;
04000		IF SONIX NEQ IXPAGE AND FULSTR(CTR!VAL(SONPS)) AND FINDTRAN(LDB(BIXNUM(SONIX)),3) THEN RESPOND(LLTHIS) ;
04100		CTR!VAL(SONPS) ← PATT!VAL(SONPS) ← NULL ;
04200		IF SONIX = IXPAGE THEN NEXTCOUNTER(SYMPAGE, SONIX ← -SONIX) ;
04300		DO  SONIX ← IF SONIX>0 AND (K←SON(SONIX)) THEN K ELSE IF (K←BROTHER(ABS SONIX)) THEN K
04400			ELSE -PARENT(ABS SONIX)  UNTIL SONIX>0 OR SONIX=-UIX ;
04500		END ;
04600	IF UIX NEQ IXPAGE AND FINDTRAN(USYMB, 4) THEN RESPOND(LLTHIS) ;
04700	IF UIX = IXPAGE THEN PAGEVAL ← PATT!VAL(PATPAGE) ;
04800	! ← PVAL ; C! ← CVAL ; comment RESPOND or NEXTCOUNTER(..PAGE..) might have changed it ;
04900	END "NEXTCOUNTER" ;
     

00100	PUBLIC INTEGER SIMPLE PROCEDURE NEXTSTATEMENT ;$"#
00200	IF ITS(NEXT) THEN
00300		BEGIN
00400		INTEGER USYMB ; COMMENT, counter name symbol number ;
00500		PASS ; USYMB←IF THISTYPE=COUNTERTYPE THEN SYMB ELSE IF THISTYPE=PCOUNTERTYPE THEN -SYMB ELSE TWO(20) ;
00600		DNEXT ; RETURN(USYMB) ;
00700		END
00800	ELSE RETURN(0) ;
     

00100	FINISHED
00200	
00300	ENDOF("CNTRS")