ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/ASSEMBLY/V20BOOT.ZIP/V20BOOT.PAS

Pascal/Delphi Source File | 1990-04-30 | 47.3 KB | 1,586 lines

(* Copyright 1990 by Clarence Wilkerson. All rights reserved *)


(* This emulator has reached the endpoint of its evolution, and
   I've decided to make it available to the public in source
   code form. There are other shareware or public domain emulators,
   but none that I know of with source code. One interesting
   feature is that it is almost entirely in Turbo Pascal.
     I have not included because of its length the CCP
   assembly language code. I had at one time plans to emulate
   this in Turbo Pascal.
*)

{ Things left to do
    1) IOBYTE                     ok
    2) ENHANCED CCP   by offloading functions to turbo nope
    3) TERMINAL EMULATION         ok  H19, check nansi code
    4) SOFTWARE EMULATION for Z80 nope
       and support for z80 boards nope
    5) Emulate the FCB's better   ok
    6) bootup configuration file  ok
    7) allow cp/m 3.0 emulation   nope
}

program v20boot;
uses crt,dos,printer;
  (*
   This is an CP/M 2.2 emulation program using the NEC
    v20 8080 emulation mode.

    Turbo Pascal 4.0-5.5 revised edition . The major design aim was to
    do this almost exclusively in Turbo Pascal rather than assembler.

Structure of the source:

  1) V20BOOT.PAS  TP 4.0-5.5 pascal source with 99.9% of 8088 code
  2) GOTOCPM.ASM  MASM source file for routine to enter V20 8080 emulation
     mode.
  3) V20BDOS.ASM  ASM80 source for stub BDOS and BIOS in 8080 code
  3) Not included because of size  V20CCP.ASM  minor changes to ZCPR v.2
     , stripping user code and submit cpability

Binary files included:
  1) V20BOOT.EXE  complete compiled version
  2) MEDLEY.ARC   set of public domain CP/M programs.. LASM, MLOAD
     DISK76, SD useful for rebuilding and testing
  3) V20BDOS.OBJ  linkable form of 8080 code V20bdos
  3) V20CCP.OBJ   " ""                       V20CCP
  4) GOTOCPM.OBJ  "  "  of help routine, gotocpm used as external routine
     in Pascal source.

Description:
General Theory:

   The V20-30 series contains an 8080 emulation mode. The mode is entered
   by executing a "BRKEM XXX", where XXX is a software interrupt between
   0 and $ff. Many of these interrupts on a pc are reserved for other
   functions. You may have to poke around on your fully configured system
   to find a set of 4 consecutive interrupts to be used by this program.
   I use $C0-> C4 as the default. This is changeable in the INITV20.CPM
   file.

      The interrupt points to a segment:offset, and the 8080 code begins
   executing at that point. The registers for the emulation have the
   obvious matches to the 8088 registers, except that 8080 sp = 8086 bp.
   Also, you must set the 8080 data segment in ds before you enter the
   BRKEM.

       The 8080 emulation mode has calls to execute 8088 code, via
   interrupt calls, and to return from emulation mode permanently.
   I have implemented most of the BDOS-BIOS emulation in Turbo Pascal, with
   access from the 8080 code via these interrupt calls.


   In short, this programs allocates a 8080 code segment, sets up bdos and
   bios stubs in it, and then enters emulation mode. The CCP used is a
   slightly modified ZCPR, so the look and feel is aprroximately that
   of a stock CP/M 2.2 system.

   The program goes to some trouble to emulate CP/M bdos calls exactly, as
   well as the console - printer oriented bios calls. One can write a
   fairly short emulator if the exactitude of bdos calls is ignored, and
  it might suffice for some purposes.
       However, there is a difference in the File
   control blocks for CP/M versus MSDOS, and several CP/M calls have no
   exact MSDOS analogue. For example, few of the first generation emulators
   will run the directory programs SD or DISK76. Often, however, assemblers
   and compilers will run under the direct translation method. On the other
   hand, this program will not run the WordStar Install program correctly,
   since it apparently tries to implement random disk access by manipulating
   reserved fields in the FCB.

   All BDOS functions are supported, including getalloc and get DPB,
   ( this was important for using SD and DISK76 ).
   Not many of the bios functions are supported, espcially the disk oriented
   ones. The main thing this  loses for you is the direct ability to use
   CP/M diskettes, and to use DU, the disk zapper. I made up for the loss
   of CP/M disks with my READCPM utility, also written in Turbo Pascal.
   The DU loss is tougher --DU is very handy and semi-programmable.
   I find Norton's Utilities as a poor replacement in some aspects.

       It wouldn't take that much effort to merge my READCPM and this code,
   but that's another project.

   One limitation is that this  V20 emulation mode does not run z-80 code.
   However, this Turbo program is written  so that only a few changes
   would be required to support a memory mapped Z80 card or software 8080
   or z80 emulation. Joan Riff's Z80MU  exists already, however.

   CP/M features missing stem from my hacking which  eliminated from ZCPR
   CCP user numbers and support for SUBMIT.
   To make up for this lack of support for SUBMIT, the standard console
   functions from bdos and bios are left in place so that cp/m utilities
   such as EX can be used.

   Furthermore, the IOBYTE feature is implemented, and one can add new
   physical devices to supplement the ones included ( raw io and H19
   emulation ).

*)

const
  ESC = #27;
  CARRYFLAG = $01;
  WHICHCOMM     : byte = $01;   { USE COMM1 }
  DEFAULTIOBYTE : byte = $81;  { CRTT, LPTT }
  BDOSSIZE :word = $600; {12 cp/m sectors} { size of disk file in cp/m sectors }
  CCPSIZE  :word = $800; {16 cp/m sectors}
  NUMALLOCBYTES  = $100;  {bytes in 8080 bdos for bit map of allocation }
  escinflag: boolean=false;
  escoutflag: boolean=false;
  escstr: string[64] ='';

  { 8088 interrupts used }
  { should make this configurable }

  baseinterrupt : byte = $c0;
  coldb      = $0;     { plus baseinterrupt starting point }
  ccphandle  = $1;
  bdoshandle = $2;
  bioshandle = $3;   { these handles are indices into table of addresses }


 { special V-20 instructions }

  CALLN =   $eded;  { used from 8080 mode not reversed byte order  }
  RETEM =   $edfd;  { used from 8080 mode stored in mem as ed,fd }
  BKREM =   $0fff;  { used from 8086 mode }
  RETI  =   $CF;    { used from 8086 mode }


{ cpm-80 constants }

{ i/o byte masks }
   consolemask = $03;
   consoleshift= $0;
   readermask  = $0c;
   readershift = $2;
   punchmask   = $30;
   punchshift  = $4;
   listmask    = $c0;
   listshift   = $6;

