Yet another simple compiler for Apple DOS/6502

There are two sources - cross compiler (host - MS DOS/8086, target - Apple DOS/6502) and self compiler (host and target - Apple DOS/6502). Compiled program must be placed in file with name C.PRG, compiled result are saved in file C.COM. Apple DOS version was tested in AppleWin 1.23 emulator (in Apple //e mode) and CiderPress 3.0.1 disk utility.

Compiler source code listed below may be compiled with Tiny Context 1.18 (c.118), or with Context but it requires four modifications of source code:

char Temp [16640]; // Before char Text [16384]; // Because memory models are different word Digraph(char C1, char C2) is -> word Digraph(char C1; char C2) is word Emi3(word P, word W) is -> word Emi3(word P; word W) is word MkIX(word I, word D) is -> word MkIX(word I; word D) is

Cross-compiler:

char Text [16384]; word pText; word nText; word nLine; byte Code [16384]; word nCode; word hFile; char Heap [ 2048]; word nHeap; word Name [ 144]; word Cls [ 144]; word Sub [ 144]; word Type [ 144]; word Size [ 144]; word Ofs [ 144]; word nName; word cBase; word nData; word Stk [ 128]; word pStk; char Buff [ 128]; word open() is inline 0xB0, 0x00; // mov AL, 00H inline 0xB4, 0x3D; // mov AH, 3DH inline 0xB2, 0x4A; // mov DL, Lo(@@Data+Ofs(Heap[64])) inline 0xB6, 0xC1; // mov DH, Hi(@@Data+Ofs(Heap[64])) inline 0xCD, 0x21; // int 21H inline 0x8A, 0xD0; // mov DL, AL inline 0x8A, 0xF4; // int DH, AH end word create() is inline 0xB4, 0x3C; // mov AH, 03CH inline 0xB1, 0x00; // mov CL, 00H inline 0xB5, 0x00; // mov CH, 00H inline 0xB2, 0x50; // mov DL, Lo(@@Data+Ofs(Heap[70])) inline 0xB6, 0xC1; // mov DH, Hi(@@Data+Ofs(Heap[70])) inline 0xCD, 0x21; // int 21H inline 0x8A, 0xD0; // mov DL, AL inline 0x8A, 0xF4; // int DH, AH end word read() is inline 0xB4, 0x3F; // mov AH, 3FH inline 0x8A, 0x1E, 0x08, 0xC1; // mov BL, [@@DATA+Ofs(hFile)] inline 0x8A, 0x3E, 0x09, 0xC1; // mov BH, [@@DATA+Ofs(hFile)+1] inline 0xB1, 0x00; // mov CL, 00H inline 0xB5, 0x40; // mov CH, 40H inline 0xB2, 0x00; // mov DL, Lo(@@DATA+Ofs(Text)) inline 0xB6, 0x41; // mov DH, Hi(@@DATA+Ofs(Text)) inline 0xCD, 0x21; // int 21H inline 0x8A, 0xD0; // mov DL, AL inline 0x8A, 0xF4; // int DH, AH end word write() is inline 0xB4, 0x40; // mov AH, 40H inline 0x8A, 0x1E, 0x08, 0xC1; // mov BL, [@@DATA+Ofs(hFile)] inline 0x8A, 0x3E, 0x09, 0xC1; // mov BH, [@@DATA+Ofs(hFile)+1] inline 0x8A, 0x0E, 0x06, 0xC1; // mov CL, [@@DATA+Ofs(nCode)] inline 0x8A, 0x2E, 0x07, 0xC1; // mov CH, [@@DATA+Ofs(nCode)+1] inline 0xB2, 0x06; // mov DL, Lo(@@DATA+Ofs(Code)) inline 0xB6, 0x81; // mov DH, Hi(@@DATA+Ofs(Code)) inline 0xCD, 0x21; // int 21H end word close() is inline 0xB4, 0x3E; // mov AH, 3EH inline 0x8A, 0x1E, 0x08, 0xC1; // mov BL, [@@DATA+Ofs(hFile)] inline 0x8A, 0x3E, 0x09, 0xC1; // mov BH, [@@DATA+Ofs(hFile)+1] inline 0xCD, 0x21; // int 21H end char putc(char C) is inline 0x8A, 0xD0; // mov DL, AL inline 0xB4, 0x02; // mov AH, 02H inline 0xCD, 0x21; // int 21H end word halt() is inline 0xB0, 0x00; // mov AL, 00H inline 0xB4, 0x4C; // mov AH, 4CH inline 0xCD, 0x21; // int 21H end word mul (word A, word B) is word M:=0; while B >0 do word T :=A; word I :=1; while B-I>=I do T:=T+T; I:=I+I; end M:=M+T; B:=B-I; end return M; end word div (word A, word B) is word D:=0; while A>=B do word T :=B; word I :=1; while A-T>=T do T:=T+T; I:=I+I; end A:=A-T; D:=D+I; end return D; end word mod (word A, word B) is return A-mul(div(A,B),B); end word Init() is Heap[ 0]:='0'; Heap[ 1]:='1'; Heap[ 2]:='2'; Heap[ 3]:='3'; Heap[ 4]:='4'; Heap[ 5]:='5'; Heap[ 6]:='6'; Heap[ 7]:='7'; Heap[ 8]:='8'; Heap[ 9]:='9'; Heap[10]:='A'; Heap[11]:='B'; Heap[12]:='C'; Heap[13]:='D'; Heap[14]:='E'; Heap[15]:='F'; Heap[16]:='c'; Heap[17]:='h'; Heap[18]:='a'; Heap[19]:='r'; Heap[20]:= char(0); Heap[21]:='b'; Heap[22]:='y'; Heap[23]:='t'; Heap[24]:='e'; Heap[25]:= char(0); Heap[26]:='w'; Heap[27]:='o'; Heap[28]:='r'; Heap[29]:='d'; Heap[30]:= char(0); Heap[31]:='b'; Heap[32]:='e'; Heap[33]:='g'; Heap[34]:='i'; Heap[35]:='n'; Heap[36]:= char(0); Heap[37]:='i'; Heap[38]:='f'; Heap[39]:= char(0); Heap[40]:='w'; Heap[41]:='h'; Heap[42]:='i'; Heap[43]:='l'; Heap[44]:='e'; Heap[45]:= char(0); Heap[46]:='i'; Heap[47]:='n'; Heap[48]:='l'; Heap[49]:='i'; Heap[50]:='n'; Heap[51]:='e'; Heap[52]:= char(0); Heap[53]:='r'; Heap[54]:='e'; Heap[55]:='t'; Heap[56]:='u'; Heap[57]:='r'; Heap[58]:='n'; Heap[59]:= char(0); Heap[60]:='e'; Heap[61]:='n'; Heap[62]:='d'; Heap[63]:= char(0); Heap[64]:='c'; Heap[65]:='.'; Heap[66]:='p'; Heap[67]:='r'; Heap[68]:='g'; Heap[69]:= char(0); Heap[70]:='c'; Heap[71]:='.'; Heap[72]:='c'; Heap[73]:='o'; Heap[74]:='m'; Heap[75]:= char(0); nHeap :=76; Name[ 0]:=16; Cls [ 0]:= 1; Size[ 0]:= 1; Name[ 1]:=21; Cls [ 1]:= 1; Size[ 1]:= 1; Name[ 2]:=26; Cls [ 2]:= 1; Size[ 2]:= 2; nName := 3; pStk := 0; nCode := 0; cBase := 3072; nData := cBase+16384; end word Push(word V) is Stk[pStk]:=V; pStk:=pStk+1; end word Pop () is pStk:=pStk-1; return Stk[pStk]; end char putn(word N) is pStk:=0; while N!=0 do Push (mod(N,10)); N:=div(N,10); end while pStk!=0 do putc(char(Pop()+48)); end end word Stop() is putn (nLine); close(); halt (); end word val () is word E:=10; word I:= 0; if Buff[0]='0' then if Buff[1]='x' then E:=16; I:= 2; end end word N:=0; while Buff[I]!=char(0) do word K:=0; while Heap[K]!=Buff[I] do if K=E then Stop(); end K:=K+1; end N:=mul(N,E)+K; I:=I+1; end return N; end char Look() is if pText>=nText then pText :=0; nText :=read(); if pText>=nText then return char(0); end end return Text[pText]; end char Read() is char Ch:=Look(); if Ch =char(10) then nLine :=nLine+1; end pText :=pText+1; return Ch; end word isalnum() is if 'A'<=Look() then if Look()<='Z' then return 0; end end if 'a'<=Look() then if Look()<='z' then return 0; end end if '0'<=Look() then if Look()<='9' then return 0; end end return 1; end word Digraph(char C1, char C2) is if Buff[0]=C1 then if Look()=C2 then Buff[1]:=Read(); Buff[2]:=char(0); end end end char Scan() is word pBuff:=0; while pBuff =0 do word sFlag:=0; while sFlag =0 do if Look()!=char( 9) then if Look()!=char(10) then if Look()!=char(13) then if Look()!=char(32) then sFlag:=1; end end end end if sFlag=0 then Read(); end end while isalnum()=0 do Buff[pBuff]:= Read(); pBuff :=pBuff+1; end if pBuff=0 then Buff[pBuff]:= Read(); pBuff :=pBuff+1; end Buff[pBuff] :=char(0); Digraph('<','='); Digraph('!','='); Digraph('>','='); Digraph(':','='); if Buff[0]='/' then if Look()='/' then while Look()!=char(10) do if Read()=char(0) then Stop(); end end pBuff:=0; end end end end word Comp(word pHeap) is word pBuff:=0; while Buff[pBuff]=Heap[pHeap] do if Buff[pBuff]=char(0) then return 0; end pHeap:=pHeap+1; pBuff:=pBuff+1; end return 1; end word Find(word fFlag) is word pName:=0; while pName< nName do if Comp(Name[pName])=0 then return pName; end pName:=pName+1; end if fFlag=0 then Stop(); end return pName; end byte Emi1(byte B) is Code[nCode]:=B; nCode:=nCode+1; end word Emi2(word W) is Emi1(mod(W,256)); Emi1(div(W,256)); end word Emi3(word P, word W) is W:=W+cBase; Code[P] :=mod(W,256); Code[P+1]:=div(W,256); end word MkIX(word I, word D) is if Size[Type[I]]=2 then Emi1(0x18); // clc Emi1(0x8A); // txa Emi1(0x0A); // asl Emi1(0xAA); // tax Emi1(0x98); // tya Emi1(0x2A); // rol Emi1(0xA8); // tay end Emi1(0x18); // clc Emi1(0x8A); // txa Emi1(0x69); // adc #Val Emi1(mod(Ofs[I],256)); if D =0 then Emi1(0x85); // sta 0xFE Emi1(0xFE); end if D!=0 then Emi1(0xAA); // tax end Emi1(0x98); // tya Emi1(0x69); // adc #Val Emi1(div(Ofs[I],256)); if D =0 then Emi1(0x85); // sta 0xFF Emi1(0xFF); end if D!=0 then Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha end end word Assign(word I) is if Size[I]>1 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x85); // sta 0xFF Emi1(0xFF); if Size[Type[I]]=2 then Emi1(0x98); // tya Emi1(0xA0); // ldy #1 Emi1(0x01); Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); Emi1(0x88); // dey Emi1(0x8A); // txa Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); end if Size[Type[I]]=1 then Emi1(0xA0); // ldy #0 Emi1(0x00); Emi1(0x8A); // txa Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); end end if Size[I]=1 then Emi1(0x8E); // stx Adr Emi2(Ofs[I]); if Size[Type[I]]=2 then Emi1(0x8C); // sty Adr Emi2(Ofs[I]+1); end end end word Expr() is word eFlag:=0; //if eFlag =0 then if '0'<=Buff[0] then if Buff[0]<='9' then word W:=val(); Emi1(0xA2); // ldx #Val Emi1(mod(W,256)); Emi1(0xA0); // ldy #Val Emi1(div(W,256)); eFlag:=1; end end if Buff[0]=''' then Emi1(0xA2); // ldx #Val Emi1(byte(Read())); Emi1(0xA0); // ldy #0 Emi1(0x00); Read(); eFlag:=1; end if Buff[0]='(' then Scan(); Expr(); eFlag:=1; end //end if eFlag =0 then word I:=Find(0); if Cls[I]=1 then Push(I); Scan(); // ( Scan(); Expr(); I:=Pop(); end if Cls[I]=2 then if Size[I]>1 then Push(I); Scan(); // [ Scan(); Expr(); I:=Pop(); MkIX(I, 0); Emi1(0xA0); // ldy #0 Emi1(0x00); Emi1(0xB1); // lda (0xFE),Y Emi1(0xFE); Emi1(0xAA); // tax if Size[Type[I]]=2 then Emi1(0xC8); // iny Emi1(0xB1); // lda (0xFE),Y Emi1(0xFE); Emi1(0xA8); // tay end end if Size[I]=1 then Emi1(0xAE); // ldx Adr Emi2(Ofs[I]); if Size[Type[I]]=2 then Emi1(0xAC); // ldy Adr Emi2(Ofs[I]+1); end end if Size[Type[I]]=1 then Emi1(0xA0); // ldy #0 Emi1(0x00); end end if Cls[I]=3 then Scan(); // ( Push(I); Sub[nName]:= 0; word J:=I+1; while Sub[J]=1 do Push(J); Scan(); Expr(); J:=Pop(); Assign(J); J:=J+1; end I:=Pop(); if J=I+1 then Scan(); // ) end Emi1(0x20); // jsr Emi2(Ofs[I]+cBase); end end Scan(); word Op:=0x00; if Buff[0]='+' then Op:=0x65; end if Buff[0]='-' then Op:=0xE5; end if Op!=0 then Emi1(0x98); // tya Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha Push(Op); Scan(); Expr(); Op:=Pop(); Emi1(0x86); // stx 0xFE Emi1(0xFE); Emi1(0x84); // sty 0xFF Emi1(0xFF); if Op=0x65 then Emi1(0x18); // clc end if Op=0xE5 then Emi1(0x38); // sec end Emi1(0x68); // pla Emi1(Op); // opr 0xFE Emi1(0xFE); Emi1(0xAA); // tax Emi1(0x68); // pla Emi1(Op); // opr 0xFF Emi1(0xFF); Emi1(0xA8); // tay end end word Cond() is Scan(); Expr(); word jType := 0; word jOfs1 := 0; word jCode2:=0x90; // bcc if Buff[0]='<' then jType := 1; if Buff[1]='=' then jType := 2; jCode2 :=0xB0; // bcs end end if Buff[0]='=' then jType := 3; jOfs1 := 6; jCode2 :=0xF0; // beq end if Buff[0]='!' then jType := 3; jOfs1 := 9; jCode2 :=0xD0; // bne end if Buff[0]='>' then jType := 2; if Buff[1]='=' then jType := 1; jCode2 :=0xB0; // bcs end end if jType=0 then Stop(); end Emi1(0x98); // tya Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha Scan(); Expr(); if jType=1 then Emi1(0x68); // pla Emi1(0x86); // stx 0xFE Emi1(0xFE); Emi1(0x38); // sec Emi1(0xE5); // sbc 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x84); // sty 0xFF Emi1(0xFF); Emi1(0xE5); // sbc 0xFF Emi1(0xFF); end if jType=2 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x8A); // txa Emi1(0x38); // sec Emi1(0xE5); // sbc 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x85); // sta 0xFF Emi1(0xFF); Emi1(0x98); // tya Emi1(0xE5); // sbc 0xFF Emi1(0xFF); end if jType=3 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0xE4); // cpx 0xFE Emi1(0xFE); Emi1(0xD0); // bne Emi1(jOfs1); Emi1(0x85); // sta 0xFF Emi1(0xFF); Emi1(0xC4); // cpy 0xFF Emi1(0xFF); end Emi1(jCode2); // bxx $+3 Emi1(0x03); Push(nCode); Emi1(0x4C); // jmp ? nCode:=nCode+2; end word Obj (word T) is if Cls[T]!=1 then Stop(); end Name[nName]:=nHeap; Type[nName]:= T; Scan(); if Find(1)<nName then Stop(); end word pBuff:=0; char Ch :=char(1); while Ch !=char(0) do Ch := Buff[pBuff]; Heap[nHeap]:= Ch; nHeap :=nHeap+1; pBuff :=pBuff+1; end Scan(); return nName; end char Var (word Subclass) is Cls [nName]:= 2; Sub [nName]:= Subclass; Size[nName]:= 1; Ofs [nName]:=nData; if Buff[0]='[' then if Subclass!=0 then Stop(); end Scan(); Size[nName]:=val(); Scan(); // ] Scan(); // ; end nData :=nData+mul(Size[nName],Size[Type[nName]]); nName :=nName+1; return Buff[0]; end word Hide() is word I:=Pop(); while I< nName do Heap[Name[I]]:=char(0); I :=I+1; end end word rFlag; word Ctrl() is word cFlag:=0; //if cFlag =0 then if Comp(37)=0 then // if Cond(); Push(nName); Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end Hide(); Emi3(Pop()+1,nCode); rFlag:=1; // 14.05.2006 cFlag:=1; end //end if cFlag =0 then if Comp(40)=0 then // while Push(nCode); Cond(); Push(nName); Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end Hide(); word pExit:=Pop(); word pLoop:=Pop(); Emi1(0x4C); // jmp Ofs Emi2(pLoop+cBase); Emi3(pExit+1,nCode); rFlag:=1; // 14.05.2006 cFlag:=1; end end if cFlag =0 then if Comp(46)=0 then // inline Buff[0]:=','; while Buff[0]=',' do Scan(); Emi1(val()); // db Val Scan(); end rFlag:=1; // 14.05.2006 cFlag:=1; end end if cFlag =0 then if Comp(53)=0 then // return Scan(); Expr(); Emi1(0x60); // rts rFlag:=0; // 14.05.2006 cFlag:=1; end end if cFlag =0 then word I:=Find(0); if Cls[I]=1 then word N:=Obj(I); if Var(2)=':' then Scan(); Expr(); Assign(N); end end if Cls[I]=2 then if Size[I]>1 then Scan(); // [ Scan(); Expr(); MkIX(I, 1); end Scan(); // := Scan(); Expr(); Assign(I); end if Cls[I]=3 then Expr(); end rFlag:=1; // 14.05.2006 end Scan(); end word Func() is Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end if rFlag!=0 then // 14.05.2006 // if rFlag=0 then Emi1(0x60); // rts end end word X; begin Init(); hFile:=open(); pText:=0; nText:=0; nLine:=1; Emi1(0x4C); // jmp ? nCode:=nCode+2; Scan(); while Comp(31)!=0 do // !begin Obj (Find(0)); char Ch:=Buff[0]; if Ch ='(' then Cls [nName]:= 3; Sub [nName]:= 0; Ofs [nName]:=nCode; nName :=nName+1; Push(nName); Scan(); if Buff[0]!=')' then Obj (Find(0)); while Var(1)=',' do Scan(); Obj (Find(0)); end end Scan(); // is Func(); Hide(); end if Ch!='(' then Var(0); end Scan(); end Emi3 (1,nCode); Func (); close(); hFile:=create(); write(); close(); X:=0; end

Apple DOS version are based on code listed above but has another I/O functions and some other minor differences.

To load and run program use following commands

BLOAD C.COM, A3072 CALL 3072

File write function work incorrect and commented. Instead of compiler print plus character and code size. To store compiled program on disk use following command:

BSAVE <FILE_NAME>, A$4F56, L<CODE_SIZE>

Note that this command write incorrect load address 0x4F56. Correct address 0x0C00 (3072) must be present in BLOAD command.

On 1 MHz Apple //e compilation of compiler itself requires about 2 minutes.

byte FMWA [ 46]; // 0x4C00 // 45 + 1 extra byte byte TSLB [ 256]; // 0x4C2E byte DSB [ 256]; // 0x4D2E char FName[ 30]; // 0x4E2E char Text [ 256]; // 0x4E4C word pText; // 0x4F4C word nText; // 0x4F4E word nLine; // 0x4F50 byte Code [14336]; // 0x4F52 word nCode; // 0x8752 char Heap [ 2048]; word nHeap; word Name [ 144]; byte Cls [ 144]; byte Sub [ 144]; byte Type [ 144]; word Size [ 144]; word Ofs [ 144]; word nName; word cBase; word nData; word Stk [ 128]; word pStk; char Buff [ 32]; word GetResultCode() is inline 0xA0, 0x0A; // ldy #0x0A inline 0xB1, 0xEE; // lda (0xEE), Y inline 0xAA; // tax inline 0xA0, 0x00; // ldy #0x00 end word InitFMPL() is inline 0x20, 0xDC, 0x03; // jsr 0x03DC ;Locate FMPL inline 0x84, 0xEE; // sty 0xEE inline 0x85, 0xEF; // sta 0xEF inline 0xA9, 0x00; // lda #>FMWA inline 0xA0, 0x0C; // ldy #0x0C inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4C; // lda #<FMWA inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x2E; // lda #>TSLB inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4C; // lda #<TSLB inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x2E; // lda #>DSB inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4D; // lda #<DSB inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y end word SetVDS() is inline 0x20, 0xE3, 0x03; // jsr 0x03E3 ;Locate RPL inline 0x84, 0xEC; // sty 0xEC inline 0x85, 0xED; // sta 0xED inline 0xA9, 0x00; // lda #0x00 inline 0xA0, 0x04; // ldy #0x04 ;Volume inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA0, 0x02; // ldy #0x02 inline 0xB1, 0xEC; // lda (0xEC), Y inline 0xA0, 0x05; // ldy #0x05 ;Drive inline 0x91, 0xEE; // sta (0xEE), Y inline 0xAA; // tax ;return inline 0xA0, 0x01; // ldy #0x01 inline 0xB1, 0xEC; // lda (0xEC), Y inline 0x4A; // lsr A inline 0x4A; // lsr A inline 0x4A; // lsr A inline 0x4A; // lsr A inline 0xA0, 0x06; // ldy #0x06 ;Slot inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA8; // tay ;return end word CallFMforOpen() is inline 0xA9, 0x01; // lda #0x01 ;Open inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x00; // lda #0x00 inline 0xA0, 0x02; // ldy #0x02 ;Record length inline 0x91, 0xEE; // sta (0xEE), Y inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y SetVDS(); inline 0xA9, 0x00; // lda #0x00 ;Text //inline 0xA9, 0x04; // lda #0x04 ;Binary inline 0xA0, 0x07; // ldy #0x07 ;File type inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x2E; // lda #>FName inline 0xC8; // iny ;File name inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4E; // lda #<FName inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA2, 0x01; // ldx #0x01 ;File exists inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word open() is CallFMforOpen(); return GetResultCode(); end word CallFMforCreate() is inline 0xA9, 0x01; // lda #0x01 ;Open inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x00; // lda #0x00 inline 0xA0, 0x02; // ldy #0x02 ;Record length inline 0x91, 0xEE; // sta (0xEE), Y inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y SetVDS(); inline 0xA9, 0x04; // lda #0x04 ;Binary inline 0xA0, 0x07; // ldy #0x07 ;File type inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x2E; // lda #>FName inline 0xC8; // iny ;File name inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4E; // lda #<FName inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA2, 0x00; // ldx #0x00 ;File may not exists inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word create() is CallFMforCreate(); return GetResultCode(); end word CallFMforRewind() is inline 0xA9, 0x0A; // lda #0x0A ;Position inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x00; // lda #0x00 inline 0xA0, 0x00; // ldy #0x02 ;Record number inline 0x91, 0xEE; // sta (0xEE), Y inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word rewind() is CallFMforRewind(); return GetResultCode(); end word CallFMforRead() is inline 0xA9, 0x03; // lda #0x03 ;Read inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x02; // lda #0x02 ;Range inline 0xC8; // iny ;Subcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x00; // lda #0x00 ;Lo(sizeof Text) inline 0xA0, 0x06; // ldy #0x06 ;Range length inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x01; // lda #0x01 ;Hi(sizeof Text) ; 0x04! inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4C; // lda #0x4C ;Lo(@Text) inline 0xC8; // iny ;Text addr inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4E; // lda #0x4E ;Hi(@Text) inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word read() is CallFMforRead(); return GetResultCode(); end word CallFMforWrite() is inline 0xA9, 0x04; // lda #0x04 ;Write inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x02; // lda #0x02 ;Range inline 0xC8; // iny ;Subcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0xAD, 0x52, 0x87; // lda 0x8752 ;Lo(nCode) inline 0xA0, 0x06; // ldy #0x06 ;Range length inline 0x91, 0xEE; // sta (0xEE), Y inline 0xAD, 0x53, 0x87; // lda 0x8753 ;Hi(nCode) inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x52; // lda #0x52 ;Lo(@Code) inline 0xC8; // iny ;Code addr inline 0x91, 0xEE; // sta (0xEE), Y inline 0xA9, 0x4F; // lda #0x4F ;Hi(@Code) inline 0xC8; // iny inline 0x91, 0xEE; // sta (0xEE), Y inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word write() is CallFMforWrite(); return GetResultCode(); end word CallFMforClose() is inline 0xA9, 0x02; // lda #0x02 ;Close inline 0xA0, 0x00; // ldy #0x00 ;Opcode inline 0x91, 0xEE; // sta (0xEE), Y inline 0x4C, 0xD6, 0x03; // jmp 0x03D6 ;Jump to FM end word close() is CallFMforClose(); return GetResultCode(); end char putc(char C) is inline 0x8A; // txa inline 0x18; // clc inline 0x69, 0x80; // adc #0x80 inline 0x20, 0xF0, 0xFD; // jsr 0xFDF0 end word halt() is inline 0x20, 0xD0, 0x03; // jsr 0x03D0 end word mul (word A, word B) is word M:=0; while B >0 do word T :=A; word I :=1; while B-I>=I do T:=T+T; I:=I+I; end M:=M+T; B:=B-I; end return M; end word div (word A, word B) is word D:=0; while A>=B do word T :=B; word I :=1; while A-T>=T do T:=T+T; I:=I+I; end A:=A-T; D:=D+I; end return D; end word mod (word A, word B) is return A-mul(div(A,B),B); end word Init() is word I:= 0; while I< 30 do FName[I]:=char(0xA0); I:=I+1; end FName[0]:=char(byte('C')+0x80); FName[1]:=char(byte('.')+0x80); FName[2]:=char(byte('P')+0x80); FName[3]:=char(byte('R')+0x80); FName[4]:=char(byte('G')+0x80); Heap[ 0]:='0'; Heap[ 1]:='1'; Heap[ 2]:='2'; Heap[ 3]:='3'; Heap[ 4]:='4'; Heap[ 5]:='5'; Heap[ 6]:='6'; Heap[ 7]:='7'; Heap[ 8]:='8'; Heap[ 9]:='9'; Heap[10]:='A'; Heap[11]:='B'; Heap[12]:='C'; Heap[13]:='D'; Heap[14]:='E'; Heap[15]:='F'; Heap[16]:='c'; Heap[17]:='h'; Heap[18]:='a'; Heap[19]:='r'; Heap[20]:= char(0); Heap[21]:='b'; Heap[22]:='y'; Heap[23]:='t'; Heap[24]:='e'; Heap[25]:= char(0); Heap[26]:='w'; Heap[27]:='o'; Heap[28]:='r'; Heap[29]:='d'; Heap[30]:= char(0); Heap[31]:='b'; Heap[32]:='e'; Heap[33]:='g'; Heap[34]:='i'; Heap[35]:='n'; Heap[36]:= char(0); Heap[37]:='i'; Heap[38]:='f'; Heap[39]:= char(0); Heap[40]:='w'; Heap[41]:='h'; Heap[42]:='i'; Heap[43]:='l'; Heap[44]:='e'; Heap[45]:= char(0); Heap[46]:='i'; Heap[47]:='n'; Heap[48]:='l'; Heap[49]:='i'; Heap[50]:='n'; Heap[51]:='e'; Heap[52]:= char(0); Heap[53]:='r'; Heap[54]:='e'; Heap[55]:='t'; Heap[56]:='u'; Heap[57]:='r'; Heap[58]:='n'; Heap[59]:= char(0); Heap[60]:='e'; Heap[61]:='n'; Heap[62]:='d'; Heap[63]:= char(0); nHeap :=64; //Heap[64]:='c'; //Heap[65]:='.'; //Heap[66]:='p'; //Heap[67]:='r'; //Heap[68]:='g'; //Heap[69]:= char(0); //Heap[70]:='c'; //Heap[71]:='.'; //Heap[72]:='c'; //Heap[73]:='o'; //Heap[74]:='m'; //Heap[75]:= char(0); //nHeap :=76; Name[ 0]:=16; Cls [ 0]:= 1; Size[ 0]:= 1; Name[ 1]:=21; Cls [ 1]:= 1; Size[ 1]:= 1; Name[ 2]:=26; Cls [ 2]:= 1; Size[ 2]:= 2; nName := 3; pStk := 0; nCode := 0; cBase := 3072-4; nData := cBase+16384+4; end word Push(word V) is Stk[pStk]:=V; pStk:=pStk+1; end word Pop () is pStk:=pStk-1; return Stk[pStk]; end char putn(word N) is pStk:=0; while N!=0 do Push (mod(N,10)); N:=div(N,10); end while pStk!=0 do putc(char(Pop()+48)); end end word Stop() is putn (nLine); close(); halt (); end word val () is word E:=10; word I:= 0; if Buff[0]='0' then if Buff[1]='x' then E:=16; I:= 2; end end word N:=0; while Buff[I]!=char(0) do word K:=0; while Heap[K]!=Buff[I] do if K=E then Stop(); end K:=K+1; end N:=mul(N,E)+K; I:=I+1; end return N; end char Look() is if pText>=nText then Text[0]:='$'; pText :=0; nText :=256; read(); end return Text[pText]; end char Read() is char Ch:=Look(); if Ch =char(10) then nLine :=nLine+1; end pText :=pText+1; if Ch!=char(10) then putc(Ch); end return Ch; end word isalnum() is if 'A'<=Look() then if Look()<='Z' then return 0; end end if 'a'<=Look() then if Look()<='z' then return 0; end end if '0'<=Look() then if Look()<='9' then return 0; end end return 1; end word Digraph(char C1, char C2) is if Buff[0]=C1 then if Look()=C2 then Buff[1]:=Read(); Buff[2]:=char(0); end end end char Scan() is word pBuff:=0; while pBuff =0 do word sFlag:=0; while sFlag =0 do if Look()!=char( 9) then if Look()!=char(10) then if Look()!=char(13) then if Look()!=char(32) then sFlag:=1; end end end end if sFlag=0 then Read(); end end while isalnum()=0 do Buff[pBuff]:= Read(); pBuff :=pBuff+1; end if pBuff=0 then Buff[pBuff]:= Read(); pBuff :=pBuff+1; end Buff[pBuff] :=char(0); Digraph('<','='); Digraph('!','='); Digraph('>','='); Digraph(':','='); if Buff[0]='/' then if Look()='/' then while Look()!=char(10) do if Read()=char(0) then Stop(); end end pBuff:=0; end end end end word Comp(word pHeap) is word pBuff:=0; while Buff[pBuff]=Heap[pHeap] do if Buff[pBuff]=char(0) then return 0; end pHeap:=pHeap+1; pBuff:=pBuff+1; end return 1; end word Find(word fFlag) is word pName:=0; while pName< nName do if Comp(Name[pName])=0 then return pName; end pName:=pName+1; end if fFlag=0 then Stop(); end return pName; end byte Emi1(byte B) is Code[nCode]:=B; nCode:=nCode+1; end word Emi2(word W) is Emi1(mod(W,256)); Emi1(div(W,256)); end word Emi3(word P, word W) is W:=W+cBase; Code[P] :=mod(W,256); Code[P+1]:=div(W,256); end word MkIX(word I, word D) is if Size[Type[I]]=2 then Emi1(0x18); // clc Emi1(0x8A); // txa Emi1(0x0A); // asl Emi1(0xAA); // tax Emi1(0x98); // tya Emi1(0x2A); // rol Emi1(0xA8); // tay end Emi1(0x18); // clc Emi1(0x8A); // txa Emi1(0x69); // adc #Val Emi1(mod(Ofs[I],256)); if D =0 then Emi1(0x85); // sta 0xFE Emi1(0xFE); end if D!=0 then Emi1(0xAA); // tax end Emi1(0x98); // tya Emi1(0x69); // adc #Val Emi1(div(Ofs[I],256)); if D =0 then Emi1(0x85); // sta 0xFF Emi1(0xFF); end if D!=0 then Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha end end word Assign(word I) is if Size[I]>1 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x85); // sta 0xFF Emi1(0xFF); if Size[Type[I]]=2 then Emi1(0x98); // tya Emi1(0xA0); // ldy #1 Emi1(0x01); Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); Emi1(0x88); // dey Emi1(0x8A); // txa Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); end if Size[Type[I]]=1 then Emi1(0xA0); // ldy #0 Emi1(0x00); Emi1(0x8A); // txa Emi1(0x91); // sta (0xFE),Y Emi1(0xFE); end end if Size[I]=1 then Emi1(0x8E); // stx Adr Emi2(Ofs[I]); if Size[Type[I]]=2 then Emi1(0x8C); // sty Adr Emi2(Ofs[I]+1); end end end word Expr() is word eFlag:=0; //if eFlag =0 then if '0'<=Buff[0] then if Buff[0]<='9' then word W:=val(); Emi1(0xA2); // ldx #Val Emi1(mod(W,256)); Emi1(0xA0); // ldy #Val Emi1(div(W,256)); eFlag:=1; end end if Buff[0]=''' then Emi1(0xA2); // ldx #Val Emi1(byte(Read())); Emi1(0xA0); // ldy #0 Emi1(0x00); Read(); eFlag:=1; end if Buff[0]='(' then Scan(); Expr(); eFlag:=1; end //end if eFlag =0 then word I:=Find(0); if Cls[I]=1 then Push(I); Scan(); // ( Scan(); Expr(); I:=Pop(); end if Cls[I]=2 then if Size[I]>1 then Push(I); Scan(); // [ Scan(); Expr(); I:=Pop(); MkIX(I, 0); Emi1(0xA0); // ldy #0 Emi1(0x00); Emi1(0xB1); // lda (0xFE),Y Emi1(0xFE); Emi1(0xAA); // tax if Size[Type[I]]=2 then Emi1(0xC8); // iny Emi1(0xB1); // lda (0xFE),Y Emi1(0xFE); Emi1(0xA8); // tay end end if Size[I]=1 then Emi1(0xAE); // ldx Adr Emi2(Ofs[I]); if Size[Type[I]]=2 then Emi1(0xAC); // ldy Adr Emi2(Ofs[I]+1); end end if Size[Type[I]]=1 then Emi1(0xA0); // ldy #0 Emi1(0x00); end end if Cls[I]=3 then Scan(); // ( Push(I); Sub[nName]:= 0; word J:=I+1; while Sub[J]=1 do Push(J); Scan(); Expr(); J:=Pop(); Assign(J); J:=J+1; end I:=Pop(); if J=I+1 then Scan(); // ) end Emi1(0x20); // jsr Emi2(Ofs[I]+cBase); end end Scan(); word Op:=0x00; if Buff[0]='+' then Op:=0x65; end if Buff[0]='-' then Op:=0xE5; end if Op!=0 then Emi1(0x98); // tya Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha Push(Op); Scan(); Expr(); Op:=Pop(); Emi1(0x86); // stx 0xFE Emi1(0xFE); Emi1(0x84); // sty 0xFF Emi1(0xFF); if Op=0x65 then Emi1(0x18); // clc end if Op=0xE5 then Emi1(0x38); // sec end Emi1(0x68); // pla Emi1(Op); // opr 0xFE Emi1(0xFE); Emi1(0xAA); // tax Emi1(0x68); // pla Emi1(Op); // opr 0xFF Emi1(0xFF); Emi1(0xA8); // tay end end word Cond() is Scan(); Expr(); word jType := 0; word jOfs1 := 0; word jCode2:=0x90; // bcc if Buff[0]='<' then jType := 1; if Buff[1]='=' then jType := 2; jCode2 :=0xB0; // bcs end end if Buff[0]='=' then jType := 3; jOfs1 := 6; jCode2 :=0xF0; // beq end if Buff[0]='!' then jType := 3; jOfs1 := 9; jCode2 :=0xD0; // bne end if Buff[0]='>' then jType := 2; if Buff[1]='=' then jType := 1; jCode2 :=0xB0; // bcs end end if jType=0 then Stop(); end Emi1(0x98); // tya Emi1(0x48); // pha Emi1(0x8A); // txa Emi1(0x48); // pha Scan(); Expr(); if jType=1 then Emi1(0x68); // pla Emi1(0x86); // stx 0xFE Emi1(0xFE); Emi1(0x38); // sec Emi1(0xE5); // sbc 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x84); // sty 0xFF Emi1(0xFF); Emi1(0xE5); // sbc 0xFF Emi1(0xFF); end if jType=2 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x8A); // txa Emi1(0x38); // sec Emi1(0xE5); // sbc 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0x85); // sta 0xFF Emi1(0xFF); Emi1(0x98); // tya Emi1(0xE5); // sbc 0xFF Emi1(0xFF); end if jType=3 then Emi1(0x68); // pla Emi1(0x85); // sta 0xFE Emi1(0xFE); Emi1(0x68); // pla Emi1(0xE4); // cpx 0xFE Emi1(0xFE); Emi1(0xD0); // bne Emi1(jOfs1); Emi1(0x85); // sta 0xFF Emi1(0xFF); Emi1(0xC4); // cpy 0xFF Emi1(0xFF); end Emi1(jCode2); // bxx $+3 Emi1(0x03); Push(nCode); Emi1(0x4C); // jmp ? nCode:=nCode+2; end word Obj (word T) is if Cls[T]!=1 then Stop(); end Name[nName]:=nHeap; Type[nName]:= T; Scan(); if Find(1)<nName then Stop(); end word pBuff:=0; char Ch :=char(1); while Ch !=char(0) do Ch := Buff[pBuff]; Heap[nHeap]:= Ch; nHeap :=nHeap+1; pBuff :=pBuff+1; end Scan(); return nName; end char Var (word Subclass) is Cls [nName]:= 2; Sub [nName]:= Subclass; Size[nName]:= 1; Ofs [nName]:=nData; if Buff[0]='[' then if Subclass!=0 then Stop(); end Scan(); Size[nName]:=val(); Scan(); // ] Scan(); // ; end nData :=nData+mul(Size[nName],Size[Type[nName]]); nName :=nName+1; return Buff[0]; end word Hide() is word I:=Pop(); while I< nName do Heap[Name[I]]:=char(0); I :=I+1; end end word rFlag; word Ctrl() is word cFlag:=0; //if cFlag =0 then if Comp(37)=0 then // if Cond(); Push(nName); Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end Hide(); Emi3(Pop()+1,nCode); rFlag:=1; // 14.05.2006 cFlag:=1; end //end if cFlag =0 then if Comp(40)=0 then // while Push(nCode); Cond(); Push(nName); Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end Hide(); word pExit:=Pop(); word pLoop:=Pop(); Emi1(0x4C); // jmp Ofs Emi2(pLoop+cBase); Emi3(pExit+1,nCode); rFlag:=1; // 14.05.2006 cFlag:=1; end end if cFlag =0 then if Comp(46)=0 then // inline Buff[0]:=','; while Buff[0]=',' do Scan(); Emi1(val()); // db Val Scan(); end rFlag:=1; // 14.05.2006 cFlag:=1; end end if cFlag =0 then if Comp(53)=0 then // return Scan(); Expr(); Emi1(0x60); // rts rFlag:=0; // 14.05.2006 cFlag:=1; end end if cFlag =0 then word I:=Find(0); if Cls[I]=1 then word N:=Obj(I); if Var(2)=':' then Scan(); Expr(); Assign(N); end end if Cls[I]=2 then if Size[I]>1 then Scan(); // [ Scan(); Expr(); MkIX(I, 1); end Scan(); // := Scan(); Expr(); Assign(I); end if Cls[I]=3 then Expr(); end rFlag:=1; // 14.05.2006 end Scan(); end word Func() is Scan(); Ctrl(); while Comp(60)!=0 do // !end Ctrl(); end if rFlag!=0 then // 14.05.2006 // if rFlag=0 then Emi1(0x60); // rts end end word X; begin InitFMPL(); Init(); open (); rewind(); nText:=0; pText:=0; nLine:=1; Emi1(0x00); // load addr Emi1(0x0C); Emi1(0x00); // file size Emi1(0x00); Emi1(0x4C); // jmp ? nCode:=nCode+2; Scan(); while Comp(31)!=0 do // !begin Obj (Find(0)); char Ch:=Buff[0]; if Ch ='(' then Cls [nName]:= 3; Sub [nName]:= 0; Ofs [nName]:=nCode; nName :=nName+1; Push(nName); Scan(); if Buff[0]!=')' then Obj (Find(0)); while Var(1)=',' do Scan(); Obj (Find(0)); end end Scan(); // is Func(); Hide(); end if Ch!='(' then Var(0); end Scan(); end Emi3 (5,nCode); Func (); close(); Code [2]:=mod (nCode-4, 256); Code [3]:=div (nCode-4, 256); //FName[2]:=char(byte('C')+0x80); //FName[3]:=char(byte('O')+0x80); //FName[4]:=char(byte('M')+0x80); //create(); //rewind(); //write (); //close (); putc (char(13)); putc ('+'); putn (nCode-4); X:=0; end


Сайт создан в системе uCoz