.H Copyright (c) 1996, Gary D. Campbell NAME =MORE2 $$$$ CODE=01900 --------------- DEXPL ----------------- 1900 : This function is followed by an EMIT(b,b,b...) listing Allowable 1900 : (State,NextState) Pairs (in the MS,LS nibbles of each "b" constant). 1900 : It controls Statement Sequencing and any Initialization required 1900 : when a transition is made between statement types. It can also be 1900 : used to detect and flag an improper transition (Sequence Error) 1900 : either by omission (the transition is not listed) 1900 : or by commision (the transition invokes S.E via the A.LIST, below). 1900 : States numbered 0..D may be allocated. 1900 : State E (left nibble only) means "Any State not listed so far" 1900 : State F (right nibble only) means Next State = Current State. 1900 F.N: ENTRY 1900 DS=CS HL = Index into CS Data Structure 1902+ HL=HL+1 Bump Index to EMIT (State Sequence) 1903 C=$HL Upon return WRAPUP will skip EMIT(..) 1905 B=0 BC = Byte Count of State Sequence 1907 SI=(HL+1) 190A DO A=$SI+ 190B$ A=A\16 A = LS nibble (the Next State) 190D* A':$(BP+STATE) A'= MS nibble (an Allowable State) 1910 IF NE, Allowable : Current 1912* A':0E 0E = an "Else State" 1915 * IF NE,EXIT 1917* ELSE A:0F If "Next" = 0F then 1919 IF NE, Keep Current State 191B $(BP+STATE)=A 191E$ AA=A+A'*16 A = [old new] States 1920 SI=@A.LIST Lookup an "Action" 1923* DO A:$SI based on (old,new) 1925 IF EQ, states. 1927 GOTO %%(SI+1) 192A SI=(SI+3) 192D LOOP UNTIL LT If none in A.LIST 192F RETURN then just return. 1930 BC=BC-1 LOOP (BC>0) If a valid State-Transition can't be found 1932 S.E: CALL FAIL.WRAP Issue a Sequence Error. 1935 ="S" 1936 A.LIST: =043,@S.E -->Pattern from Source | Object 1939 =053,@S.E is a Sequence Error. 193C =0E3,@IPS -->Pattern (Init for State = 3) 193F =0E4,@IPS,-1 -->Source (Init for State = 4) 1943 =80*0 1996 : THE FOLLOWING LOCAL DECLARATIONS MUST BE CONSISTENT WITH "MORE" 1996 :----------------------------------------------------------------- 0002 EXIT=2 Set by INIT.B, used by IPS (no WRAPUP if ERROR.F>0) 0004 ADDR=4 Set = $OBJECT by INIT.B 0006 SYM=6 SymTab Pointer from last lookup 0008 S.S=8 Source Segment 000A VECT=10 @Vector (upper SYMTAB segment) 000C TOKN=12 Token (FF80..FFFE while STATE<5 (See NEW.TOKN) 000F STATE=15 (0 Set by INIT.F, 1-4 Set by F.N, and 5 Set by F.1) 0010 A.PTR=16 Alt Pointer (Set by F.P to Current OBJECT Index) 0012 M.PTR=18 Main Pointer (ALTs with < prefix in current definition) 0014 T.PTR=20 Table Pointer (16-byte table of [size] / Element) 0016 A.FCN=22 Called by DO.ALT before each ALT in MainStatement 0018 S.FCN=24 Called by DO.ALT before (|) in MainStatement 001A O.FCN=26 Called by NEXT.SUC before each Override in ALL Elements 001C D.ALT=28 Defines the Action of DO.SHAPE. 1996 :------- See pages 6 & 14 for more definitions ----------------- .P 1993 F.I: ENTRY Need to find earlier = current 1993 PUSH DI First, get SI,DI positioned as follows: 1994 CALL GET.EMIT ...'[Next Emit] 1997+ SI=SI-1 | ^SI ^GET.EMIT 1998 DI=%(BP+A.PTR) ^DI (DS = Object Segment) 199B+ DI=DI-1 199C A=$SI Note: Current ALT can't have "specs" 199E+ DO DI=DI+1 or "object" (it might have > prefix). 199F* A:$DI A = $SI = 19A1 LOOP UNTIL EQ This loop succeeds when 19A3* DI:SI earlier copy is found, or 19A5 IF LT, when ' is reached. 19A7* A:0 Found = ' 19A9 * IF NEG,EXIT (it's OK, it's a subpattern) 19AB ELSE CALL FAIL.WRAP It was not a proper element. 19AE ="'" SO, Error in a ' 19AF PUSH DI DI = @ 19B0+ DO DI=DI+1 We're going to move it up 1 byte. 19B1 C=$DI Open up a "hole" (for an Override) 19B3 $DI=A by moving and all 19B5 SWAP AA,BC bytes up to 2nd 19B6* DI:SI forward one byte position. 19B8 LOOP UNTIL EQ (final byte = 2nd ) 19BA POP DI EMIT(6D) follows F.I to rematch 1st 19BB $DI=0 Now, fill in the "hole" with a 0-byte. 19BE POP DI (F.1 inserts the proper override later) 19BF RETURN 19C0 F.J: ENTRY Called after EMIT(80) --> new definition 19C0 CALL GET.EMIT or, EMIT() --> continue definition 19C3 AA=%(BP+M.PTR) If $M.PTR = 0, must be 080. 19C6+ SI=SI-1 allocate 4 bytes & reel out a list 19C7* $SI:0 of ALTs that have a < prefix. 19CA IF EQ, 19CC* AA:0 Link the most recent to $M.PTR. 19CE * IF NE,EXIT Copy prev M.PTR into newest packet. 19D0 M.ERR: CALL FAIL.WRAP Packet = [ptr to ALT][prev M.PTR] 19D3 ="M" 19D4* ELSE AA:0 19D6 IF NE,GOTO M.ERR 19D8 PUSH AA AA = Prev M.PTR 19D9 AA=4 19DC CALL ALLOCATE Get AA = @(4-byte packet) 19DF SWAP AA,BP 19E0 %BP=SI Put address of ALT in $packet (2) 19E3 POP SI Put prev M.PTR in $packet+2 (2) 19E4 %(BP+2)=SI 19E7 SWAP AA,BP get original BP, and AA = @packet 19E8 %(BP+M.PTR)=AA put @packet into M.PTR 19EB RETURN .PAD=10 19F0 F.K: ENTRY Called to emit Binary Konstant 19F0 CALL GET.BINARY EMITs current Token as [byte] 19F3 F.K1: SWAP A,A' 19F5 GOTO EMIT.A 19F8 F.L: ENTRY Called to emit Length + Binary 19F8 CALL GET.BINARY EMITs current Token as [len][byte] 19FB PUSH AA 19FC CALL EMIT.A 19FF POP AA 1A00 GOTO F.K1 1A02 GET.BINARY PUSH HL 1A03 CALL GET.TOKEN 1A06* BC:8 1A09 IF GT, 1A0B CALL FAIL.WRAP 1A0E =">" 1A0F HL=BC 1A11 DO A=$SI+ 1A12* A=A AND 1 1A14* ASL H 1A16* H=H OR A 1A18 BC=BC-1 LOOP (BC>0) 1A1A SWAP AA,HL 1A1B POP HL 1A1C RETURN 0000 TEMP (16) 1A1D BUFFER ENTRY 1A1D CALL GET.TOKEN 1A20* BC:10 MaxSymbolLength=10 1A23 IF GT, 1A25 BC=10 1A28 PUSH BC BC = Length; SI,DS = Raw Source 1A29 ES=CS 1A2B DI=@TEMP 1A2E PUSH DI 1A2F DO CALL FILE.CHR 1A32 $DI+=A 1A33 BC=BC-1 LOOP (BC>0) 1A35 DS=CS 1A37 POP SI SI,DS = @Buffer (Shifted Source) 1A38 POP BC BC = Length 1A39 RETURN 1A3A ALLOCATE CS: SWAP AA,%E.O.MEM Also see INIT.P 1A3F* CS: %E.O.MEM=%E.O.MEM+AA E.O.MEM is maintained 1A44* AA=AA-256 256 bytes above actual 1A47 RETURN address allocated. 1A63 : 0051 ERROR.F=81 1A48 IPS: %(BP+M.PTR)=@0 1A4D %(BP+T.PTR)=@0 1A52* $(BP+ERROR.F):0 1A56 IF NE, 1A58 SP=%(BP+EXIT) 1A5B RETURN .PAD=10 1A60 LOOKUP.T ENTRY 1A60 PUSH DS 1A61 PUSH SI 1A62 PUSH ES 1A63 PUSH DI 1A64 PUSH BC 1A65 CALL BUFFER 1A68 CALL LOOKUP 1A6B POP AA 1A6C IF CY, 1A6E CALL ENTER.DI 1A71 * EXIT 1A73* ELSE ES: A'::$DI 1A76 IF ZR,GOTO ERROR.A 1A7A ES: AA=%(DI+1) 1A7E POP DI 1A7F POP ES 1A80 POP SI 1A81 POP DS 1A82 RETURN 1A83 DEFINE.V ENTRY Here, we must lookup/enter a symbol 1A83 PUSH DS and we must not find a value equivalent. 1A84 PUSH SI (finding none, we enter one). 1A85 PUSH AA 1A86 CALL LOOKUP.T Lookup Current Symbol = ObjectToken 1A89 CS: DS=%SYMTAB+2 Fetch Pointer to the Lookup Entry 1A8E SI=%(BP+SYM) [key skip] [Token] [Symbol] 1A91 DO C=$SI [Token, Value] always comes after 1A93* BC=BC AND 0F [Token, Symbol]. 1A97 * IF ZR,EXIT (exit, if no more entries) 1A99* SI=SI+BC If we compare AA beyond the end of 1A9B* AA:%(SI+1) the SymTab and exit, it's OK 1A9E LOOP UNTIL EQ Otherwise, exit when Token = AA. 1AA0* $SI:0 1AA3 IF NZ, If we aren't at the end of SymTab 1AA5 CALL FAIL.WRAP it must be a duplicate definition. 1AA8 ="D" 1AA9 SHOVE: POP BC At end-of-SymTab, enter a [Token,Value]. 1AAA $SI=0E5 Key = 0E5 (length always = 5) 1AAD %(SI+1)=AA 1AB0 %(SI+3)=BC 1AB3 $(SI+5)=0 1AB7 POP SI 1AB8 POP DS 1AB9 RETURN 1ABA ENTER.AABC PUSH DS AA = Token 1ABB PUSH SI BC = @Def 1ABC PUSH BC 1ABD CS: SI,DS=%SYMTAB (no other regs affected) 1AC2* BC=0 Find End-of-Symtab 1AC4* DO SI=SI+BC and Make a Type = E5 Entry 1AC6 C=$SI equal to (Token, Value) 1AC8* C=C AND 0F 1ACB LOOP UNTIL ZR 1ACD GOTO SHOVE .PAD=10 1AD0 LOOKUP DI,ES=%SYMTAB SI,DS = @Buffer (Symbol) (DS=CS) 1AD4 SWAP AA,BC BC was Length of Symbol (max=10) 1AD5* BC=0 1AD7* DO DI=DI+BC 1AD9 ES: C=$DI Here, A=Len 1ADC* C=C AND 0F 1ADF * IF ZR,EXIT 1AE1 PUSH DI 1AE2 PUSH BC 1AE3 DI=(DI+3) 1AE6* C=C-3 1AE9* A:C Are lengths equal? 1AEB IF EQ, (if not, symbols can't be equal) 1AED PUSH SI 1AEE DO UNTIL BC=0 * $SI+:$DI+ BC=BC-1 LOOP EQ (BC>0) 1AF0 POP SI 1AF1 POP BC 1AF2 POP DI 1AF3 LOOP WHILE NE 1AF5 SWAP AA,BC BC=Length of Symbol 1AF6 %(BP+SYM)=DI A=Length of Entry 1AF9* A:1 NC-->Symbol Found ($DI=[k l] Value) 1AFB RETURN CY-->End-of-Table ($DI=[0]) 1AFC ENTER.DI PUSH AA 1AFD PUSH DI A = ErrorCode, A'=Key(skip) 1AFE CALL NEW.TOKN 1B01+ DI=DI+1 SI,DS = @Buffer (Symbol to be entered) 1B02 %DI+=AA 1B03 DO UNTIL BC=0 $DI+=$SI+ BC=BC-1 LOOP (BC>0) 1B05 ES: $DI=B End-of-Table = 0-byte 1B08 POP AA Index of Skip Byte 1B09 POP BC 1B0A SWAP AA,DI now, AA = Index of 0-Byte 1B0B* AA=AA-DI now, DI = Begin Entry & A = Length of Entry 1B0D* A=A OR B combine key & skip 1B0F ES: $DI=A and fix the [key skip] byte. 1B12 RETURN 1B13 NEW.TOKN AA=%(BP+TOKN) 1B16+ $(BP+TOKN)=$(BP+TOKN)+1 1B19 IF NV, OV-->7F,80 transition 1B1B * IF NEG,EXIT Tokens = 80..FE STATE=3,4,5 1B1D* $(BP+STATE):5 FF,00..7E STATE=5 only 1B21 * IF EQ,EXIT 1B23 ELSE CALL FAIL.WRAP 1B26 =">" 1B27 RETURN .PAD=10 1B30 F.1: ENTRY 1B30* $(BP+STATE):4 1B34 IF EQ, 1B36 CALL FIX.MACRO (uses FAIL.WRAP) 1B39 CALL STUFF 1B3C CALL FIX.SHAPE 1B3F CALL CRUSH 1B42 BP=%(BP+T.PTR) 1B45 $(BP+STATE)=5 1B49 RETURN 1B4A FIX.MACRO HL=%(BP+M.PTR) 1B4D* HL:0 1B4F IF EQ, 1B51 BC=%(BP+ADDR) Record the Address of 1B54*ENTER.BC AA=0 every Statement Definition 1B56 GOTO ENTER.AABC (distinguished by TOKN=0). 1B59 CALL GET.EMIT SI = New Statement Address 1B5C* CS: %(HL+2):@0 Verify there are at least 1B62 IF ZR, TWO < prefix statements. 1B64 BAD.MACRO: CALL FAIL.WRAP 1B67 ="M" 1B68* DE=0 1B6A DO CS: DI=%HL 1B6D CS: HL=%(HL+2) 1B71+ DE=DE+1 Count = 1 if $M.PTR-->[PFX2] 1B72* $DI=$DI OR `0 [PTR]-->[PFX1] 1B75 PUSH DI [0] 1B76* CS: %(HL+2):@0 1B7C LOOP UNTIL EQ DE = Count of DI's pushed onto stack. 1B7E CS: DI=%HL 1B81* $DI:0 1st Prefix MUST begin Statement Def. 1B84 IF POS,GOTO BAD.MACRO 1B86 BC=DI BC = Final DI (not pushed) 1B88* DE:31 1B8B IF GE, 1B8D CALL FAIL.WRAP 1B90 =">" 1B91 A=E 1B93* A=A+A 1B95* A=A+082 NEW STATEMENT = 1B97 CALL EMIT.A [^skip] 1B9A DO CALL NEW.TOKN then, [sub] ["o"] 1B9D CALL ENTER.AABC for each loop 1BA0 CALL EMIT.A 1BA3 A="o" 1BA5 CALL EMIT.A 1BA8 POP BC 1BA9+ DE=DE-1 1BAA LOOP UNTIL ZR then, [sub] 1BAC CALL NEW.TOKN for final element. 1BAF CALL ENTER.AABC 1BB2 CALL EMIT.A 1BB5 BC=SI BC = Address of New Statement Def. 1BB7 %(BP+ADDR)=BC 1BBA GOTO ENTER.BC .PAD=10 1BC0 INIT.TBL AA=32 CREATE AUX TABLE 1BC3 CALL ALLOCATE 1BC6 CS: DS=%OBJECT+2 1BCB ES=CS 1BCD %(BP+T.PTR)=AA 1BD0 SI=%(BP+ADDR) 1BD3 SWAP AA,BP A.PTR = Current Alt Pointer 1BD4 %(BP+T.PTR)=AA T.PTR = Parms (Old BP) 1BD7 %(BP+M.PTR)=SI M.PTR = Main ALT of Statement DEF 1BDA ZERO.TBL DI=BP 1BDC* AA=0 1BDE PUT.16 CALL PUT.8 1BE1 PUT.8 CALL PUT.4 1BE4 PUT.4 CALL PUT.2 1BE7 PUT.2 %DI+=AA 1BE8 RETURN 1BE9*SUB.TRAV CS: SP:%E.O.MEM 1BEE IF LT, 1BF0 CALL BOMB 1BF3 ="^" 1BF4 CALL DI2HL.P1 RETURN: HL = Table Index, A = Field Size 1BF7 PUSH HL Failure --> BOMB 1BF8 PUSH SI 1BF9 SWAP AA,DI 1BFA DO SWAP AA,DI Here, DI = Same as upon Initial 1BFB PUSH DI Entry to SUB.TRAV 1BFC CALL DO.ALT Leave SUB.TRAV with DI that comes 1BFF POP AA back from final DO.ALT 1C00* $SI:0 1C03 LOOP UNTIL NEG 1C05 POP SI After Return from SUB.TRAV, 1C06 POP HL the value in A will be deposited in 1C07 CALL FIELD.SIZE Table at $HL. 1C0A RETURN (A = FieldSize) 1C0B STUFF CALL INIT.TBL 1-Time pre- Build Table INIT 1C0E AA=ERASE.TBL 1C11 SI=STUFF.ALTS 1C14 DI=SET.OVRRD 1C17 TRAVERSE %(BP+A.FCN)=AA What to do @ Begin ALT 1C1A %(BP+S.FCN)=SI What to do @ each | 1C1D %(BP+O.FCN)=DI What to do @ each Override Byte 1C20 SI=%(BP+M.PTR) 1C23* DI=0 S.FCN only invoked for elements of a 1C25 CALL SUB.TRAV Statement Def (never a subpattern). 1C28 CS: $HL=A 1C2B RTN: RETURN Used when no action is necessary. 1C2C SET.D.ALT: $(BP+D.ALT)=`0 Init for new Alt in FIX.SHAPE 1C30 RETURN 1C31 FIX.SHAPE CALL ERASE.TBL 1C34 AA=SET.D.ALT 1C37 SI=RTN 1C3A DI=DO.SHAPE 1C3D GOTO TRAVERSE 1C3F CRUSH AA=RTN 1C42 SI=RTN 1C45 DI=CRUSH.ALTS 1C48 GOTO TRAVERSE .PAD=10 1C50 ERASE.TBL PUSH DI 1C51 CALL ZERO.TBL 1C54 POP DI 1C55 RETURN 1C56*DEF.SIZE CS: $HL:0 HL = Pointer into Table 1C5A IF NE, Define a New Entry's Size 1C5C* CS: $HL:A (or verify Old = New) 1C5F CS: $HL=A 1C62 RETURN 1C63+DI2HL.P1 DI=DI+1 1C64* DI:15 Max DI = 15 1C67 IF GE, 1C69 DI=15 1C6C HL=(BP+DI-1) Max HL = BP+14 1C6F RETURN 1C70 =15*0 1C7F DO.ALT C=$SI 1C81* C=C AND 3F 1C84 IF ZR, 1C86 CALL BOMB 1C89 ="?" 1C8A* SI:%(BP+M.PTR) 1C8D IF GE, 1C8F %(BP+A.PTR)=SI AA = Unknown 1C92 CALL %%(BP+A.FCN) CALL Begin ALT Function 1C95+ SI=SI+1 1C96+ DO C=C-1 1C98 IF ZR,RTN 1C9B CALL NEXT.SUC Calls O.FCN if appropriate. 1C9E IF CY, 1CA0* A::11110000 A>15 --> LOOP, else 1CA2 * IF NZ,LOOP HL = Table Pointer 1CA4 * EXIT A = SizeDefinition 1CA6 ELSE PUSH AF 1CA8* SI:%(BP+M.PTR) 1CAB IF GT, CALL | 1CAD CALL %%(BP+S.FCN) Function 1CB0* POP AF S.FCN is ONLY CALLED 1CB2 * IF POS,NEXT for Statement Defs. 1CB4 CALL MAP.IT 1CB7* A':-1 1CBA IF EQ, 1CBC CALL BOMB 1CBF ="U" 1CC0 PUSH BC 1CC1 PUSH SI 1CC2 SWAP AA,SI 1CC3 CALL SUB.TRAV = A bits wide 1CC6 POP SI 1CC7 POP BC 1CC8 * EXIT 1CCA ELSE CALL DI2HL.P1 1CCD A=15 = "15 bits wide" 1CCF CALL DEF.SIZE 1CD2 LOOP WHILE EQ 1CD4 I.ERR: CALL BOMB Inconsistant Elements 1CD7 ="I" .P 1CD8 F.Q: ENTRY 1CD8 PUSH BP 1CD9 PUSH DI 1CDA BP=%(BP+T.PTR) 1CDD CALL GET.EMIT 1CE0 A=$(SI-1) The last byte of OBJECT 1CE3* AA=AA AND 0F HAD to be a 1CE6 SWAP AA,SI Use it to Index the "size" Table 1CE7 A=$(BP+SI) and get its field size. 1CE9* A:15 Size=15 --> Primitive 1CEB IF NE,GOTO I.ERR Otherwise, error = "I"NCONSISTENT 1CED POP DI 1CEE POP BP 1CEF RETURN 1CF0 NEXT.SUC A=$SI+ RETURN: CY if SUC not interesting 1CF1 A'=0 POS if Primitive 1CF3* C:1 NEG if Subpattern 1CF6 IF GT, Note: A'=0 on RETURN. 1CF8* A:" " 1CFA * IF GE,EXIT AA = Override (A'=0) 1CFC CALL %%(BP+O.FCN) CALL Override Function 1CFF.CY.NEG: CY=1 1D00* A=A-CY-A CY,NZ = Uninteresting Element 1D02 RETURN 1D03*EVAL.SUC A:"a" 1D05 IF LT,GOTO CY.NEG a-l --> POS,NC (A unchanged) 1D07*EVAL.N A:"n" sub --> NEG,NC (A unchanged) 1D09 IF NE, n --> CY (see below) 1D0B* A:"m" else, CY,NEG (A=-1) 1D0D IF ^GE,GOTO CY.NEG 1D0F* A:0 1D11 RETURN 1D12 A=$SI+ We know SUC not interesting, 1D13+ BC=BC-1 But, if = "n" we have to bump SI 1D14* A::00110000 and decrement C 1D16 IF NZ, Once for byte following "n" 1D18* A::00100000 and 0-3 times after that. 1D1A IF NZ, n,[xxnnxxxx], 1D1C* A::00010000 1D1E IF NZ, 1D20+ SI=SI+1 1D21+ BC=BC-1 1D22+ SI=SI+1 1D23+ BC=BC-1 1D24+ SI=SI+1 1D25+ BC=BC-1 1D26 HL=AA Get upper 4 bits of A = 0 1D28* HL=HL AND 0F if "n" Function defines a $ref. 1D2C* HL=HL+BP HL = Index to Table (ref) 1D2E* A=A AND 0F0 1D30* A:010 1D32 IF EQ, 1D34 A=15 Here, we have $ref=mods 1D36 * EXIT so, field size = 15. 1D38* ELSE A:0E0 1D3A A=-1 1D3C * IF NE,EXIT Below, we have $ref= 1D3E A=$(SI-2) so, field size = , at $(SI-2). 1D41. CY=1 Otherwise, A=-1 to flag no $ref= anything. 1D42 RETURN .PAD=10 1D50 SET.OVRRD A'=0 Element = Override, so 1D52* A:0 either Set DI = Override, 1D54 IF EQ, 1D56 STUFF.A SWAP AA,DI OR, fix an Override = 0. 1D57 $(SI-1)=A (and leave DI alone) 1D5A SWAP AA,DI 1D5B RETURN 1D5C STUFF.ALTS CALL STUFF.1 1D5F* DO $(BP+DI):0 1D62 * IF EQ,EXIT 1D64+ DI=DI+1 1D65* DI:14 1D68 LOOP UNTIL GE 1D6A CALL STUFF.A 1D6D+ SI=SI+1 1D6E S.RTN: RETURN 1D6F STUFF.1 PUSH SI 1D70+ SI=SI-1 1D71 DO SWAP A,A' 1D73 A=$SI+ 1D74 $(SI-1)=A' 1D77* CS: SI:%OBJECT 1D7C LOOP UNTIL GT 1D7E $SI=A 1D80 CS: %OBJECT=SI 1D85 SI=%(BP+A.PTR) 1D88+ $SI=$SI+1 1D8A* $SI::00111111 1D8D POP SI 1D8E IF NZ,GOTO S.RTN 1D90 CALL BOMB 1D93 =">" 1D94 CRUSH.ALTS SWAP AA,DI Compare Current Element # to 1D95* AA:DI the Override 1D97 IF EQ, EQUAL? Then Crush it Ruthlessly. 1D99+ SI=SI-1 (if NE, leave DI reset to Override) 1D9A PUSH SI 1D9B+ SI=SI+1 1D9C DO A=$SI+ 1D9D $(SI-2)=A 1DA0* CS: SI:%OBJECT 1DA5 LOOP UNTIL GT 1DA7+ SI=SI-2 1DA9 CS: %OBJECT=SI 1DAE SI=%(BP+A.PTR) 1DB1+ $SI=$SI-1 1DB3* $SI::00111111 1DB6 IF ZR, 1DB8 CALL BOMB 1DBB ="?" 1DBC POP SI 1DBD* $SI:" " 1DC0 IF LT, 1DC2+ SI=SI+1 1DC3+ C=C-1 1DC5 RETURN .PAD=10 1DD0*FIELD.SIZE BC=0 B=Max, C=Current 1DD2* AA=0 SI = Begin Alts (count them) 1DD4 DO A=$SI 1DD6* A=A AND 3F 1DD8* SI=SI+AA 1DDA* A:2 (empty Alt?) 1DDC IF GE, 1DDE A=$(SI-1) no, Alt Override? 1DE1* A:020 1DE3 * IF GE,EXIT no. 1DE5 C=A yes (reset C) 1DE7* B:C 1DE9 IF LT, 1DEB B=C Save Max Alt # 1DED* $SI:0 1DF0 * IF NEG,EXIT (no more Alts) 1DF2* $SI::01000000 1DF5 * IF NZ,LOOP =Alt (don't count it) 1DF7+ C=C+1 else, do Bump the count 1DF9 LOOP RETURN: A=FieldSize 1DFB* AA=0 1 Alt B=0 1-2 Alts A=1 1DFD+ DO AA=AA+1 2 Alts B=1 3-4 Alts A=2 1DFE* LSR B 3-4 Alts B=2-3 5-8 Alts A=3 1E00 LOOP UNTIL ZR 5-8 Alts B=4-7 9-16 Alts A=4 1E02 RETURN 17-32 Alts A=5 1E03 BOMB BP=%(BP+T.PTR) 1E06 GOTO FAIL.WRAP 1E09 MAP.IT ENTRY CALL WITH: A = Token for symbol 1E09 A'=-1 RETURN WITH: 1E0B PUSH DS AA = Address (If Fail, A'=-1) 1E0C PUSH SI (other regs unchanged) 1E0D PUSH BC 1E0E CS: SI,DS=%SYMTAB 1E13* BC=0 1E15* DO SI=SI+BC 1E17* $SI:0E0 1E1A IF GT, 1E1C* %(SI+1):AA 1E1F * IF NE,NEXT 1E21 AA=%(SI+3) 1E24 * EXIT 1E26 C=$SI 1E28* C=C AND 0F 1E2B LOOP UNTIL ZR 1E2D POP BC 1E2E POP SI 1E2F POP DS 1E30 RETURN 1E31 ALL.DEFS A=$PARMS+TOKN 1E34+ DO A=A-1 1E36 IF OV,RTN 1E39 PUSH AA 1E3A CALL MAP.IT 1E3D+ A'=A'+1 1E3F POP AA 1E40 LOOP UNTIL ZR 1E42 CALL BUMP.E.CNT 1E45 SI=@NO.DEF.1 1E48 GOTO DSPLY .P 1E4B DO.SHAPE AA=%(BP+M.PTR) >>>>>> Fix Override in 2nd or later ALT 1E4E* AA:%(BP+A.PTR) 1E51 IF NE, D.ALT = ^0 (Begin ALT) 1E53* $(BP+D.ALT):0 0 (Keep Overrides) 1E57 * IF EQ,EXIT X Match ,#prim 1E59 PUSH SI `X ,#prim = 1st of kind 1E5A PUSH BC 1E5B DE=%SI E = Byte after Override, 1E5D* E:020 D = Byte after that 1E60 IF GT, E = 2nd Override? 1E62 SWAP D,E 1E64* D:0 Now, D = Actual Element 1E66 IF POS, Keep , but 1E68 D=7F change #prim to 7F 1E6A E=$(BP+D.ALT) E = Copy of D.ALT 1E6D SWAP AA,SI 1E6E REPEAT: A=$SI+ 1E6F* AA=AA AND 3F 1E72 SWAP AA,BC 1E73+ BC=BC-1 1E74 DO A=$SI+ 1E75 CALL EVAL.SUC 1E78 IF NC, 1E7A IF POS, 1E7C A=7F 1E7E* E:`0 E = D.ALT Condition 1E81 IF EQ, 1E83 E=A Here, D.ALT 1E85* E=E XOR D needs to be 1E87 $(BP+D.ALT)=E Updated. 1E8A* A=A XOR D A = Match 1E8C* E:0 Check Condition 1E8E IF NEG, (partial match) 1E90* A=A AND `0 sign bit only 1E92* A:0 1E94 * IF ZR,EXIT Get ALT 1 Override. 1E96 BC=BC-1 Else, Try Again * LOOP (BC>0) (if more elements) 1E98 GOTO REPEAT 1E9A A=$(SI-2) 1E9D POP BC 1E9E POP SI 1E9F $(SI-1)=A Substitute Canonical 1EA2* $SI:020 Override 1EA5 * IF GT,EXIT 1EA7 $SI=A (in both places) 1EA9+ SI=SI+1 1EAA+ BC=BC-1 1EAB A'=0 Quick Exit if Alt=1 or Keep Overrides 1EAD A=$(SI-1) 1EB0 SWAP AA,DI RETURN DI = Element # 1EB1 RETURN .PAD=10 1EC0 F.M: ENTRY Called after Table built by F.1 1EC0 PUSH BP 1EC1 PUSH DI 1EC2 BP=%(BP+T.PTR) 1EC5 CALL GET.SKIP SI = Prev Emit, A = Skip to Current Emit 1EC8 PUSH SI 1EC9 B=A B = Bytes to be scanned 1ECB C=8 C = Initial Total Shift (bits in a byte) 1ECD A'=0 A'= Constant to be OR'ed 1ECF DO A=$SI+ 1ED0* A:0 Two kinds of codes 1ED2 IF POS, pos--> [len][bits] 1ED4* C=C-A subtract "len" from "shift" 1ED6 A=$SI+ get the "bits" 1ED7+ B=B-1 1ED9* ASL A,C 1EDB* A'=A' OR A shift & OR bits into constant 1EDD * EXIT 1EDF ELSE PUSH AA 1EE0* AA=AA AND 0F neg--> [1000 ref] 1EE3 SWAP AA,DI what we do here is put the 1EE4 A=$(BP+DI) shift into the current code. 1EE6* C=C-A This is done by indexing 1EE8 A=C the handy "Table" F.1 built. 1EEA* ASL A,4 (again subtract shift from C) 1EED* $(SI-1)=$(SI-1) OR A 1EF0 POP AA 1EF1+ B=B-1 loop through all bytes 1EF3 LOOP UNTIL ZR 1EF5* C:0 now, C should = 0 1EF7 BC=(SI+2) save the cutoff index 1EFA POP SI get the begin index 1EFB IF ZR, (DO the following if C=0) 1EFD DI=SI dest = source (at first) 1EFF PUSH %SI put the 1st 2 bytes into a "pipeline" 1F01+ SI=SI+2 now, source = dest+2 1F03* A':0 test the constant we built 1F05 IF EQ, 1F07 $DI=7 if it's zero, EMIT() 1F0A * EXIT 1F0C ELSE A=1 Otherwise, EMIT(A') 1F0E %DI=AA 1F10+ DI=DI+1 1F11+ DI=DI+1 Bump dest +1 or +2 1F12 POP AA and fetch the pipeline. 1F13* DO A:0 Test next byte in pipe. 1F15 IF POS, If pos, skip it & next one 1F17 AA=%SI+ fetch next 2 bytes 1F18 * EXIT 1F1A ELSE $DI=A If neg, move it to the dest 1F1C+ DI=DI+1 & move pipeline 1F1D A=$SI+ +1 byte. 1F1E SWAP A,A' 1F20* SI:BC loop until source = 1F22 LOOP UNTIL EQ end-of-source 1F24 CS: %OBJECT=DI SET new OBJECT index 1F29 POP DI 1F2A POP BP 1F2B IF ZR,RTN 1F2E CALL FAIL.SET Flag an error 1F31 ="8" (expecting total = 8 bits) .P 0020 B.OBJ=32 Base of OJBECT All of this data is BP Relative 0022 S.OBJ=34 Seg of OBJECT ------------------------------- 0024 E.OBJ=36 End of Object 0026 B.FIX=38 Base of Fixup Area (1st fixup byte) 0028 S.FIX=40 Seg of Fixup Area (=SymTab Segment) 002A E.FIX=42 End of Fixups 002C B.SYM=44 Base of Relocated SymTab (Hi SymTab Area) 002E N.SYM=46 Next Symbol in Hi SymTab Area 0030 V.NOW=48 Byte Code of Vector Now being built. 0032 V.TOT=50 Pointer to Total Vector Count (1st Vector) 0034 V.LOC=52 Pointer to Local Vector Count Byte 1F32 FINAL ENTRY 1F32 DS=CS 1F34* %OBJECT:0 1F39 IF NZ,CALL ALL.DEFS 1F3E A=$ERR.CNT 1F41* A:0 Suppress FINAL if ERR.CNT > 0 1F43 IF ZR, 1F45* %OBJECT:0 1F4A SI=@EMPTY Empty OBJECT --> Abort 1F4D IF EQ,GOTO DSPLY (without rewriting Source) 1F51 CALL I.FINAL Build the final Object File 1F54 CALL PAT.VECT 1F57 CALL VECT.MORE 1F5A CALL FIX.VECTS 1F5D CALL MOVE.OBJ (RETURNs AA=0) 1F60 DS=CS 1F62 %SYMTAB=@0 Reset SYMTAB Index = 0 1F68 ES=CS 1F6A RETURN 1F6B PAT.VECT SI=%(BP+B.SYM) <<<<<< Here we build the Pattern Vector 1F6E %(BP+N.SYM)=SI [@next][@sub1][@sub2]... [next] 1F71 HL=DE All addresses must be Emitted with 1F73 %(BP+V.NOW)='E580' CR (Code Relative) Fixups. 1F78 DO CALL EMIT.CR 1st time Emit placeholder for [@next] 1F7B DO AA=%(BP+V.NOW) 1F7E* AA:%SI Test IF Entry = E5,Token 1F80 IF EQ, Be sure Entry = Token, 1F82* $(SI+2):-1 & LOOP 1F86 * IF EQ, EXIT while it's not. 1F88 A=$SI NOTE: 1st Entry is ALWAYS a 1F8A* AA=AA AND 0F Def(name), not a Def(Token) 1F8D* SI=SI+AA (so we always skip it) 1F8F* $SI:0 didn't see Token? Then DONE. 1F92 * IF NZ,LOOP Original [@Next] = 1F94 %(HL+1)=BC count of addresses 1F97 RETURN emitted so far. 1F98+ $(BP+V.NOW+1)=$(BP+V.NOW+1)+1 1F9B AA=%(SI+3) Capture Address = Token 1F9E SI=%(BP+B.SYM) for the Pattern Vector. 1FA1 LOOP (starting SI over again) .PAD=10 1FB0+EMIT.CR BC=BC+2 Emit a Code Relative Address (in AA) 1FB2 SWAP AA,DE 1FB3 A=083 1FB5 $DI+=A Reg Usage: 1FB6 SWAP AA,DE BC = Total Bytes Emitted 1FB7 %DI+=AA DE = Most Recent Fixup 1FB8 DE=(DI-3) DI = Next Emit Location 1FBB RETURN 1FBC EMIT.AA CALL EMIT..A Emit AA without a new Fixup 1FBF SWAP A,A' 1FC1+EMIT..A BC=BC+1 Emit A without a new Fixup 1FC2 SWAP DE,DI (Unless Prev Fixup at Max Skip) 1FC4+ ES: $DI=$DI+1 1FC7* ES: $DI::00111111 1FCB IF ZR, 1FCD+ ES: $DI=$DI-1 Here we insert an 1FD0 DI=DE Extension Fixup 1FD2 ES: $DI=2 1FD6+ DE=DE+1 1FD7 SWAP DE,DI 1FD9 $DI+=A 1FDA RETURN 1FDB I.FINAL DI,ES=%SYMTAB <<<<<< INITIALIZE for FINAL operations. 1FDF %(BP+S.FIX)=ES Start Work in the SymTab Segment. 1FE2* BC=0 1FE4 %(BP+B.OBJ)=BC 1FE7 AA=%OBJECT 1FEA %(BP+E.OBJ)=AA 1FED AA=%OBJECT+2 Later we will work in Object Segment. 1FF0 %(BP+S.OBJ)=AA 1FF3 DS=ES 1FF5 SI=DI 1FF7 PUSH DI 1FF8* AA=0 1FFA* DO SI=SI+AA Find the end of the SymTab 1FFC A=$SI 1FFE* A=A AND 0F 2000 LOOP UNTIL ZR 2002* DI=DI-SI 2004+ DI=DI-1 Compute uppermost address to which it 2005 %(BP+B.SYM)=DI can be moved inside the 64K segment. 2008 POP SI 2009 PUSH SI 200A DO $DI+=$SI+ Move upper SymTab to Upper Segment. 200B* DI:0 200D LOOP UNTIL EQ 200F POP DI 2010 %DI+=AA Tack 0,0 onto end of Lower SymTab 2011 $DI+=A 2012 %DI+=AA Preface Lower Object with 3,0,0 2013 $(DI-3)=3 (DataUsed=0) 2017 DE=DI 2019 %(BP+B.FIX)=DE DE & these pointers are used to 201C %(BP+E.FIX)=DE control Fixup Emits (see next page) 201F RETURN .PAD=10 2030*VECT.MORE AA=0 <<<<<< Build all the Statement Vectors 2032 %(BP+V.TOT)=DI Index of Total Vector Count 2035 %(BP+V.LOC)=DI Index of Local Vector Count 2038 CALL EMIT.AA Placeholder=0,0 203B A=020 203D CALL NEXT.VECT A = Beginner Byte of Next Vector 2040+ A=A+1 AA comes back unchanged. 2042 DO HL=%(BP+V.TOT) Each time thru, Bump Total Count 2045+ $HL=$HL+1 2047 %(BP+V.LOC)=DI What we want to do is build 204A PUSH AA a vector for all statements 204B* AA=0 that begin with a 204D CALL EMIT.AA and that begin with each 2050 POP AA given byte code 21-60,7B-7E. 2051 DO CALL NEXT.VECT 2054 HL=%(BP+V.LOC) 2057 A'=$(HL+1) If count = 0, vector is null 205A* A':0 205C * IF NZ,EXIT 205E CALL BUMP.A so, try same vector again 2061 * IF EQ,EXIT 2063 LOOP 2065 %HL=AA deposit final , 2067 CALL BUMP.A 206A LOOP UNTIL EQ and loop for another vector. 206C RETURN 206D FIX.VECTS SI=%(BP+B.FIX) <<<<<<< Here we add BC to all addresses 2070+ SI=SI+1 in the vectors (except the 1st). 2071 AA=%SI+ 2072* LSR AA Here the 1st Address is divided by 2 2074+ DO A=A-1 to give a count of pattern addresses. 2076 * IF ZR,EXIT [ 2][vect1] 2078+ SI=SI+1 [ 4][sub1][vect1] 2079* %SI=%SI+BC [ 6][sub1][sub2][vect1] 207B+ SI=SI+2 Note: Fixups between Addresses 207D LOOP must be skipped. 207F AA=%SI+ A = Count of Vectors 2080* DO A':0 A' = Count of Addresses 2082 IF NE, 2084+ DO SI=SI+1 Skip the fixup 2085* %SI=%SI+BC Bump the address 2087+ SI=SI+2 2089+ A'=A'-1 208B LOOP UNTIL ZR 208D+ SI=SI+1 Ignore Byte Code in Upper Vectors 208E A'=$SI but, grab the Address Count 2090+ SI=SI+1 now, point at 1st fixup byte 2091+ A=A-1 2093 LOOP UNTIL ZR Loop for each Vector. 2095 RETURN 2096+BUMP.A A=A+1 A=020 --> Match 2098* A:"a" otherwise, A = 021..060, 07B..07E 209A IF EQ, 209C* A=A+26 Skip "a" thru "z" 209E* A:7F 20A0 RETURN Return EQ when A = 7F (cutoff point) .PAD=10 20B0 MATCH.ALT PUSH SI <<<<<< Match 1st Element in ALT 20B1 A=$SI+ with Byte in $(BP+V.NOW) 20B2* A=A AND 03F 20B4 SWAP A,A' A' = [skip], $SI = 20B6+ DO A'=A'-1 Count down to zero; Ignore null Alt. 20B8 * IF ZR,EXIT Each ALT MAY begin with 20BA A=$SI+ n,0X due to >prefix, 20BB* A:"n" or an Override Code < 020 20BD * IF EQ,LOOP (0X looks like an Override) 20BF* A:020 Ignore an Override Code < 020 20C1 * IF LT,LOOP 20C3* A:$(BP+V.NOW) Here, A=Good Primitive 20C6 IF NE, and V.NOW = 20..60, 7B..7F 20C8* A:"a" where, 20 (in V.NOW) 20CA * IF LT,EXIT matches ONLY A = 61..6C 20CC* A:"m" 20CE IF LT, 20D0* $(BP+V.NOW):020 20D4 * IF EQ,NEXT 20D6* A:0 20D8 * IF POS,EXIT 20DA* A=A XOR `0 Here, A = 20DC A'=3 20DE* AA=A*A' 20E0 SWAP AA,DI 20E1 HL=%(BP+B.FIX) 20E4 ES: DI=%(HL+DI+4) 20E8 SWAP AA,DI Here, AA = @Subpattern 20E9 CALL SUB.TRAVEL 20EC POP SI 20ED RETURN Flag comes from SUB.TRAVEL 20EE. CY=1 20EF POP SI Flag a Match 20F0 RETURN 20F1. CY=0 20F2 POP SI Flag a failure to Match 20F3 RETURN 20F4 TRAVEL PUSH DS Save/Restore all regs used by SUB.TRAVEL 20F5 PUSH SI 20F6 PUSH AA 20F7 DS=%(BP+S.OBJ) Look at the Object Segment 20FA CALL SUB.TRAVEL 20FD POP AA 20FE POP SI 20FF POP DS 2100 RETURN 2101 SUB.TRAVEL SWAP AA,SI 2102 DO CALL MATCH.ALT once for each ALT 2105 * IF CY,EXIT until CY --> Match 2107 A=$SI 2109* AA=AA AND 3F 210C* SI=SI+AA 210E* $SI:0 or, until no more ALTs. 2111 LOOP WHILE POS NC --> Fail 2113 RETURN .PAD=10 2120 NEXT.VECT PUSH AA <<<<<< Here we scan SymTab for 2121 $(BP+V.NOW)=A all Statement Definitions 2124 SI=%(BP+B.SYM) Looking to find ones that begin 2127* AA=0 with = $(BP+V.NOW) 2129* DO SI=SI+AA 212B* $SI:0E5 212E IF EQ, 2130* %(SI+1):@0 Look for E5 entries 2135 * IF NE,EXIT with Token = @0 2137 AA=%(SI+3) 213A CALL TRAVEL and traverse all its ALTS 213D * IF NC,EXIT CY --> Beginner Matched 213F CALL EMIT.CR Emit Address just traversed. 2142 HL=%(BP+V.LOC) 2145+ $(HL+1)=$(HL+1)+1 Bump the Vector Count Byte 2148* AA=0 214A A=$SI 214C* A=A AND 0F 214E LOOP WHILE NZ 2150 POP AA 2151 RETURN 2152 MOVE.OBJ SI,DS=%(BP+B.OBJ) 2155 DO A=$SI+ 2156 CALL EMIT..A 2159* SI:%(BP+E.OBJ) 215C LOOP UNTIL GT 215E* AA=0 2160 %DI+=AA 2161 RETURN 2162 NEXT . 1932 FAIL.WRAP 1994 GET.EMIT 19F5 EMIT.A 1A03 GET.TOKEN 1A2F FILE.CHR 1A3A E.O.MEM 1A76 ERROR.A 1A89 SYMTAB 1BC6 OBJECT 1E31 PARMS 1E42 BUMP.E.CNT 1E45 NO.DEF.1 1E48 DSPLY 1EC5 GET.SKIP 1F2E FAIL.SET 1F3E ERR.CNT 1F4A EMPTY