Program   C64;
{$M $2000,0,$A0000}
{ ------------------------------------------------------------------------- }
Uses      Crt, Dos, Xdos, Strings, Types, Bios;
{ ------------------------------------------------------------------------- }
Const     Program_Name      = 'Sally Commodore 64 Emulator';
          Program_Version   = '0,20';
          Program_Copyright = 'Copyright 1992 by Sally I/S';
          Patcherom         = True;
          Debug             : Boolean = False;
          AutorunFileName   = 'AutoRun';
          Defaultpath       = 'Programs';
{ ------------------------------------------------------------------------- }
Type      Emulate_Proc      = Procedure(Arom,Drom,Erom,Ram,Swap,Layout: Word);
          Cpuneed_Func      = Function(Actual: Word): Word;
          Videoneed_Func    = Function(Actual: Word): Word;
{ ------------------------------------------------------------------------- }
Var       AromPtr   : ByteArrayPtr;
          DromPtr   : ByteArrayPtr;
          EromPtr   : ByteArrayPtr;
          RamPtr    : ByteArrayPtr;
          SwapPtr   : ByteArrayPtr;
          LayoutPtr : ByteArrayPtr;
          Old08     : Pointer;
          Old09     : Pointer;
          Old80     : Pointer;
          OldExit   : Pointer;
          Emulator  : Emulate_Proc;
          Cpuneed   : Cpuneed_Func;
          Videoneed : Videoneed_Func;
          Cpu       : Word;
          Video     : Word;
          Autokeys  : String;
{ ------------------------------------------------------------------------- }
Procedure Getmem64(Var P2{: Pointer}; Size: LongInt);
Var       Dummy : Pointer;
          P     : Pointer Absolute P2;
Begin
  If Size>MaxAvail Then Begin
    Writeln('Out of memory allocating buffers.');
    Halt(1);
  End;
  If Size=$10000 Then Begin
    GetMem(P,$FFF0);
    GetMem(Dummy,$0010);
  End Else Begin
    GetMem(P,Size);
    Dummy:=Ptr(Seg(P^)+$FFF,0);
  End;
  If (Ofs(P^)<>0) Or (Ofs(Dummy^)<>0) Or (Seg(P^)+$FFF<>Seg(Dummy^)) Then Begin
    Writeln('Allocation of buffers failed.');
    Halt(1);
  End;
End;
{ ------------------------------------------------------------------------- }
Procedure FindFile(Var Name: String; Var Size,Offset: LongInt);
Var       Fil        : File;
          Hs,Is,Rs,P : LongInt;
          Name2      : String;
          Identifier : LongInt;
