module bootdammodule;
import sysglobals,asm,mini,hfsboot;
export

  type string2=string[2];
       string6=string[6];       {added for LANSRM node lengths. SFB 1/19/89}
       string20=string[20];

  var nodestr: string[50];
      { hfsbflg tells whether we are booting from an HFS disc }
      hfsbflg['HFSBFLG']: boolean;

  procedure initbootdam;
  procedure bootdam(anyvar f:fib; unum:unitnum; request:damrequesttype);
  procedure boottm(f:fibp; request: amrequesttype;
		      anyvar buffer: window; bufsize,position: integer);
  function srmnode(sc: shortint): string6;      {upgraded for LANSRM. SFB 1/19/89}
  function bootnode: string6;                   {upgraded for LANSRM. SFB 1/19/89}
  function bootname(fullname: string20; shortlen: shortint): string20;

implement

  type

    strptr = ^string255;
    lifname  = packed array[1..10] of char;
    word15   = 0..32767;
    bcd      = 0..15;
    tdate    = packed array[1..12] of bcd;
    direntryp= ^direntry;
    direntry = packed record
		 fname    : lifname;
		 ftype    : shortint;
		 fstart   : integer;
		 fsize    : integer;
		 fdate    : tdate;
		 lastvol  : boolean;
		 volnumber: word15;
		 extension: integer;
	       end;

    msustype = packed record
		 mtype : byte;
		 munit : byte;
		 mscode: byte;
		 maddr : byte;
	       end;
  var
    driverkey  [-293  {$FFFFFEDB}]: boolean;
    boot_msus  [-292  {$FFFFFEDC}]: msustype;
    boot_id    [16382 {$    3FFE}]: shortint;
    boot_flags [16380 {$    3FFC}]: packed array[0..7] of boolean;

    gread        : boolean;

    {  FUNCTIONS AND PROCEDURES USED FROM THE BOOT ROM  }
  procedure boot_lifhead(var dsize,dstart:integer); external;
  procedure boot_findfile(var entry:direntryp; var lname:lifname;
						    dl,ds : integer); external;
  function boot_minit(msus:msustype):boolean; external;
  function boot_mfopen(anyvar fname:string255; var xaddr,length:integer;
		       var ftype:shortint):boolean; external;
  procedure boot_mfclose; external;
  procedure boot_mread(sector,bytecount: integer;
		       anyvar buffer:window; media:boolean); external;

  function escio(escn:integer):iorsltwd;
  begin
    case escn of
    1,7 : escio:=znodevice;
    2   : escio:=znomedium;
    3   : escio:=znotready;
    4   : escio:=zbadblock;
    5   : escio:=zbadhardware;
    6   : escio:=zcatchall;
    otherwise  escape(escn);
    end; { case }
  end;

  procedure bootdam(anyvar f:fib; unum:unitnum; request:damrequesttype);
  var
    ftype       : shortint;
    fk          : filekind;
    dstart      : integer;
    dsize       : integer;
    dentry      : direntryp;
    i,j         : integer;

    procedure escesc(ecode:integer);
    var
      tempec      : integer;
    begin { convert mini driver escape code to general code}
      if ecode<=0 then escape(ecode);
      if ecode = 1 then ioresult := ord(ibadtitle);
      tempec:=ecode mod 1000;
      if tempec=80 then escape(2)     { no medium }
      else if tempec=90 then escape(6){ bad error state }
	   else escape(4);            { read error }
    end;

    function minit(msus:msustype):boolean;
    var
      tempec              : integer;
    begin
      if gread then minit:=boot_minit(msus)
      else
      begin
      try
	minit:=true;
	driverkey := false;
	boot_lifhead(dsize,dstart);
	driverkey := true;
      recover begin
	      driverkey := true;
	      if escapecode=-1 then minit:=false
			       else escesc(escapecode);
	      end;
      end;
    end;

    function mfopen(anyvar fname:string255; var xaddr,length:integer;
		    var ftype:shortint):boolean;
    var
      tfname      : lifname;
      i           : integer;
      fk, fkind   : filekind;
    begin
      if gread then
	if hfsbflg then
	  { booting from HFS }
	  mfopen:=hfsopen(fname,xaddr,length,ftype)
	else
	  { not HFS, so boot ROM can handle it }
	  mfopen:=boot_mfopen(fname,xaddr,length,ftype)
      else
      begin
      try
	mfopen:=true;
	if (strlen(fname)=0) or (strlen(fname)>10) then escape(1);
	for i:=1 to 10 do
	  if i>strlen(fname) then tfname[i]:=' ' else tfname[i]:=fname[i];

	driverkey := false;
	boot_findfile(dentry,tfname,dsize,dstart);
	driverkey := true;

	fkind:=datafile;  ftype:=dentry^.ftype;
	for fk:=lastfkind downto untypedfile do
	  if efttable^[fk]=ftype then fkind:=fk;
	if fkind=sysfile then xaddr:=dentry^.extension
			 else xaddr:=0;
	if fkind=datafile then length:=dentry^.extension
			  else length:=dentry^.fsize*256;
      recover
	begin
	  driverkey := true;
	  mfopen:=false;
	  if escapecode<>-1 then escesc(escapecode);
	end;
      end;
    end;

    procedure mfclose;
    begin
      if gread then boot_mfclose;
    end;

  begin { bootdam }
    ioresult:=ord(inoerror);
    case request of
    getvolumename:  strptr(addr(f))^ := '"BOOT_DEVICE"';
    openfile:
      try
	j := 0;
	for i := 1 to strlen(f.ftitle) do if f.ftitle[i] = '/' then j := i;
	if strlen(f.ftitle)-j>tidleng then f.ftid := ''
	else begin
	     setstrlen(f.ftid, strlen(f.ftitle)-j);
	     for i := 1 to strlen(f.ftid) do f.ftid[i] := f.ftitle[j+i];
	     end;
	if minit(boot_msus) then
	begin
	  ftype:=-1;
	  if mfopen(f.ftitle,f.fstartaddress,f.fpeof,ftype) then
	  begin
	    f.fkind:=datafile;
	    for fk:=lastfkind downto untypedfile do
		   if efttable^[fk]=ftype then f.fkind:=fk;
	    if gread then f.fileid := 0
		     else f.fileid := dentry^.fstart*256;
	    f.fleof:=f.fpeof;       f.fisnew:=false;
	    if not f.fbuffered then f.am:=amtable^[UNTYPEDFILE]
	    else f.am:=amtable^[f.fkind];
	  end
	  else ioresult:=ord(inofile);
	end
	else with boot_msus do
	  ioresult:=ord(inounit);
      recover ioresult:=ord(escio(escapecode));
    closefile:
      try
	mfclose;
      recover ioresult:=ord(escio(escapecode));
    otherwise
      ioresult:=ord(ibadrequest);
    end; {case request}
  end; { bootdam }

  procedure initbootdam;
  type
    lrec = packed record
	     pad   : packed array[0..15] of char;
	     mbptr : ^char;     { offset 16 }
	     mbsize: integer;   { offset 20 }
	   end;
  const
    remote_boot_mask = binary('11100000');      {for validating hfsbflg. SFB}
  var
    boot_space  [-300]:^lrec;
  begin
    {Added a check to see that hfsbflg is correct, and correct it if it is not.
     Note that the startup and relocation code sets hfsbflg if we had to
     relocate before kicking off the system. Actually relocating means we did
     not boot directly from the BOOTROM, not that we booted from HFS.
     Usually, relocating just means that we booted through HP-UX's secondary
     loader. This could happen either as an HFS boot, or as a HPUX bootserver
     load. To check this, check the boot_msus first byte. If the upper 3 bits
     are 111, we booted through a "special" interface, and could not have
     booted from HFS, so clear hfsbflg. SFB}

    if (iand(boot_msus.mtype, remote_boot_mask) = remote_boot_mask) then
      hfsbflg:=FALSE;

    if boot_id<3 then gread:=false
    else gread:=not boot_flags[7];

    if gread then newbytes(boot_space^.mbptr,boot_space^.mbsize );

  end; {initboot dam}

  procedure boottm(f:fibp; request: amrequesttype;
		   anyvar buffer: window; bufsize,position: integer);
  begin
    if gread then
    begin
      with f^ do
      begin
	ioresult:=ord(inoerror);
	if request=readbytes then
	begin
	  if ((position+bufsize)>fpeof) or
	     (position<0)   then ioresult:=ord(znoblock)
	  else
	  if (position mod 256)<>0 then  ioresult:=ord(zbadmode)
	  else
	  begin
	    try
	      if hfsbflg then
		hfsread(position div 256,bufsize,buffer,false)
	      else
		boot_mread(position div 256,bufsize,buffer,false);
	    recover ioresult:=ord(escio(escapecode));
	  end;
	end
	else ioresult:=ord(zbadmode);
      end;{ with }
    end
    else begin
	 driverkey := false;
	 miniio(f,request,buffer,bufsize,position);
	 driverkey := true;
	 end;
  end;  { boottm }