{ possible console values  SHR 0 }

   TTY     =  0;
   CRTT    =  1;  (* CRT conflict with DOS unit in TP 4.0 *)
   BAT     =  2;
   UC1     =  3;

{ possible reader values SHR 2 }
{  TTY     =  0; }
   RDR0    =  1;
   UR1     =  2;
   UR2     =  3;

{ possible punch values  SHR 4 }
{  TTY     =  0 }
   PUN     =  1;
   UP1     =  2;
   UP2     =  3;

{ possible list values  SHR 6 }
{  TTY     =  0; }
{  CRT     =  1; }
   LPTT    =  2;
   UL1     =  3;     { output to a file }


{ offsets in CPM-80 code segment }

   ccpaddr : word =  $f200;
   bdosaddr :word =  $fa00;
   biosaddr :word =  $ff00;

   bdosdpb  =  $9;  {  + bdosaddr }
   bdosalloc=  $19; {  + bdosaddr }
   jmp     =   $c3;
   jmpwarm =   $0;
   jmpbdos =   $5;
   kfcb1   =   $80;
   kfcb2   =   $5c;
   cpmstack   =   $ff80;  (* default value *)
   cpmoutname: string[64] ='V20OUT.LST';   { list output to a file }
   cpm80     : word = 0;

type
  segment = array[0..$7ff0] of word;
  filler  = array[0..$1000] of word;

  reg8080 = record case integer of
              1:  (a,x,l,h,c,b,e,d  : byte); { 8080 mode }
              2:  (achr,u,lchr,hchr,cchr,bchr,echr,dchr: char);
              3:  (psw,hl,bc,de : word);  { word mode }
            end;
  reg8080ptr = ^reg8080;
  interruptrec  = record
                   loc     : byte;
                   offset  : word;
                   segment : word;
            end;

  regpakptr =^registers;
{ cp/m and dos types }
    fcbname = array[0..11] of char;
    nstring = string[64];
    anystring = string[255];

    dpbblk = record case integer of
        1: (spt : word;
            bsh : byte;
            blm : byte;
            exm : byte;
            dsm : word;
            drm : word;
            al01 : word;
            cks  : word;
            off  : word;
            );
        2: (dpb : array[1..15] of byte);
     end;

    allocblk = record case integer of
                 1: ( allshort: array[1..16] of byte);
                 2: ( alllong: array[1..8] of word);
                end;

    cpmfcb = record case integer of

        1: (  drive: byte;
              name : array[1..11] of char; { 1..11 }
              curext : byte;  { 12 }
              rs12   : word;     { 13..14 }
              recused : byte;       { 15 }
              ablk : allocblk;      { 15..31 }
              currec : byte;        { 32 }
              randrec: word;     { 33..34 }
              overflow: byte        { 35 }      );
       2:  (fcb : array[0..35] of byte);
      end;

     dosfcb =   record case integer of
        1: (  drive: byte; { 0 for default before opening, then A=1,..etc }
              name : array[1..11] of char; { 8 + 3, spaces to fill both pieces}
              curext :  word;
              recsize : word;  { set to 80 hex on opening }
              filesize: array[1..4] of byte;
              date : word;
              time : word;
              reserved : array[24..31] of byte;
              currec : byte;
              randrec: array[1..2] of word);
              { user should set to 0 normally }
        2:  (fcb : array[0..36] of byte);
        3:  ( cpmseqfcb: array[0..32] of byte;
              fillit : array[33..36] of byte) { for sequential records };
        4:  (cpmrandfcb: array[0..35] of byte;
             myextra : byte  { for random access });
      end;

  dosdir = record   case integer of
         1: (  dskflg : byte;
               name   : array[1..8] of char;
               ext    : array[1..3] of char;
               attr  :  byte;
               rsvrd :  array[1..10] of byte;
               time  :  word;
               date  :  word;
               strtcluster : word;
               size  :  array[1..4] of byte);
        2:  ( cpmdir :  array[0..31] of byte);
      end;

      fname = array[1..11] of char;
      alloc = array[0.. NUMALLOCBYTES] of byte;



    { replace absolute variables in the 8080 address space by pointers }
var    myseg : word;
       mystack : word;
       myinterrupt : word;
       oldinterrupt  : array[0..3] of interruptrec;
       newinterrupt  : array[0..3] of interruptrec;
       cursX, cursY : byte; { h-19 emulation }
       bioschar  : ^char;
       bioswhich,biosbyte : ^byte;
       cpmseg    : ^segment;
       extra     : ^filler;
       biosreg   : reg8080ptr ;
       bdosreg   : reg8080ptr ;
       ccpregs   : reg8080ptr ;
       user      : ^byte ;    { cpm80:4;}
       iobyte    : ^byte ;    { cpm80:3;}
       abortflag : ^byte ;    { cpm80:$ffff;}  { put <> 0 to abort }
       zero      : ^byte ;    { cpm80:0; }

       { misc. variables }

       lastdma  :  word;
       ccpfile  :  file;
       bdosfile :  file;
       cpmout   :  text; { for output to disk file from list }
       initf    :  text; { set cp/m parameters }
       z        : registers;
       myownfcb : dosfcb;
       listouthandle : word;

procedure v20ccp ; external ;
{$L v20ccp.obj}
{ 8080 code stored in "v20ccp.obj" }
{ contains 8080 code ccp extracted from zcpr 2.0 }
{ with user numbers removed, and SUBMIT file removed }
{ Fancier versions could pass most functions off to Turbo routines }
{ such as assigning  MSDOS paths for user numbers or drives }
{ changing directories }

procedure v20bdos ; external ;
{$L v20bdos.obj}
{ 8080 code stored in "v20bdos.obj" }
{ has cp/m 2.2 console handlers, passes rest off to routines here to }
{ imitate with msdos functions}
{ Bios is only a stub, handles character routines only, others when }
{ graceful imitation is possible}
{ fancier version could add cp/m disk imitation for a floppy}
{ but not necessary given my read cp/m }



function getcurrent : byte;
var u : registers;
begin
   u.ah:=$19;
   msdos(u);
   getcurrent:=u.al and $0f;
end; { getcurrent }

procedure resetdisk;
var u : registers;
begin
   u.ah:=$0d;
   msdos(u);
   user^:=2;
end; { resetdisk }


procedure setjumps;
var u : registers;
    s : ^fname;
    j : integer;
    temp: byte;