Begin
  Xdos_SplitExeSize(ParamStr(0),Hs,Is,Rs);
  Offset:=-1;
  If Rs>0 Then Begin
    Xdos_ResetFile(Fil,ParamStr(0),'r',1);
    P:=Hs+Is;
    Seek(Fil,P);
    BlockRead(Fil,Identifier,SizeOf(Identifier));
    If Identifier=$31108825 Then Begin
      Inc(P,SizeOf(Identifier));
      Dec(Rs,SizeOf(Identifier));
      While Rs>0 Do Begin
        Seek(Fil,P);
        BlockRead(Fil,Name2,1);
        BlockRead(Fil,Name2[1],Byte(Name2[0]));
        BlockRead(Fil,Size,SizeOf(Size));
        P:=FilePos(Fil);
        If Upper(Name2)=Upper(Name) Then Begin
          Rs:=-1;
          Offset:=P;
          Name:=ParamStr(0);
        End Else Begin
          Inc(P,Size);
          Dec(Rs,Size+1+Length(Name2)+SizeOf(Size));
        End;
      End;
    End;
    Close(Fil);
  End;
  If Offset=-1 Then Begin
    Xdos_ResetFile(Fil,Xdos_Pathof(ParamStr(0))+Name,'r',1);
    If IOResult<>0 Then
      Xdos_ResetFile(Fil,Xdos_Pathof(ParamStr(0))+Defaultpath+'\'+Name,'r',1);
    If IOResult=0 Then Begin
      Offset:=0;
      Size:=FileSize(Fil);
      Close(Fil);
      Name:=Assigned_Name(Fil);
    End;
  End;
End;
{ ------------------------------------------------------------------------- }
Procedure Cleanup; Far;

  Procedure Resettime;
  Var       Cmos : Array[$00..$3F] Of Byte;
            I,B  : Byte;
  Begin
    For I:=0 To $3F Do Begin
      Port[$70]:=I;
      B:=Port[$71];
      Cmos[I]:=(B Shr 4)*10+(B And 15);
    End;
    SetTime(Cmos[4],Cmos[2],Cmos[0],0);
    SetDate(Cmos[9]+1900,Cmos[8],Cmos[7]);
  End;

Begin
  ExitProc:=OldExit;
  SetIntVec($08,Old08);
  SetIntVec($09,Old09);
  SetIntVec($80,Old80);
  If Cpu>=2 Then Resettime;
  Port[$43]:=$36;
  Port[$40]:=$FF;
  Port[$40]:=$FF;
  If ExitCode=$FF Then TextMode(LastMode);
End;
{ ------------------------------------------------------------------------- }
Function GetFileName: String;
Var      Name    : String;
         S,A     : Word;
         L,P     : Byte;
         Allowed : Set Of Char;
Begin
  L:=RamPtr^[$00B7];
  A:=RamPtr^[$00BB]+RamPtr^[$00BC] Shl 8;
  Move(RamPtr^[A],Name[1],L);
  Name[0]:=Char(L);
  If Pos(',',Name)=0 Then Name:=Name+',p';
  P:=Pos(',',Name);
  If P>17 Then Begin
    Name:=Copy(Name,1,16)+Copy(Name,P,2);
    P:=17;
  End;
  Name[0]:=Char(P+1);
  While Name[P-1]=#160 Do Begin
    Delete(Name,P-1,1);
    Dec(P);
  End;
  If Name[2]=':' Then Begin
    Delete(Name,1,2); { "0:" }
    Dec(P,2);
  End;
  If Name[1]='$' Then
    Allowed:=['a'..'z','A'..'Z','0'..'9','-','(',')','$','*','?']
  Else
    Allowed:=['a'..'z','A'..'Z','0'..'9','-','(',')'];
  For L:=1 To P-1 Do
    If Not (Name[L] In Allowed) Then
      Name[L]:='-';
  GetFileName:=Copy(Name,1,P-1)+'.64'+Name[P+1];
End;
{ ------------------------------------------------------------------------- }
{$R-}
Function LoadFile: Boolean;
Var      Name    : String;
         Fil     : File;
         Start   : Word;
         Size    : LongInt;
         Offset  : LongInt;

  Procedure Loaddir(Mask: PathStr);
  Var       Start : Word;
            Path  : String;
            Rec   : SearchRec;
            L     : LongInt;
            Dir   : DirStr;
            Name  : NameStr;
            Ext   : ExtStr;

    Procedure Put(S: String);
    Var       I : Integer;
    Begin
      For I:=1 To Length(S) Do Begin
        RamPtr^[Start]:=Byte(S[I]);
        Inc(Start);
      End;
    End;

  Begin
    Path:=Xdos_Pathof(ParamStr(0));
    If Mask='' Then Mask:='*';
    Get_Dir(Path+Mask+'.64*',True,0);
    If RamPtr^[$00B9]=0 Then
      Start:=RamPtr^[$00C3]+RamPtr^[$00C4] Shl 8
    Else
      Start:=$0401;
    Put(#4#4+#0#0+#18'"'+Left(Replace(Path,'\','/'),16)+'" 00 2A'+#0);
    While Files_Count>0 Do Begin
      Get_File(Rec,Path);
      FSplit(Rec.Name,Dir,Name,Ext);
      Case UpCase(Ext[4]) Of
        'L' : Ext:='REL';
        'P' : Ext:='PRG';
        'S' : Ext:='SEQ';
        'U' : Ext:='USR';
        'D' : Ext:='DSK'; { Not standard }
      Else    Delete(Ext,1,1);
      End;
      L:=(Rec.Size+253) Div 254;
      Put(#4#4+Char(Lo(L))+Char(Hi(L))+Spaces(4-Length(Int2Str(L)))+
          Left('"'+Copy(Name,1,16)+'"',19)+Ext+'   '#0);
    End;
    L:=DiskFree(Ord(Path[1])-Ord('A')+1) Div 254;
    If L>$FFFF Then L:=$FFFF;
    Put(#4#4+Char(Lo(L))+Char(Hi(L))+'BLOCKS FREE.'#0);
    Put(#0#0);
    RamPtr^[$0090]:=0;
    RamPtr^[$00AE]:=Lo(Start);
    RamPtr^[$00AF]:=Hi(Start);
  End;

Begin
  Name:=GetFileName;
  FindFile(Name,Size,Offset);
  If (Offset>=0) And (Size>=SizeOf(Start)) Then Begin
    Dec(Size,SizeOf(Start));
    Xdos_ResetFile(Fil,Name,'r',1);
    Seek(Fil,Offset);
    BlockRead(Fil,Start,SizeOf(Start));
    If RamPtr^[$00B9]=0 Then
      Start:=RamPtr^[$00C3]+RamPtr^[$00C4] Shl 8;
    BlockRead(Fil,RamPtr^[Start],Size);
    Close(Fil);
    Inc(Start,Size);
    RamPtr^[$0090]:=0;
    RamPtr^[$00AE]:=Lo(Start);
    RamPtr^[$00AF]:=Hi(Start);
    LoadFile:=True;
  End Else Begin
    If Name[1]='$' Then Begin
      Loaddir(Copy(Name,2,Length(Name)-5));
      LoadFile:=True;
    End Else
      LoadFile:=False;
  End;
End;

Procedure SaveFile;
Var      Name  : String;
         Fil   : File;
         Start : Word;
         Size  : Word;
Begin
  Name:=GetFileName;
  Xdos_RewriteFile(Fil,Xdos_Pathof(ParamStr(0))+Defaultpath+'\'+Name,1);
  If IOResult=0 Then Begin
    Start:=RamPtr^[$00C1]+RamPtr^[$00C2] Shl 8;
    Size:=RamPtr^[$00AE]+RamPtr^[$00AF] Shl 8-Start;
    BlockWrite(Fil,Start,SizeOf(Start));
    BlockWrite(Fil,RamPtr^[Start],Size);
    Close(Fil);
  End Else
    Writeln('Save error!');
End;
{ ------------------------------------------------------------------------- }
Procedure Int80(Flags,Cs,Ip,Ax,Bx,Cx,Dx,Si,Di,Ds,Es,Bp: Word); Interrupt;
Var       Save09   : Pointer;
          save8086 : byte;

  Procedure Outregs;
  Begin
    Writeln('Pc=',Int2HexN(Si,4),':',Int2HexN(Byte(Pointer(LongInt(RamPtr)+Si)^),2),
      '  A=',Int2HexN(Hi(Cx),2),
      '  X=',Int2HexN(Lo(Dx),2),
      '  Y=',Int2HexN(Hi(Dx),2),
      '  ',Choose('\n\N',Lo(Di) Shr 7 And 1+1),
           Choose('\v\V',Lo(Di) Shr 6 And 1+1),
           Choose('\-\+',Lo(Di) Shr 5 And 1+1),
           Choose('\b\B',Lo(Di) Shr 4 And 1+1),
           Choose('\d\D',Lo(Di) Shr 3 And 1+1),
           Choose('\i\I',Lo(Di) Shr 2 And 1+1),
           Choose('\z\Z',Lo(Di) Shr 1 And 1+1),
           Choose('\c\C',Lo(Di) Shr 0 And 1+1));
  End;

  Procedure Outinstruct;
  Var       Inst : String;
            P    : Word;

    Function Get: String;
    Begin
      Get:=Int2HexN(RamPtr^[P],2);
      Inc(P);
    End;

  Begin
    P:=Si+1;
    Inst:=String(Ptr(Cs,Bp-$10)^);
    Case Length(Inst) Of
      3 : Case Inst[1] Of
            'J',
            'S',
            'L' : Begin
                    Insert(' $'+Get,Inst,4);
                    Insert(Get,Inst,6);
                  End;
          End;
      5 : Case Inst[5] Of
            '#' : Insert('$'+Get,Inst,6);
            'z' : Begin
                    Dec(Inst[0]);
                    Insert('$'+Get,Inst,5);
                  End;
            'r' : Begin
                    Dec(Inst[0]);
                    Insert('$'+Int2HexN(ShortInt(RamPtr^[P])+P+1,4),Inst,5);
                  End;
            'X',
            'Y' : Begin
                    Insert('$'+Get+',',Inst,5);
                    Insert(Get,Inst,6);
                  End;
          End;
      7 : Case Inst[5] Of
            'z' : Begin
                    Delete(Inst,5,1);
                    Insert('$'+Get,Inst,5);
                  End;
          End;
      9 : Begin
            Delete(Inst,6,1);
            Insert('$'+Get,Inst,6);
          End;
    End;
    Writeln(Int2HexN(Si,4),':',
      Left(Inst,11),
      ' A=',Int2HexN(Hi(Cx),2),
      ' X=',Int2HexN(Lo(Dx),2),
      ' Y=',Int2HexN(Hi(Dx),2),
      ' ',Choose('\n\N',Lo(Di) Shr 7 And 1+1),
          Choose('\v\V',Lo(Di) Shr 6 And 1+1),
          Choose('\-\+',Lo(Di) Shr 5 And 1+1),
          Choose('\b\B',Lo(Di) Shr 4 And 1+1),
          Choose('\d\D',Lo(Di) Shr 3 And 1+1),
          Choose('\i\I',Lo(Di) Shr 2 And 1+1),
          Choose('\z\Z',Lo(Di) Shr 1 And 1+1),
          Choose('\c\C',Lo(Di) Shr 0 And 1+1));
    While Shift_Status And Bios_Shift=0 Do ;
  End;

  Procedure Text_Snapshot;
  Var       Src1 : ^Byte;
            Src2 : ^Byte;
            Dst  : ^Word;
            X,Y  : Byte;
  Begin
    Src1:=Pointer(LongInt(RamPtr)+$0400);
    Src2:=Pointer(LongInt(RamPtr)+$D800);
    Dst:=Ptr($B800,40*2);
    For Y:=0 To 24 Do Begin
      For X:=0 To 39 Do Begin
        Dst^:=Src2^ Shl 8 Or Src1^;
        Inc(Src1);
        Inc(Src2);
        Inc(Dst);
      End;
      Inc(Dst,40);
    End;
  End;

Begin
  save8086:=test8086;
  test8086:=0;
  Asm Sti End;
  Case Lo(Ax) Of
    $00 : Begin
            Writeln('Illegal instruction:');
            Outregs;
            Halt(1);
          End;
    $01 : Begin
            Outregs;
          End;
    $02 : Begin
            GotoXY(1,5);
            Outregs;
          End;
    $03 : Begin
            Writeln('Unsupported video mode');
            Halt(1);
          End;
    $04 : Begin
            Writeln('Sanity check failed.');
            Outregs;
            Halt(1);
          End;
    $05 : If Debug Then Begin
            GetIntVec($09,Save09);
            SetIntVec($09,Old09);
            Outinstruct;
            SetIntVec($09,Save09);
          End;
    $06 : If Debug Then Begin
            Writeln('':20,Int2HexN(Lo(Bx),2),
                    '-->',Int2HexN(Di,4),
                    '  (',Int2HexN(LayoutPtr^[Di],2),')','':5);
          End;
    $08 : Begin
            GotoXY(1,1);
            Writeln('Processor in shutdown-mode -- resetting!');
            Delay(1000);
          End;
    $10 : Begin
            If LoadFile Then
              Flags:=Flags And Not fCarry
            Else
              Flags:=Flags Or fCarry;
          End;
    $11 : SaveFile;
    $12 : Begin
            Cx:=Lo(Cx)+Byte(Autokeys[1]) Shl 8;
            Delete(Autokeys,1,1);
            If Autokeys='' Then Begin
              EromPtr^[$FFCF-$E000]:=$6C;
              RamPtr^[$FFCF]:=$6C;
            End;
          End;
  End;
  test8086:=save8086;
End;
{$R+}
{ ------------------------------------------------------------------------- }
Procedure Initialize;

  Procedure Initmemory;
  Var       Name    : String;
            Fil     : File;
            Size    : LongInt;
            Offset  : LongInt;
            Emu     : Pointer;
            Theend  : Word;

  Procedure Readrom(Name: String; P: Pointer; ExpSize: Word);
  Var       Fil    : File;
            Size   : LongInt;
            Offset : LongInt;
  Begin
    Name:=Name+'.64p';
    FindFile(Name,Size,Offset);
    If (Offset<0) Or ((Size<>ExpSize) And (Size<>ExpSize+2)) Then Begin
      Writeln('Bad or missing ',Name);
      Halt(1);
    End;
    Xdos_ResetFile(Fil,Name,'r',1);
    Seek(Fil,Offset+(Size-ExpSize));
    BlockRead(Fil,P^,ExpSize);
    Close(Fil);
    If IOResult<>0 Then Begin
      Writeln('Error read Rom image from ',Name);
      Halt(1);
    End;
  End;

  Begin
    Name:='Emulate.Bin';
    FindFile(Name,Size,Offset);
    If (Offset<0) Or (Size>=$FFF0) Then Begin
      Writeln('Bad or missing ',Name);
      Halt(1);
    End;
    Xdos_ResetFile(Fil,Name,'r',1);
    Seek(Fil,Offset);
    BlockRead(Fil,Theend,SizeOf(Theend));
    Getmem64(Emu,(Theend+$F) And Not $F);
    Seek(Fil,Offset);
    BlockRead(Fil,Emu^,Size);
    Close(Fil);
    LongInt(@Emulator):=LongInt(Emu)+2;
    LongInt(@Cpuneed):=LongInt(Emu)+5;
    LongInt(@Videoneed):=LongInt(Emu)+8;

    Getmem64(AromPtr,$2000);      { Basic Rom             }
    Getmem64(DromPtr,$1000);      { Charater set Rom      }
    Getmem64(EromPtr,$2000);      { Kernal Rom            }
    Getmem64(RamPtr,$10000);      { Ram                   }
    Getmem64(SwapPtr,$B000);      { Swap space            }
    Getmem64(LayoutPtr,$10000);   { $0001-trick           }

    Readrom('A000BFFF',AromPtr,$2000);
    Readrom('D000DFFF',DromPtr,$1000);
    Readrom('E000FFFF',EromPtr,$2000);

    If Patcherom Then Begin
      EromPtr^[$F4C4-$E000]:=$02;
      EromPtr^[$F605-$E000]:=$02;
      If Autokeys<>'' Then
        EromPtr^[$FFCF-$E000]:=$02;
    End;
  End;

  Procedure Checkscreen;
  Const     Types   = '\monochrome\cga\\ega colour\ega mono\pga\vga mono'+
                      '\vga colour\\system 30\system 30 mono\system 30 colour';
  Var       Nv,I    : Word;
  Begin
    Video:=Bios_ScreenType;
    Nv:=Videoneed(Video);
    If (Nv And (1 Shl Video))=0 Then Begin
      Writeln('This emulator needs one of the following video systems:');
      For I:=1 To 15 Do
        If (Nv And (1 Shl I))<>0 Then
          Writeln('    - ',FUpper(Choose(Types,I)));
      Writeln;
      Writeln('Your video system is ',Choose(Types,Video),'.');
      writeln('Program execution aborted due to insufficient hardware.');
      Halt(1);
    End;
  End;

  Procedure Checkcpu;
  Var       Nc : Word;
  Begin
    Cpu:=Bios_Cpu;
    Nc:=Cpuneed(Cpu);
    If Nc>Cpu Then Begin
      Writeln('The emulator needs at least a 80',Int2Str0(Nc),'86 processor; ',
              'you only have a 80',Int2Str0(Cpu),'86 processor.');
      writeln('Program execution aborted due to insufficient hardware.');
      Halt(1);
    End;
  End;

  Procedure Autoload;
  Var       Name   : String;
            Size   : LongInt;
            Offset : LongInt;
  Begin
    Autokeys:=ParamStr(1);
    If Autokeys='' Then Begin
      Name:=AutorunFileName+'.64p';
      FindFile(Name,Size,Offset);
      If Offset<>-1 Then Autokeys:=AutorunFileName;
    End;
    If Autokeys<>'' Then
      Autokeys:=Upper('poke646,6:load"'+Autokeys+'",8,1'#13+
                      'sys58692:ifpeek(45)+256*peek(46)=2051then?"'#154'Load error.'#31#13+
                      'poke646,14:ifpeek(45)+256*peek(46)>2051thenrun'#13);
  End;

Begin
  GetIntVec($08,Old08);
  GetIntVec($09,Old09);
  GetIntVec($80,Old80);
  OldExit:=ExitProc;
  ExitProc:=@Cleanup;

  Autoload;
  Initmemory;
  Checkcpu;
  Checkscreen;
  SetIntVec($80,@Int80);
End;
{ ------------------------------------------------------------------------- }
Procedure Prolog;
Begin
  ClrScr;
  Writeln(Program_Name,' version ',Program_Version);
  Writeln(Program_Copyright);
  Writeln;
End;
{ ------------------------------------------------------------------------- }
Procedure Epilog;
Begin
  TextMode(LastMode);
  Prolog;
  Writeln('Program terminated normally.');
End;
{ ------------------------------------------------------------------------- }
Procedure Go;
Begin
  Emulator(Seg(AromPtr^),Seg(DromPtr^),Seg(EromPtr^),
           Seg(RamPtr^),Seg(SwapPtr^),Seg(LayoutPtr^));
End;
{ ------------------------------------------------------------------------- }
Begin
  DirectVideo:=False;
  Prolog;
  Initialize;
  Go;
  Epilog;
End.