function srmnode(sc: shortint): string6;      {upgraded for LANSRM. SFB 1/19/89}
  const scsize =  hex(' 10000'); nodecom = chr(128+6);
	command = hex('4003'); data    = hex('4005');
	dio_base = hex('600000');
	dio_id  = hex('1');  { LAF 850619 }
	LANLINKADDR = hex('C000');        {SFB 1/19/89}
	LANID   = 21;   {98643A DIO reg 1 ID. SFB}
	lookup='0123456789ABCDEF';
  type charptr = ^char;
  var bnode: string6;   {upgraded for LANSRM. SFB 1/19/89}
      node, i: integer;
      cardptr, addrptr: charptr;
  begin
    try
    (* if wrong card, pretend no card *)                      { LAF 850619 }
    (* DEW 09/29/88 Bug fix for DTS # FSDlg00560
       System does not recognize SRM card with remote switch set *)
    (* DEW 10/04/88 Fix compile error at turn time. *)
    cardptr:=anyptr(ord(sc*scsize+dio_base));
    if ord(charptr(ord(cardptr)+dio_id)^) mod 128 = 52 then
      begin
	charptr(ord(cardptr)+command)^ := nodecom;
	repeat until charptr(ord(cardptr)+command)^ = chr(0);
	node := ord(charptr(ord(cardptr)+data)^);
	if node < 10 then bnode := '0' else bnode := '';
	strwrite(bnode, strlen(bnode)+1, i, node:1);
	srmnode := bnode;
      end
    else        {see if it's 98643A; if so, put LAST 6 hex digits of its link
		 address into srmnode. SFB/RDQ 1/19/89}
      if (ord(charptr(ord(cardptr)+dio_id)^) mod 128) = LANID then
	begin
	  setstrlen(bnode,6);
	  addrptr:=addr(cardptr^,LANLINKADDR+1);
	  if (ord(addrptr^) mod 16) + (ord(charptr(addr(addrptr^,2))^) mod 16) <> 0 then
	    addrptr:=addr(addrptr^, hex('40')); {second bank}
	  addrptr:=addr(addrptr^, 8 + 12 {skip longword + first 6 digits});
	  for i:=1 to 6 do
	    begin
	      bnode[i]:=lookup[(ord(addrptr^) mod 16)+1];
	      addrptr:=addr(addrptr^,2);
	    end;
	  srmnode := bnode;
	end
      else
	escape(-12);
    recover if escapecode = -12 then srmnode := '' else escape(escapecode);
  end;

  function bootnode: string6;      {upgraded for LANSRM. SFB 1/19/89}
  const srmtype = 7*32+1 {$E1};
	lantype = hex('E2');
  begin
  bootnode := '';
  if gread then with boot_msus do
    if (mtype = srmtype) or (mtype = lantype) then bootnode := srmnode(mscode);
  end;


  function bootname(fullname: string20; shortlen: shortint): string20;
  var
    shortversion: boolean;
    suffix: string20;
    ans: string20;
    i, j: shortint;
  {----------------}
  {
  { Find system suffix.
  { SYSTEM_P -> ''
  { SYSTEM_xxx -> 'xxx'
  { SYSxxxxxxx -> 'xxxxxxx'
  { anything else -> ''
  }
  procedure getsyssuffix;
  type stringsysp = packed array[1..10] of char;
  const sysp      = stringsysp['SYSTEM_P'];
  var
    i,j,k: shortint;
  begin
   { normalize sysname; HFS boot can put nulls in it }
   for i := 1 to 10 do if sysname[i] = #0 then sysname[i] := ' ';
   i := 0;
   { find first place where user sys name different from SYSTEM_P }
   repeat i := i + 1; until (i=10) or (sysname[i]<>sysp[i]);
   setstrlen(suffix, 0);
   shortversion := false;
   if (i = 10) or (i <= 3) then
     { user system name is SYSTEM_P, or something too strange }
     { suffix = '' }
   else begin
     shortversion := true;
     if i > 7 then
       { SYSTEM_xxx }
       i := 8
     else
       { SYSxxxxxxx }
       i := 4;
     k := 1;
     for j := i to 10 do
       if sysname[j] <> ' ' then begin
	 setstrlen(suffix, k);
	 suffix[k] := sysname[j];
	 k := k + 1;
       end;
   end;
  end;
  {----------------}
  begin
    ans := fullname;
    getsyssuffix;
    if shortversion then
      setstrlen(ans, shortlen);
    i := strlen(ans);
    for j := 1 to strlen(suffix) do
      begin i:=i+1; setstrlen(ans, i); ans[i]:=suffix[j]; end;
    bootname := ans;
  end;



end     { module }


