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")