begin
   temp:=iobyte^;
   { now intialize lowest page of memory in the cpm80 seg }
   fillchar(zero^,$ff,0);
   iobyte^:=temp;
   abortflag^:=0; { special }
   mem[cpm80:0] :=jmp;
   memw[cpm80:1]:=biosaddr+3;
   mem[cpm80:5] :=jmp;
   memw[cpm80:6]:=bdosaddr + 6; { skip serial number }
   user^:= getcurrent;
   { blank fcb's }
   s:=ptr(cpm80,$5d);
   for j:=1 to 11 do s^[j]:=' ';
   s:=ptr(cpm80,$6d);
   for j:=1 to 11 do s^[j]:=' ';
end; { set jumps }


procedure putnibble( x : byte);
begin
   x:=x and $0f;
   if x < 10 then write(chr($30+x)) else write(chr(55+x));
end;

procedure putbyte( x : byte );
begin
   x:=x and $ff;
   putnibble(x shr 4);
   putnibble(x);
end;

procedure putword( x : word);
begin
   putbyte(hi(x));
   putbyte(lo(x));
end;

procedure putinteger( x : integer);
begin
   putbyte(hi(x));
   putbyte(lo(x));
end;

 procedure setinterrupt ( x : interruptrec);
 { set interrupt vector x to xseg:xofs }
 var   z : registers;
 begin
    z.ds:= x.segment;
    z.dx:= x.offset;
    z.ah:= $25;
    z.al:= x.loc;    { load ah with 25h , al with interrupt number}
    msdos(z);
 end; { setinterrupt }

 procedure getinterrupt ( var x : interruptrec);
 { get interrupt vector x into xseg,xofs }
 var   z : registers;
 begin
     z.ah:= $35;
     z.al:= x.loc;
     msdos(z);
     x.segment:=z.es;
     x.offset  :=z.bx;
 end; { getinterrupt }

procedure setdefdma;
var z :registers;
  begin
     z.ds:=cpm80;
     z.dx:=$80;
     z.ah:=$1a;    { set default dma while we're at it }
     msdos(z);
  end; { setdefdma }

procedure loadbdos;
var u : ^byte;
    bbbb : ^byte;
begin
   u   :=ptr(cpm80,bdosaddr);
   bbbb:=@v20bdos;
   move(bbbb^,u^,BDOSSIZE);
end; { load bdos }


procedure loadccp;
var  u    : ^byte;
     cccc : ^byte;
begin
   u:= ptr(cpm80,ccpaddr);
   cccc:=@v20ccp;
   move(cccc^,u^,CCPSIZE);
end; { move ccp }

procedure warmboot( var x : registers);
var  u : registers;
begin  { reload ccp and reset dma to $80 }
    loadccp;
    resetdisk;
    setdefdma; { stack and DMA }
    lastdma:=$80;
    setjumps;  { clean up 0 to $ff to ffh in  cpm80 seg }
    x.bx:=ccpaddr + 3;
end; { warmboot }

procedure notimplemented;
var  ch : char;
begin
   write(#7,#7,'Warning! Bios call ');
   putbyte(biosreg^.a);
   writeln('H not implemented.');
   writeln;
   write('Resume 8080 program or abort? <R, A>  '); ch:=readkey;
   write(ch);
   if not ( upcase(ch) = 'R') then abortflag^ := $ff else writeln;
end; { not implemented }

{ bios routines next }
{ cpm/80 sends parameters in c or bc, gets back in a and hl }

{ first are physical character output routines }

{ CRT device }

procedure CRTOUTPUT( x : byte);
var u : registers;
begin
  write(chr(x));
end; { crtoutput }

procedure CRTINPUT( var x : byte);
var ch: char;
begin
      ch:=readkey;
      x:=ord(ch);
end; { CRTINPUT }

procedure CRTSTATUS( var x : byte);
var u : registers;
begin
   if keypressed then x:=$ff else x:=0;
end; { CRTSTATUS }

{ TTY device }
{ use native TURBO routines }
{ emulates H-19 terminal codes }

var escqueue    : char;

procedure ttystatus( var x : byte);
begin
   if escinflag  then x:=$ff  { if have some in queue }
   else
    if keypressed then x:=$ff else x:=$0;
end; { ttystatus }


procedure longescape;
var x,y : byte;
begin
    { now take a look at longer escape sequences }
    case escstr[2] of

      { cursor positioning }
      'Y' : if length(escstr) >=4 then begin
               y:=ord(escstr[3]) - 31;
               x:=ord(escstr[4]) - 31;
               gotoxy(x,y);
               escstr:='';escoutflag:=false;
             end;

      { various setup codes not implemented }
       'x','y' :  if length(escstr) >=3 then begin
                      escstr:='';
                      escoutflag:=false;
                  end;
    end; { case }
  end; { long escape }

procedure processescape;  { try minor emulation of h-19}
var x,y,i,j : byte;
    notproc : boolean;
begin
   notproc:=false;
   case escstr[2] of
      'E' : clrscr;
      'M' : delLine;
      'L' : InsLine;
      'K' : ClrEol;
      'H' : gotoxy(1,1);
      'J' : { EOS }
           begin
               x:=whereX; y :=whereY; clreol;
               for j:=y +1 to 25 do begin
                  gotoxy(1,j);clreol;
               end;
               gotoxy(x,y);
            end;
      'p' : lowvideo;
      'q' : NormVideo;
      'l' : { erase entire line
              begin
                 delLine; InsLine;
              end;
      'N' : { delete char }  write(' ');
      'A' : { cursor up }
            begin
               x:=whereX; y:=whereY -1;  if y < 1 then x:=1;
               gotoxy(x,y);
             end;
      'B' : { cursor down }
             begin
               x:=whereX; y:=whereY +1;  if y > 25 then y:=25;
               gotoxy(x,y);
             end;
      'C' : { cursor right }
              begin
                x:=whereX +1; y:=whereY;  if x > 80 then x:=80;
                gotoxy(x,y);
             end;
      'D' : { cursor left }
             begin
               x:=whereX-1; y:=whereY;  if y < 1 then x:=1;
               gotoxy(x,y);
             end;
      'j' : { push cursor }
            begin
              cursX:=whereX;
              cursY:=whereY;
            end;
      'k' : { pop cursor }  gotoxy(cursX,cursY);
      'n' : begin
            end;
      '@' : begin end; { go to insert mode }
      'b' : begin  { erase beginning of display }
            x:=whereX;y:=whereY;
            for i:=1 to y-1 do begin
                gotoxy(1,i);
                clreol;
            end;
            gotoxy(1,y);
            for i:=1 to y do write(' ');
            gotoxy(x,y);
           end;

      'I' : { reverse index }
             begin
               x:=whereX; y:=whereY -1; if y < 1 then y:=1;
               gotoxy(x,y);
             end;
      'o' : begin    { erase beginning of line }
              x:=whereX;y:=whereY;
              gotoxy(1,y);
              for i:=1 to x do write(' ');
              gotoxy(x,y);
            end; { erase beginning of  line }
      'F','G','[','=','>','t','u','<','z','Z','#',']','}','{','v','w' : begin end;
      'Y','y','x' : begin notproc:=true; longescape; end;
  end; { case }
    if not notproc then begin
       escoutflag:=false;
       escstr:='';
       exit;
    end;

end; { processescape }

procedure ttyoutput( x : byte);
var s,y,yy : byte;
     j : integer;
begin
   if x=27 then begin   { start accumulating chars again }
      escoutflag:=true;
      escstr:= ''+ ESC;   { start over }
      exit;
   end;
   if not escoutflag then begin
       if x <> 9 then write(chr(x))  { expand tabs }
       else begin
          s:=WhereY;y:=WhereX; yy:=y;
          y:= 9 + 8*(y div 8);  if y > 80 then y:=80;
          (* do it with blanks *)
          for j:=yy to y do write(' ');
          gotoxy(y,s);
       end;
    end
   else begin
      { check for escape sequence abort }
      if x=30 then begin escoutflag:=false; escstr:='';exit;end;
      escstr:=escstr+chr(x);
      processescape;
   end;
end; { ttyoutput }

function translate( ch : char) : char;
{ translate turbo scan codes to H-19 codes }
begin
   case ch of
    #75,#115,#178 : translate:='D';
    #77,#116,#180 : translate:='C';
    #72,#160,#175 : translate:='A';
    #80,#164,#183 : translate:='B';
    #71,#174      : translate:='H';
    #59,#84,#94,#104 : translate:='S';   { function keys 1..5 }
    #60,#85,#95,#105 : translate:='T';
    #61,#86,#96,#106 : translate:='U';
    #62,#87,#97,#107 : translate:='V';
    #63,#88,#98,#108 : translate:='W';
    #66,#91,#101,#111: translate:='P';   { blue, grey, red }
    #67,#92,#102,#112: translate:='Q';
    #68,#93,#103,#113: translate:='R';
    else translate:=ch;
  end; { case }
end; { translate }


procedure ttyinput( var x : byte);
var ch: char;
begin
{ see if any in line already }
if escinflag then begin
      x:=ord(escqueue);
      escinflag:=false;
      exit;
  end;
 { else wait for a real character }
  ch:=readkey;
  x:=ord(ch); { return the character }
  if (ch = ESC) and keypressed then begin
     ch:=readkey;
     escinflag:=true;
     escqueue:= translate(ch);  { change on the fly }
  end;
end; { ttyinput }


{ user console 1 routines to allow external CRT on COMM1 }
{ use interrupt 14h }

procedure uc1status( var x : byte);
var u : registers;
begin
  u.ah:=3;
  u.dx:=WHICHCOMM;
  intr($14,u);
  { status now in u.ah }
  if (u.ah and $1) <> 0 then x:=$ff else x:=$0;
end; { uc1status }

procedure uc1input( var x : byte);
var u : registers;
begin
   repeat  uc1status(x) until x = $ff;
   u.ah:=2;
   u.dx:=whichcomm;
   intr($14,u);
   x:=u.al;
end; { uc1input }

procedure uc1output( x : byte);
var u : registers;
begin
  repeat
    u.ah:=3;
    u.dx:=whichcomm;
    intr($14,u);
  until u.ah and $40 <> 0;
  u.ah:=1;
  u.al:=x;
  u.dx:=whichcomm;
  intr($14,u);
end; { uc1output }


var nextlist : byte;
{ routed to a file, V20OUT.LST, presently }

procedure ul1output( x : byte);
var u : registers;
begin
  u.bx:=listouthandle;
  u.ds:=dseg;
  u.dx:=ofs(nextlist);  { a 1 byte buffer }
  nextlist:=x;
  u.cx:=1;
  u.ah:=$40;
  msdos(u);
  if u.flags and carryflag <> 0 then write(#7);
  if u.ax<> 1 then write('?');
end; { ul1output }


procedure breader( var x : byte);
var ch : char;
    u : registers;
begin
   case  (iobyte^ and readermask) shr readershift of
      TTY  :  begin ch:=readkey;  x:=ord(ch); end;
      RDR0 ,UR1, UR2:begin
           u.ah:=$03;
           msdos(u);
           x:=u.al;
          end;
  end; { case }
end;   { breader }

procedure bpunch( x : byte);
var  u : registers;
begin
  case (iobyte^ and punchmask) shr punchshift of
  TTY,PUN,UP1,UP2: begin
        u.ah:=$04;
        u.dl:=x;
        msdos(u);
      end;
  end;
end; { bpunch }

procedure blist( x : byte);
begin
  case (iobyte^ and listmask) shr listshift of
    TTY:  TTYOUTPUT(x);
    CRTT: crtoutput(x);
    LPTT:  write(lst,chr(x));
    UL1:  ul1output(x);
 end; { case }
end; { blist }

procedure blistst( var x : byte);
begin
    x:=$0ff;
end; { blistst }


procedure bconst( var x : byte);
begin
   case (iobyte^ and consolemask)  of
     TTY : TTYSTATUS(x);
     CRTT: CRTSTATUS(x);
     BAT : if keypressed then x:=$ff else x:=0;
     UC1 : uc1status(x);
   end; { case }
end;

procedure bconin( var x : byte);
var u : registers;
   ch : char;
begin   { bconin }
  case (iobyte^ and consolemask)  of
    CRTT: crtinput(x);
    TTY : ttyinput(x);
    BAT : breader(x) ;
    UC1 : uc1input(x);
 end; { case }
end; { bconin }

procedure bconout( x : byte);
begin
   case (iobyte^ and consolemask) of
     TTY  : ttyoutput(x);
     CRTT : crtoutput(x);
     BAT :  blist(x);
     UC1 :  uc1output(x);
   end;
end; { bconout }

procedure bseldsk( var x : registers);
var  z : registers;
begin
   z.ah:=$0e;
   z.dl:=x.cl;   { restored at end }
   msdos(z);
   x.bx:=0;      { no DPH for now }
end; { bseldsk }


procedure bsetdma(var x : registers);
var z : registers;
begin
   { do msdos STA }
   { DMA address in BC }
   z.ah:=$1a;
   z.dx:=x.cx;  { x.dx is restored at end ; }
   lastdma:=x.cx;
   msdos(z);
end; { bsetdma }

function bsectran( x : word) : word;
begin
   bsectran:=x;
end; { sectran }

var   x : registers;
var biostmp : byte;

{ next routine accessed only via CALLN BIOSHANDLE from 8080 mode }

procedure biosemul;
interrupt;  (* for turbo 4.0, try built in stuff *)
{ communicates via biosreg, a has call, bc data, returns in hl }
var x :registers;
begin
   (* writeln('Got to BIOS. call  ',biosreg^.a);   *)
   x.CX:=biosreg^.bc; { pass data on }
   x.ds:=cpm80;
case bioswhich^ of
    4:   (* bconout(x.cl);*)
            case (iobyte^ and consolemask) of
               CRTT : write(bioschar^);
               TTY : ttyoutput(biosbyte^);
               BAT : blist(biosbyte^);
               UC1 : uc1output(biosbyte^);
             end;

    0:   abortflag^:=1;      (* cold boot should abort *)
    1:   begin
            warmboot(x);
            x.bx:=ccpaddr + 3;  { jump to beginning of ccp }
         end;
         { check this for the new bdos !!! }
    2:   bconst(x.al);
    3:   bconin(x.al);
    5:   blist(x.cl);
    6:   bpunch(x.cl);    { punch  }  { do as  COM1 later }
    7:   breader(x.al);   { reader }  { do as  COM1 later }
    8:   begin  end;      { home   }  { fake it }
    9:   bseldsk(x);      { does not return DPE pointer }
    10:  notimplemented ; { settrk }
    11:  notimplemented ; { setsec }
    12:  bsetdma(x);
    13:  notimplemented ; { read   }
    14:  notimplemented ; { write  }
    15:  blistst( x.al);
    16:  biosreg^.hl:=bsectran(x.cx); { probably not used }
  else notimplemented;
 end; { case }
 biosreg^.a:=x.al;
 biosreg^.hl:=x.bx; (* wrong for 16 *)
end; { bios emulation }


{ now bdos routines }
{ cpm80 sends parameters in e or de, gets back in a or hl }

procedure nobdos( n : byte);
begin
    writeln;write('BDOS call # ');putbyte(n);writeln(' not implemented.');
    writeln;
    abortflag^:=1;
end; { nobdos }


function getalloc : word;
var    v : ^alloc;
       u : registers;
begin
   v:=ptr(cpm80,bdosaddr+bdosalloc);
   fillchar(v^[0],NUMALLOCBYTES,$ff);    { say that it's used }
   u.dl:=0; { default drive }
   u.ah:=$36;
   msdos(u);
   if u.ax=$ffff then writeln('Invalid CP/M drive number.');
   if u.bx <> 0 then begin
       { compute number of free blocks, and mark them with a zero }
       if u.bx > (NUMALLOCBYTES shl 3)   then u.bx:= NUMALLOCBYTES shl 3 ;
       v^[0]:= (not (u.bx and $0007)) and $ff;     { partial block }
       fillchar(v^[$1], (u.bx shr 3 ),0);          { whole blocks }
   end;
   getalloc:=bdosaddr+bdosalloc;
end; { getalloc }

{ construct a fake dpb from the DOS data }
{ need this for programs like DISK76 and SD to work }

function makedpb : word;
var    u : registers;
       fatid : byte;
       numalloc : word; { number of allocation blocks }
       secalloc : byte;    { number of sectors per alloc block }
       physize  : word; { number of bytes in physical sector }
       fake : dpbblk;
       cdpb : ^dpbblk;
       fat  : ^byte;
       cpmphys : byte;
       small   : boolean;
       blksize : word; { cpm alloc block size }
begin
  cdpb:=ptr(cpm80,bdosaddr+bdosdpb);
  fillchar(cdpb^,16,0);
  with fake do begin
      u.ah:=$1b;  { use newer dos call }
      msdos(u);
      fat:=ptr(u.ds,u.bx);
      fatid:=fat^;     { in asm code, would have to protect DS }

      u.ah:=$36;u.dl:=0;
      msdos(u);
      numalloc:=u.dx;  { number of allocation units }
      secalloc:=u.al;  { physical sectors per allocation unit }
      physize:=u.cx;   { size of physical sector }
      cpmphys:= physize shr 7; { 128 byte sectors per physical sector }
                               {assume multiple of 128 }
      if fatid <> $f8 then begin
          { check for dos 1.x versus dos 2.x formats }
          if (fatid and 2) <> 0 then spt:= 8*cpmphys else spt:=9*cpmphys;
      end else begin { is harddisk }
          spt:=18*4; { 18 physical 512 byte sectors per track }
      end;
          { compute block size } { minimum of 1k for cpm }
      blksize:= ( secalloc * physize ) shr 10 ; {  in 1024 chunks }
      if blksize = 0 then begin
            numalloc:=numalloc shr 1 ;
            blksize:=1;
      end;   { smallest allowable cpm blocks are 1k, so adjust }
      if numalloc > 255 then small:=true else small:=false;
      { decides byte or word value for alloc blocks in cpm fcb }
      if (numalloc < 0)  or ( numalloc > 8*$d0) then numalloc:=8*$d0;
      { only have $d0 bytes for allocation vector }

case blksize of
       1: begin  bsh:=3; blm:=7;   end;
       2: begin  bsh:=4; blm:=15;  end;
       4: begin  bsh:=5; blm:=31;  end;
       8: begin  bsh:=6; blm:=63;  end;
      16: begin  bsh:=7; blm:=127; end;
    else writeln(#$0d,#$0a,#7,'Screwy blocksize.');
   end; { case }
   { set extent mask block }
   { 16k per extent. exm is # of extents per dir entry -1}
   { there are 16 bytes of data/entry, so if 1 byte pointers, gives}
   { 16 blocks/entry. If 2 bytes per counter, gives 8 blocks/entry }
   if small then
       exm:= blksize -1
   else exm:= (blksize shr 1) -1;
   if exm < 0 then begin
        writeln;
        writeln('Bad decode of BPB information giving invalid CP/M DPB.');
        writeln;
   end;
   dsm:=numalloc-1;
   drm:=511;
   cks:=0;
   al01:=$ff00;
   off:=0; { no reserved  tracks }
 end; { with fake }
 { pass a allocation vector .. a bit map of usage of disk blocks }
 cdpb^:=fake;
 makedpb:=bdosaddr+bdosdpb;
end; { makedpb }

var
     help : dosfcb;
        w : ^dosfcb;

procedure setdma; { make  sure the  dma address is set correctly }
var  t : registers;
begin
  t.ah:=$1a;
  t.ds:=cpm80;
  t.dx:=lastdma;
  msdos(t);
end; { setdma }


{ CP/M programs seemed to destroy parts of the record in fcb needed }
{ by msdos to do findnext. The following kludge is to save the }
{ result of the fcb for each findfile or findnext for use later. }
{ If different fcbs were used, this could be a problem???? }
{ However, the big problem would be a fallacious match and then }
{ a delete, so avoid this by a check on the fcb address }
{ However, this did not work.... }
{ The CCP - EMUL interaction clobbers the DMA address somewhere }


{ kludge.. set the first directory byte = 0 always }
{ because msdos puts it to be disk number a=1,..e=5 }
{ sets returned size in size bytes of fcb since some programs }
{ eg, SD, use this to size the file, instead of the BDOS CALL }


procedure fakeit;
var u : ^dosdir;
   y, x : longint;
   z,t :  byte;
   j : word;
begin
{ adjust directory entry returned for right size and user }
{ MSDOS returns 1st byte to be disk number. CP/M expects user number }
{ Our CP/M emulation has only userr 0, so set this to be zero, and   }
{ make the extent byte and the leftover sectors byte }

   u:=ptr(cpm80,lastdma);  { look at the directory entry returned }

   { read the MSDOS file size from this directory entry }
   x:= longint(u^.size[1]) +  (longint(u^.size[2]) shl 8) +
       (longint(u^.size[3]) shl 16) + (longint(u^.size[4]) shl 24) ;
   if  x > $400000 then x:=$400000; { set a cut off size of 4 megs }
   y:= x shr 14 ; { number of 16k extents }
   { if y > 256, in trouble, so x < 256*16k = 4 meg }
   x:= x and $3FFF; { get remainder mod 16384 }
   x:= x shr 7;   { number of physical sectors }
   t:= x      ;
   for j:=12 to 31 do u^.cpmdir[j]:=0; { zero the rest of it }
   u^.cpmdir[0]:=0;  { set user byte = 0 }
   u^.cpmdir[$f]:=t; { sectors left over from last extent }
   u^.cpmdir[$c]:=z; { extent byte  }
end; { fakeit }


{  according to cp/m rules, a program can do no disk calls between }
{  findfirst and findnext, or between sucessive findnext calls }
{  MSDOS claims you can, but not with same FCB }


procedure findfile(var z : registers);
var u : ^dosfcb;
    p : ^byte;
begin
   u:=ptr(z.ds,z.dx);
   z.ah:=$11;
   msdos(z);
   p:=ptr(cpm80,lastdma);
   if p^<> $e5 then fakeit;
   myownfcb:=u^;     { save the exact fcb for use for find next }
   z.bl:=z.al;  { bdos returns a in l }
   {writeln('findfile  a= ',z.al);  }
end; { findfile }

procedure findnext( var z : registers);
var u : ^dosfcb;
    p : ^byte;
begin
   u:=ptr(z.ds,z.dx);
   u^:=myownfcb;         { replace it by my copy from last time }
   z.ah:=$12;
   msdos(z);
   myownfcb:=u^;        { hoard it away again }
   p:=ptr(cpm80,lastdma);  { see what it returned }
   if p^<> $e5 then fakeit;
   { writeln('findnext a= ',z.al); }
   z.bl:=z.al;
end; { findnext }


{ all disk calls go directly to MSDOS bdos }
{ character calls go through 8080 BIOS and on to 8086 bios emulator }


{ adapt for interrupt servicing }
var   f : ^dosfcb;
      mine : dosfcb;

{ NOTES on interfacing Turbo modules as CALLN service routines
  For a Turbo routine with no parameters or local storage the
  code produced is
  push  bp
  mov   bp,sp
  push  bp
  jump  xxxx
xxxx:   ....... Turbo code
  jmp   yyyy
yyyy:   mov   sp,bp
  pop   bp
  ret

 I'm trying the sequence
  push  ds
  mov   ds, cs:[oldds]     ; at xxxx

  pop   ds
  mov   sp,bp
  pop   bp                 ; before jump to yyyy
  iret
}


var  spin : word;
     cpmrecord : word;

procedure bdosemul;  { communicates with bdosreg pointer }
{ emulate cpm80 bdos using msdos bdos }
{ problem with record lengths.. 36 versus 37 bytes }
{ so doctor the fcbs on read and write calls }
interrupt; (* for turbo 4.0 *)
begin
    x.ah:=bdosreg^.c;  { could do this in 8080 bdos }
                        { prepare for msdos call }
    x.dx:=bdosreg^.de;
    x.ds:=cpm80;

 case x.ah of
 { calls 0-c are handled by 8080 bdos stub via bios calls }
 { this allows for more compatibility with CP/M-80 console handling }

      $D : msdos(x);
      $E..$10,$13:  begin
                  msdos(x);
                  x.bl:=x.al;
                end;
      $11:  findfile(x);
      $12:  findnext(x);
      $14:  begin  { read  seq. }
               setdma;
               f:=ptr( cpm80,bdosreg^.de);
               mine:=f^;  { switch fcb's for disk calls }
               x.dx:=ofs(mine);
               x.ds:=seg(mine);
               mine.recsize:=$80;
               msdos(x);
               f^.cpmseqfcb:=mine.cpmseqfcb; { identify these pieces }
               if x.al=3 then x.al:=0; { read 1 more }
               x.bl:=x.al;
               if x.al=2 then writeln(#7,'BDOS read error. DTA too small.');
               { msdos sends a 3 for partial record read. }
               { But cpm only knows about 128 byte records, so fake it }
               { one problem is that some dos programs do not terminate
               text file with $1a. should probably fake this }
            end; { read }
      $15:   begin   { write seq. }
               setdma;
               f:=ptr( cpm80,bdosreg^.de);
               mine:=f^;  { switch fcb's for disk calls }
               mine.recsize:=$80;
               x.dx:=ofs(mine);
               x.ds:=seg(mine);
               msdos(x); x.bl:=x.al;
               f^.cpmseqfcb:=mine.cpmseqfcb; { identify these pieces }
               x.bl:=x.al;
            end;
      $16..$17: begin
                  msdos(x);
                  if x.al <> 0 then x.al:=$ff;
                  x.bl:=x.al;
                end;
      $18:   begin
               x.ah:=$19;msdos(x);
               x.ah:=$e; msdos(x);
               { now convert number in x.al to vector in x.bx}
               spin:=$ffff;
               spin:=spin shr (16 - x.al);
               x.bx:=spin;
             end; { log in vector }
      $19:   begin msdos(x); x.bl:=x.al; end;
      $1a:   begin       { set dma address }
                lastdma:=x.dx;
                setdma;
             end;
      $1b: begin x.bx:=getalloc; x.al:=x.bl;end;
                 { have to calculate .. use $1c dos call }
      $1c: begin x.al:=0;end;      { set write protect..fake it  }
      $1d: begin x.bx:=0; x.al:=0; end;      { no write protected disks }
      $1e: begin x.bl:=0; x.al:=0; end;      { set attributes }
      $1f: x.bx:=makedpb;  { make it up in 8080 space }
      $20: begin   { get/set user number }
              if x.dl=$ff then begin x.al:=0; x.bl:=0; end;
           end;
      $21..$22: begin { random read and write }
                  writeln(#7,'Used Random READ-WRITE calls.');
                  setdma;
                  f:=ptr( cpm80,bdosreg^.de);
                  { get the record number to save }
                  mine:=f^;  { switch fcb's for disk calls }
                  cpmrecord:=f^.randrec[1];
                  mine.randrec[2]:=0;
                  x.dx:=ofs(mine);
                  x.ds:=seg(mine);
                  mine.recsize:=$80;
                  msdos(x);
                  f^.cpmrandfcb:=mine.cpmrandfcb; { identify these pieces }
                  f^.randrec[1]:= cpmrecord; { restore the record number }
                  x.bl:=x.al;
                end;
      $23 :  begin   { file size }
                  (* writeln(#7,'Used File Size DOS call.'); *)
                  f:=ptr( cpm80,bdosreg^.de);
                  { get the record number to save }
                  mine:=f^;  { switch fcb's for disk calls }
                  x.dx:=ofs(mine);
                  x.ds:=seg(mine);
                  mine.recsize:=$80;
                  msdos(x);
                  f^.cpmrandfcb:=mine.cpmrandfcb; { identify these pieces }
                  x.bl:=x.al;
                end;
      $24 :  begin   { set random record number}
                  (* writeln(lst,'Used SET RND REC'); *)
                  f:=ptr( cpm80,bdosreg^.de);
                  mine:=f^;  { switch fcb's for disk calls }
                  x.dx:=ofs(mine);
                  x.ds:=seg(mine);
                  mine.recsize:=$80;
                  msdos(x);
                  f^.cpmrandfcb:=mine.cpmrandfcb; { identify these pieces }
                  x.bl:=x.al;
             end;
      $25 :  begin    { selective reset disk }
               x.ah:=$0d;
               msdos(x);
               x.al:=0; x.bl:=0;
             end;
      $28:  begin    { zero fill random write }
                  x.ah:=$22; { fake it with usual random write }
                  setdma;
                  f:=ptr( cpm80,bdosreg^.de);
                  { get the record number to save }
                  mine:=f^;  { switch fcb's for disk calls }
                  cpmrecord:=f^.randrec[1];
                  mine.randrec[2]:=0;
                  x.dx:=ofs(mine);
                  x.ds:=seg(mine);
                  mine.recsize:=$80;
                  msdos(x);
                  f^.cpmrandfcb:=mine.cpmrandfcb; { identify these pieces }
                  f^.randrec[1]:= cpmrecord; { restore the record number }
                  x.bl:=x.al;
           end;
    else  nobdos(x.cl);
  end; { case }
  bdosreg^.hl:=x.bx;
  bdosreg^.a:=x.al;
end; { bdos emulation }

var   st : ^anystring;
(* this later piece is not implemented yet
   the thought was to rewrite the ccp in pascal and add various features
*)
procedure ccpemul;
interrupt;
begin
 case ccpregs^.c of
  0 : begin  { chdir }
         st:=ptr(cpm80,ccpregs^.de +1);
         ChDir(st^);
         user^:=getcurrent;
      end;
  1 : begin
         st:=ptr(cpm80,ccpregs^.de +1);
         MkDir(st^)
      end;
  2 : begin
         st:=ptr(cpm80,ccpregs^.de +1);
         RmDir(st^)
      end;
  3 : begin
         st:=ptr(cpm80,ccpregs^.de +1);
         user^:=getcurrent;
         GetDir(user^+1,st^)
      end;
 else begin end;   { pass them through }
 end; { case }
end;     { ccp emul }


procedure logo;
var x : word;
begin
clrscr;
  writeln('CP/M-80 Emulator for NEC V-20 and the IBM-PC');
  writeln('Uses default setup or reads from file ');
  write('8080 Code Loaded at 0');putword(cpm80);writeln('H Segment');
  write('Uses interrupts ');putbyte(baseinterrupt);
  write('..');putbyte(baseinterrupt+3);writeln('H.');
  writeln;
  write('CCP loaded at ');putword(ccpaddr);
  write('H, BDOS at ')   ;putword(bdosaddr);
  write('H, BIOS at ')   ;putword(biosaddr);writeln('H.');
  x:=ccpaddr;
  writeln('TPA of ',x:6,' bytes.');
  write('Default IObyte is ');putbyte(defaultiobyte);writeln('H.');
  if(defaultiobyte and 1) = 0 then
                    writeln('TTY: device emulates H-19 terminal.');
  writeln('UL1: device is ',cpmoutname,'.');
  writeln;
  writeln('Copyright Nov.10, 1985 by Clarence Wilkerson');
  writeln('All rights reserved.');
  writeln('Modified for Turbo Pascal 4.0, December 6, 1988');
  writeln;
  writeln;
  writeln('Exit with the BYE command, or by writing 1 in location $ffff.');
  writeln;writeln;
end;


procedure findcpm;
var uu : ^byte;
begin     { put some error checking here eventually }
  new(cpmseg);
  new(extra); { hope these are together }
  cpm80:=seg(cpmseg^[0]) + (ofs(cpmseg^[0]) shr 4 ) + 1 ;
  uu:=ptr(cpm80,0);
  fillchar( uu^,$ffff,#0);
end; { findcpm }

procedure interruptset;
var  i : integer;
begin
  for i:=0 to 3 do begin
     oldinterrupt[i].loc:=baseinterrupt + i;
     newinterrupt[i].loc:=baseinterrupt + i;
     getinterrupt(oldinterrupt[i]);       { store it away for restoration }
  end;
  newinterrupt[coldb].segment       :=cpm80;
  newinterrupt[coldb].offset        :=biosaddr;  { DO 8080 COLD BOOT ROUTINE }
  newinterrupt[ccphandle ].segment  :=seg(ccpemul);
  newinterrupt[ccphandle ].offset   :=ofs(ccpemul);
  newinterrupt[bdoshandle].segment  :=seg(bdosemul);
  newinterrupt[bdoshandle].offset   :=ofs(bdosemul);
  newinterrupt[bioshandle].segment  :=seg(biosemul);
  newinterrupt[bioshandle].offset   :=ofs(biosemul);
  MEM[CPM80:$FFb0]:=BASEinterrupt+COLDB;
  MEM[CPM80:$FFb1]:=BASEinterrupt+CCPHANDLE;
  MEM[CPM80:$FFb2]:=BASEinterrupt+BDOSHANDLE;
  MEM[CPM80:$FFb3]:=BASEinterrupt+BIOSHANDLE;
  for i:=0 to 3 do setinterrupt(newinterrupt[i]);
end; { interruptsetup }


procedure opencpmoutput;
var u : registers;
begin   { use dos 2.0 handle calls }
  u.ah:=$3c;
  u.ds:=seg(cpmoutname);
  u.dx:=ofs(cpmoutname) + 1;
  cpmoutname:=cpmoutname + #0;
  u.cx:=0;
  msdos(u);
  listouthandle:=u.ax;
  if u.flags and carryflag <> 0 then begin
     writeln;writeln('Error on list handle opening.');
     writeln;
 end;
end; { open cpm output }

procedure closehandle( x : integer);
var u : registers;
begin
  u.ah:=$3e;
  u.bx:=x;
  msdos(u);
  if u.flags and carryflag <> 0 then begin
     writeln;writeln('Error on closing handle.');
  end;
end; { closehandle }

procedure restoreinterrupts;
var  i : integer;
begin
  for i:=0 to 3 do setinterrupt(oldinterrupt[i]);
end;  { restore interrupt vectors }

procedure digest(var s : anystring);
var i,n,code : integer;
    t,tt,ttt : anystring;
begin
   t:='';
   for i:=1 to length(s) do begin
       s[i]:=upcase(s[i]);
       if s[i] in ['A'..'Z','0'..'9','=','.','-','\',':','$'] then t:=t+s[i];
       { strip spaces and junk off }
   end; { for }
       n:=pos('=',t);
       if n=0 then exit;
       tt:=copy(t,1,n-1);
       ttt:=copy(t,n+1,255);
       if tt=  'IOBYTE' then begin
                     val(ttt,n,code);
                     if (code = 0) and (length(ttt) >0 ) then
                        defaultiobyte:=n;
                     end { get iobyte }
       else if tt=  'LIST'   then begin
                      if length(ttt) > 0 then cpmoutname:=ttt;
                    end { get LST output file }
       else if tt=  'INTER' then begin
                     val(ttt,n,code);
                     if (code = 0) and (length(ttt) >0 ) then
                        baseinterrupt:=n ;
                    end { get beginning interrupt number }
       else if tt= 'CCP'  then begin
                     val(ttt,n,code);
                     if (code = 0) and (length(ttt) >0 ) then
                        CCPSIZE:=n * 128;
                    end { length of ccp in 128 byte chunks }
      else if tt= 'ADDR'  then begin
                     val(ttt,n,code);
                     if (code = 0) and (length(ttt) >0 ) then
                        CCPADDR:=n;
                    end { beginning of ccp  }

      else if tt= 'BDOS' then begin
                     val(ttt,n,code);
                     if (code = 0) and (length(ttt) >0 ) then
                        BDOSSIZE:=n * 128;
                   end; { length of bdos-bios in 128 byte chunks }
end; { digest }

PROCEDURE getinitfile;
var  n : integer;
     parmstrng : anystring;
{ allows change of most of the setup parameters }
begin
   assign (initf,'INITV20.CPM');
   {$I-}
   reset(initf);
   n:=IOresult;
   {$I+}
   if n <> 0 then exit; { no file }
   while not eof(initf) do begin
      readln(initf,parmstrng);
      digest(parmstrng);
   end; { while not eof }
   close(initf);
end; { get initialization file }

procedure initcpm; { set some cpm addresses }
begin
   lastdma  :=$80;
   bdosreg  :=ptr(cpm80,$ffe0);
   biosreg  :=ptr(cpm80,$ffd0);
   bioswhich:=ptr(cpm80,$ffd0);
   bioschar:=ptr(cpm80,$ffd4);
   biosbyte:=ptr(cpm80,$ffd4);
   ccpregs  :=ptr(cpm80,$ffc0);
   user     :=ptr(cpm80,4); (* user byte *)
   iobyte   :=ptr(cpm80,3); (* iobyte is implemented *)
   iobyte^  :=defaultiobyte;
   abortflag:=ptr(cpm80,$ffff);
   zero     :=ptr(cpm80,0);
   bdosaddr :=ccpaddr + CCPSIZE;
end; { initcpm }

procedure gotocpm(seg8080,stack8080pointer,brkemint : word); external;
{$L gotocpm.obj}
(*   Has to be assembled with MASM or TASM
;
;
; procedure gotocpm(cpmseg,cpmstack,baseint : word);
;begin
; contains a kludge to get variable interrupt call
; or BRKEM call
; have to rewrite byte after the opcode
; on machines with a cache, could be a problem

code segment word public
     assume cs:code
     public  gotocpm
gotocpm proc near
            push bp    ;
            mov  bp,sp ; standard set up code, no local variables
            mov  ax,[bp + 4] ; brkem int # patch
            mov  byte ptr cs:hack,al  ; modify code
            mov  ax,[bp + 8] ; using near call, so last param at bp + 4
            ; since we pushed bp to start, plus return address
            mov  dx,[bp +6]  ; cpmstack to dx
            push bp       ; used by V20 as stack pointer
            push ds       ; set equal to CP/M data=code
            mov  ds,ax    ; [cpm80] set data segment for cpm
            mov  bp, dx   ; cpmstack to set cp/m stack
            db   0fh,0ffh ;   BRKEM
hack:       db   000h;    ;   BRKEM  XX  ; uses XX interrupt
                          ; overwritten in this version
            pop ds
            pop bp
            mov sp,bp  ; standard exit code
            pop bp
            ret 6   ; 3 two byte parameters pushed on stack
gotocpm     endp

code ends
end

*)

var ExitSave : pointer;

procedure CPMExit;
(* get here by disk error, etc, so cold booting  CP/M would be best
solution. However, have not done.
*)

begin
  writeln('Error in CP/M handler.');
  ErrorAddr:=Nil;
  ExitProc:=Nil;
end;

begin { main }
   GETINITFILE;
   findcpm; { get the 64k code space for cp/m-80 }
   logo;
   initcpm; { set up some cpm variables }
   setjumps;  { set lower memory }
   loadccp;
   loadbdos;
   opencpmoutput;
   interruptset; { set up the interrupts }
   setdefdma;    { set stack and DTA, data segment }
   iobyte^:=DEFAULTIOBYTE;
   myseg:=cpm80;
   mystack:=cpmstack;
   myinterrupt:=baseinterrupt;
   Exitsave:=ExitProc;
   ExitProc:=@CPMexit;
(* set up segments and use BRKEM to get to emulator *)

   gotocpm(myseg,mystack,myinterrupt);

   ExitProc:=ExitSave;
   restoreinterrupts;
   closehandle(listouthandle);
end
.