head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.32.54;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.09.28;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.30.43;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.08.42;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.16.43;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.17.17;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.02.29;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.01.40;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.15.16;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.03.33;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.09.20;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.46.57;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.35.09;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.42.02;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.21.59.53;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.49.45;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.35.10;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.17.29;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.40.26;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.25.45;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.16.12;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.29.21;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.08.24;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.19.50;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.15.55.08;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.30.25;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.36.28;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.17.57.22;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.35.40;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.19.45;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.49.13;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.14.46;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.30.36;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.08.59;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.18.06;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.09.54.52;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.35.04;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.22.52;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.33.01;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.07.51.33;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.14.46.06;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.03.47;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.18.25;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.08.43.33;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.07.09.40.48;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.14.39.07;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.06.39;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.12.52.45;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.19.41;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.25.48;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.13.47.58;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.23.19;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.09.22;  author hal;  state Exp;
branches ;
next     6.2;

6.2
date     86.11.19.15.50.36;  author bayes;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.10.44;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.15.59.58;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.13.11;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.25.22;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.16.25;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.13.37.04;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@				{ file GENUTIL }

    import
      assemble,genmove,ci,fs;
    implement
      type
	pachstring = packed array[1..strglgth] of char;
      var
	codelinestart: 0..1023;
	nullstring: string[1];
	dot_code: string[5];

      procedure codeinit;
	begin
	  codeout := false; startaddr := -1;
	  codephile.headerblock := 2;
	  nextmodule := 1;
	end;

      procedure moduleinit (* modulenameptr: alphaptr *);
	begin
	uniquenum := 0;
	currentglobal := modulenameptr;
	modulecodeout := false;
	with codephile do
	  begin
	  bytecount := 0;
	  windowptr := 0;
	  startblock := headerblock + 1;
	  sourceblock := 1;
	  sourcesize := 0;
	  end;
	with defile do
	  begin
	  block := 0;
	  bite := 0;
	  end;
	def_ext_top := 1;
	with refile do
	  begin
	  block := 0;
	  bite := 0;
	  end;
	outputdef('_BASE',0,relocatable,0);
	end; { codeinit }

      procedure file_warn(errornum,iores: shortint);
	var
	  s: string[10];
	  i: integer;
	  message: string[50];
	const
	  error_opening = 'Error opening ';
	  error_writing = 'Error writing ';

	begin
	error(errornum);
	setstrlen(s,0);
	strwrite(s,1,i,iores:1);
	message := ' file, ioresult(' + s + ')';

	case errornum of
	  903: message := error_opening + 'code' + message;
	  904: message := error_opening + 'ref' + message;
	  905: message := error_opening + 'def' + message;
	  906: message := error_writing + 'code' + message;
	  907: message := error_writing + 'ref' + message;
	  908: message := error_writing + 'def' + message;
	end;
	warning(linenumber,message);
	end;

      procedure dumpbuffer;
	var
	  block: shortint;
	begin
	with codephile do
	  begin
	  if totalerrors = 0 then
	    begin
	    if not codefileopen then
	      begin
	      reset(fileid,file_name);
	      close(fileid,'PURGE');  { Purge any existing file }
	      fmaketype(fileid,file_name,
			nullstring,dot_code);
	      if ioresult <> 0 then
		file_warn(903,ioresult);
	      codefileopen := true;
	      end;
	    block := startblock + (windowptr DIV 512);
	    if blockwrite(fileid,buffer^,coderecs,block) <> coderecs then
	      file_warn(906,ioresult);
	    end;
	  windowptr := bytecount;
	  end;
	end; { dumpbuffer }

      procedure outputcodebyte (* b: shortint *);
	var
	  block, bite: shortint;
	begin
	  with codephile do
	    begin
	    modulecodeout := true;
	    block := (bytecount - windowptr) DIV 512 + 1;
	    bite := (bytecount - windowptr) MOD 512;
	    buffer^[block,bite] := b;
	    bytecount := bytecount + 1;
	    if (block = coderecs) and (bite = 511) then { buffer is full }
	      dumpbuffer;
	    end;
	end; { outputcodebyte }

      procedure outputcodeword (* w: shortint *);
	var
	  variantrec: packed record case boolean of
			true: (w: shortint);
			false: (b1: byt;
				b2: byt);
		      end;
	begin
	  variantrec.w := w;
	  outputcodebyte(variantrec.b1);
	  outputcodebyte(variantrec.b2);
	end; { outputcodeword }

      procedure outputcodelong (* l: integer *);
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;
	begin
	  variantrec.l := l;
	  for i := 0 to 3 do outputcodebyte(variantrec.b[i]);
	end; { outputcodelong }

      procedure fixbyte (* pc: addrrange; value: shortint *);
	var
	  fixbuffer: bytebufs;
	  bite,block: shortint;
	begin
	  if (pc >= 0) and (value <> 0) then with codephile do
	    if pc >= windowptr then { byte is in current buffer }
	      begin
	      bite := (pc - windowptr) MOD 512;
	      block := (pc - windowptr) DIV 512 + 1;
	      buffer^[block,bite] := buffer^[block,bite] + value;
	      end
	    else { patch up on disk }
	      begin
	      block := startblock + (pc DIV 512);
	      bite := pc MOD 512;
	      if blockread(fileid,fixbuffer,1,block) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      fixbuffer[bite] := fixbuffer[bite] + value;
	      if blockwrite(fileid,fixbuffer,1,block) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	end; { fixbyte }

      procedure fixword ( pc: addrrange; value: shortint );
	var
	  fixbuffer: array[1..2] of bytebufs;
	  numberofblocks: shortint;
	  bite1,block1,
	  bite2,block2: shortint;
	  variantrec: packed record case boolean of
			true: (w: shortint);
			false: (b1: byt;
				b2: byt);
		      end;
	begin
	if totalerrors = 0 then
	  if (pc >= 0) and (value <> 0) then with codephile do
	    if pc >= windowptr then { word is in current buffer }
	      begin
	      bite1 := (pc - windowptr) mod 512;
	      block1 := (pc - windowptr) DIV 512 + 1;
	      variantrec.b1 := buffer^[block1,bite1];
	      bite2 := (pc - windowptr + 1) MOD 512;
	      block2 := (pc - windowptr + 1) DIV 512 + 1;
	      variantrec.b2 := buffer^[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      buffer^[block1,bite1] := variantrec.b1;
	      buffer^[block2,bite2] := variantrec.b2;
	      end
	    else { patch up on disk }
	      begin
	      block1 := startblock + (pc DIV 512);
	      bite1 := pc MOD 512;
	      if bite1 < 511 then numberofblocks := 1 {word is all in one block}
			     else numberofblocks := 2;{word crosses boundry}
	      if blockread(fileid,fixbuffer,numberofblocks,block1)
							 <> numberofblocks then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      variantrec.b1 := fixbuffer[1,bite1];
	      block2 := 1 + (bite1 + 1) DIV 512;
	      bite2 := (bite1 + 1) MOD 512;
	      variantrec.b2 := fixbuffer[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      fixbuffer[1,bite1] := variantrec.b1;
	      fixbuffer[block2,bite2] := variantrec.b2;
	      if blockwrite(fileid,fixbuffer,numberofblocks,block1)
							  <> numberofblocks then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	end; { fixword }

      $IF MC68020$
      procedure fixlong ( pc: addrrange; value: integer );
	{ Assumes that the location being fixed currently has a value of 0 }
	var
	  variantrec : record case boolean of
			 true: (i: integer);
			 false:(s1: shortint;
				s2: shortint);
		       end;
	begin
	variantrec.i := value;
	fixword(pc,variantrec.s1);
	fixword(pc+2,variantrec.s2);
	end; {fixlong}
      $END$

      procedure fixreflist (* listptr: reflistptr *);
	{ listptr is a ptr to a linked list of 16-bit pc relative
	  references to the current pc.  This routine patches all
	  of those references. }
	var
	  patchbuf: array[1..2] of bytebufs;
	  patchblock,          {indicates the current block(s) in the patchbuf}
	  blocksin: shortint;  {number of blocks read into patchbuf}

	procedure diskpatch (pc: addrrange; value: shortint);
	  var
	    variantrec: packed record case boolean of
			  true: (w: shortint);
			  false: (b1: byt;
				  b2: byt);
			end;
	    bite1,block1,
	    bite2,block2: shortint;
	  begin
	    with codephile do
	      begin
	      block1 := startblock + (pc DIV 512);
	      bite1 := pc MOD 512;
	      if block1 <> patchblock then
		if (block1 <> patchblock + 1) or (bite1 = 511) then
		  begin
		  if patchblock <> 0 then
		    if blockwrite(fileid,patchbuf,blocksin,patchblock)<>blocksin
		      then begin ioresult := ord(zcatchall); escape(-10); end;
		  if bite1 < 511 then blocksin := 1
				 else blocksin := 2;
		  patchblock := block1;
		  if blockread(fileid,patchbuf,blocksin,patchblock) <> blocksin
		    then begin ioresult := ord(zcatchall); escape(-10); end;
		  end
		else
		  if blocksin <> 2 then { read in second part of buffer }
		    begin
		    if blockread(fileid,patchbuf[2],1,patchblock+1) <> 1
		      then begin ioresult := ord(zcatchall); escape(-10); end;
		    blocksin := 2;
		    end;
	      block1 := 1 + block1 - patchblock;
	      block2 := block1 + (bite1 + 1) DIV 512;
	      bite2 := (bite1 + 1) MOD 512;
	      variantrec.b1 := patchbuf[block1,bite1];
	      variantrec.b2 := patchbuf[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      patchbuf[block1,bite1] := variantrec.b1;
	      patchbuf[block2,bite2] := variantrec.b2;
	      end;
	  end; { diskpatch }

	procedure dumpatches;
	  begin
	    if patchblock <> 0 then with codephile do
	      if blockwrite(fileid,patchbuf,blocksin,patchblock) <> blocksin
		then
		begin
		ioresult := ord(zcatchall);
		escape(-10);
		end;
	  end; { dumpatches }

	begin { fixreflist }
	if totalerrors = 0 then
	  begin
	  patchblock := 0;
	  while listptr <> NIL do
	    with listptr^ do
	      begin
	      if pc <> -1 then { -1 => branch not emitted }
		if (codephile.bytecount - pc) > 32767 then
		  error(671)
		else
		  if pc >= codephile.windowptr then
		    fixword(pc,codephile.bytecount-pc)
		  else
		    diskpatch(pc,codephile.bytecount-pc);
	      listptr := next;
	      end; { with listptr^ }
	  dumpatches;
	  end;
	end; { fixreflist }

      procedure outputref(name: alpha; loc: addrrange; t: reftype);
	{ temporarily output refs to a file }
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;

	procedure dumprefbuffer;
	  begin
	    with refile do
	      begin
	      if blockwrite(fileid,buffer^,1,block) <> 1 then
		file_warn(907,ioresult);
	      block := block + 1;
	      bite := 0;
	      end;
	  end; { dumprefbuffer }

	begin
	if totalerrors = 0 then
	  with refile do
	    begin
	    upc(name);               { added 4/12/84 }
	    buffer^[bite] := strlen(name);
	    bite := bite + 1;
	    if bite > 511 then dumprefbuffer;
	    for i := 1 to strlen(name) do
	      begin
	      buffer^[bite] := ord(name[i]);
	      bite := bite +1;
	      if bite > 511 then dumprefbuffer;
	      end;
	    buffer^[bite] := ord(t);
	    bite := bite + 1;
	    if bite > 511 then dumprefbuffer;
	    variantrec.l := loc;
	    for i := 0 to 3 do
	      begin
	      buffer^[bite] := variantrec.b[i];
	      bite := bite + 1;
	      if bite > 511 then dumprefbuffer;
	      end;
	    end;
	end; { outputref }

      procedure outputdef(name: string255;
			  loc: addrrange;
			  t: reloctype;
			  extnumber: shortint);
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;
	  flags: flagtype;

	procedure dumpdefbuffer;
	  begin
	    with defile do
	      begin
	      if blockwrite(fileid,buffer^,1,block) <> 1 then
		file_warn(908,ioresult);
	      block := block + 1;
	      bite := 0;
	      end;
	  end; { dumpdefbuffer }

	begin
	if curglobalname <> NIL then
	  name := curglobalname^ + '_' + name;
	if totalerrors = 0 then
	  with defile do
	    begin
	    buffer^[bite] := strlen(name);
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    for i := 1 to strlen(name) do
	      begin
	      upc(name);
	      buffer^[bite] := ord(name[i]);
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    if not(odd(strlen(name))) then { pad to an even byte }
	      begin
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    with flags do
	      begin
	      typ := t;
	      size := sl;
	      patchable := false;
	      valueextend := true;
	      longoffset := false;
	      end;
	    buffer^[bite] := flags.b;
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    { output length of GVR in offset field }
	    if t = general then { has ref pointer }
	      buffer^[bite] := 8
	    else
	      buffer^[bite] := 6;
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    { output value extension }
	    variantrec.l := loc;
	    for i := 0 to 3 do
	      begin
	      buffer^[bite] := variantrec.b[i];
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    if t = general then { has ref pointer }
	      begin
	      variantrec.l := extnumber + 1;
	      for i := 2 to 3 do
		begin
		buffer^[bite] := variantrec.b[i];
		bite := bite + 1;
		if bite > 511 then dumpdefbuffer;
		end;
	      end;
	    end; { with defile }
	end; { outputdef }

      procedure outputextdef(name: alpha;
			     loc: addrrange;
			     ext: alpha);
	{ output a def which references an ext }
	var
	  i,extnumber: shortint;
	  found: boolean;
	  globalnametemp: alphaptr;
	begin
	if ext = currentglobal^ then
	  extnumber := 4 {global delta }
	else
	  begin
	  extnumber := 8;
	  found := false;
	  i := 1;
	  while (i < def_ext_top) and not found do
	    begin
	    if def_ext_table[i] = ext then
	      found := true
	    else
	      extnumber := extnumber +
		   strlen(def_ext_table[i]) + 4 -
		   (strlen(def_ext_table[i]) mod 4);
	    i := i + 1;
	    end;
	  if not found then
	    if def_ext_top <= max_module_nesting then
	      begin
	      def_ext_table[def_ext_top] := ext;
	      def_ext_top := def_ext_top + 1;
	      end
	    else
	      error(663); { poor error number }
	  end;
	{ output def without module name prefix }
	globalnametemp := curglobalname;
	curglobalname := NIL;
	outputdef(name,loc,general,extnumber);
	curglobalname := globalnametemp;
	end;

      procedure codewrapup (* term: termtype *);

	procedure libraryheader;
	  begin
	    with libraryptr^[0] do
	      begin
	      dfirstblk := 0;
	      dlastblk := 2;
	      dfkind := untypedfile;
	      if strlen(outerblock^.namep^) > vnlength then
		outerblock^.namep^[0] := chr(vnlength);
	      dvid := outerblock^.namep^;
	      deovblk := dlastblk - 1;
	      dnumfiles := nextmodule - 1;
	      dloadtime := 0;
	      dlastboot:= globaldate;
	      end;
	    if blockwrite(codephile.fileid,libraryptr^,2,0) <> 2 then
	      begin ioresult := ord(zcatchall); escape(-10); end;
	  end;

	begin { codewrapup }
	  if (term = normal) and codeout and
	     (totalerrors = 0) then
	    begin
	    libraryheader;
	    close(codephile.fileid,'lock');
	    if ioresult <> 0 then
	      escape(-10);
	    with userinfo^ do
	      begin
	      gotcode := true;
	      codefid := file_name;
	      end;
	    end
	  else
	    begin
	    writeln;
	    writeln('No codefile generated.');
	    close(codephile.fileid,'purge');
	    end;
	  close(refile.fileid,'purge');
	  close(defile.fileid,'purge');
	end;

      procedure endofcode;
	{ append current memory code buffer to code file }
	var
	  numberofblocks,
	  block: shortint;
	begin
	if totalerrors = 0 then
	  with codephile do
	    begin
	    numberofblocks := (bytecount - windowptr + 511) DIV 512;
	    if numberofblocks > 0 then
	      begin
	      block := startblock + windowptr DIV 512;
	      if not codefileopen then
		begin
		reset(fileid,file_name);
		close(fileid,'PURGE');  { Purge any existing file }
		fmaketype(fileid,file_name,
			  nullstring,dot_code);
		codefileopen := true;
		end;
	      if blockwrite(fileid,buffer^,numberofblocks,block)
							    <> numberofblocks
		then file_warn(906,ioresult);
	      end;
	    end;
	end; { endofcode }

      procedure importexportstart(s: alphaptr);
	var
	  i: shortint;
	const
	  modu = 'MODULE ';
	begin
	if putcode and (totalerrors = 0) then
	  begin
	  for i := 1 to 7 do
	    outputcodebyte(ord(modu[i]));
	  for i := 1 to strlen(s^) do
	    outputcodebyte(ord(s^[i]));
	  outputcodebyte(ord(';'));
	  outputcodebyte(13{EOL});
	  end;
	end;

      procedure outputsymbol;
	{ Output the symblo that is between
	  symbolstart and symcursor.  Do not
	  let the symbol cross a block boundry
	  on the code file. }

	var
	  symbolsize,i: shortint;
	begin
	if putcode and (totalerrors = 0) then
	  with codephile do
	    begin
	    symbolsize := symcursor - symbolstart - 1;
	    if odd(bytecount DIV 512) and
	       ((bytecount+symbolsize+2) DIV 512 >
	       bytecount DIV 512) then
		 begin
		 outputcodebyte(13{EOL});
		 outputcodebyte(0);
		 end;
	    if (bytecount+symbolsize+1) DIV 512 > bytecount DIV 512 then
	      begin
	      while (bytecount+symbolsize+1) DIV 512 >
		    (bytecount+1) DIV 512 do
		outputcodebyte(32{blank});
	      outputcodebyte(13{EOL});
	      end;
	    for i := symbolstart to symcursor-1 do
	      outputcodebyte(ord(symbuf[i]));
	    end;
	end;

      procedure importexportwrapup;
	begin
	with codephile do
	  begin
	  if putcode and (totalerrors = 0) then
	    begin
	    if odd(bytecount DIV 512) and
	       ((bytecount+6) DIV 512 >
		bytecount DIV 512) then
	      outputcodebyte(0);
	    while (bytecount+6) DIV 512 >
		   bytecount DIV 512 do
	      outputcodebyte(32{blank});
	    outputcodebyte(ord('E'));
	    outputcodebyte(ord('N'));
	    outputcodebyte(ord('D'));
	    outputcodebyte(ord(';'));
	    outputcodebyte(13{EOL});
	    outputcodebyte(3);  { import export text terminator }
	    sourcesize := bytecount;
	    endofcode;
	    startblock := startblock +
			(sourcesize+511) DIV 512;
	    end;          { dump buffer to file }
	  bytecount := 0;
	  windowptr := 0;
	  modulecodeout := false;
	  end;
	end;

      procedure modulewrapup(countglobals: boolean);
	type
	  extptr = ^extentry;
	  extentry = record
		       nextext: extptr;
		       name: alpha;
		     end;
	var
	  curglobaltemp: alphaptr;
	  exttop: extptr;

	function extaddress (var name: alpha) : integer;
	  { search the exttable for "name" and return its position.
	    If it is not in the table put it at the end and return
	    its position. }
	  var
	    exptr: extptr;
	    done: boolean;
	    result: integer;
	    i: shortint;
	  begin
	    result := 8; { first two entries are reserved }
	    if exttop = NIL then
	      begin
	      newwords(exttop,(strlen(name)+2) DIV 2 + 4);
	      { cannot use normal string assignment for name field }
	      for i := 0 to strlen(name) do
		exttop^.name[i] := name[i];
	      exttop^.nextext := NIL;
	      end
	    else
	      begin
	      exptr := exttop;
	      done := false;
	      repeat
		if exptr^.name = name then done := true
		else
		  begin
		  result := result + strlen(exptr^.name) + 4
				   - (strlen(exptr^.name) MOD 4);
		  if exptr^.nextext = NIL then
		    begin
		    newwords(exptr^.nextext,(strlen(name)+2) DIV 2 + 4);
		    { cannot use string assignment for name field }
		    for i := 0 to strlen(name) do
		      exptr^.nextext^.name[i] := name[i];
		    exptr^.nextext^.nextext := NIL;
		    done := true;
		    end;
		  end;
		exptr := exptr^.nextext;
	      until done;
	      end;
	    extaddress := result;
	  end; { extaddress }

	procedure copydefs;
	  { append defile to codefile }
	  var
	    dontcare,i: shortint;
	    alphavar: alpha;
	  begin
	    with defile do
	      begin
	      defstartblock := codephile.startblock+totalbytesofcode DIV 512 + 1;
	      sizeofdefs := block * 512 + bite;
	      if block <> 0 then { dump last def block to defile }
		begin
		if bite > 0 then
		  begin
		  if blockwrite(fileid,buffer^,1,block) <> 1 then
		    file_warn(908,ioresult);
		  end
		else
		  begin
		  block := block - 1;
		  bite := 512;
		  end;
		if blockread(fileid,buffer^,1,0) <> 1 then
		  begin ioresult := ord(zcatchall); escape(-10); end;
		end;
	      if (block <> 0) or (bite <> 0) then
		for i := 0 to block do
		  begin
		  if blockwrite(codephile.fileid,buffer^,1,defstartblock+i) <> 1
		    then file_warn(906,ioresult);
		   if i <> block then
		    if blockread(fileid,buffer^,1,i+1) <> 1 then
		      begin ioresult := ord(zcatchall); escape(-10); end;
		  end; { for }
	      end;
	      for i := 1 to def_ext_top - 1 do
		begin
		alphavar := def_ext_table[i];
		dontcare := extaddress(alphavar);
		end;
	  end; { copydefs }

	procedure copyrefs;
	  var
	    copyblock,copybite: shortint;
	    flags: flagtype;
	    previousref: addrrange;

	  procedure copyexts;
	    var
	      exptr: extptr;
	      i: shortint;
	    begin { copyexts }
	      with codephile do { use codefile buffer routines for exts }
		begin
		extstartblock := refstartblock + (sizeofrefs + 511) DIV 512;
		sizeofexts := 8; { first 8 bytes are reserved }
		bytecount := (extstartblock - startblock) * 512;
		windowptr := bytecount;
		bytecount := bytecount + 8;
		exptr := exttop;
		while exptr <> NIL do
		  begin
		  sizeofexts := sizeofexts + strlen(exptr^.name) + 4
			      - (strlen(exptr^.name) MOD 4);
		  {upc(exptr^.name);         DELETED 4/12/84 }
		  for i := 0 to strlen(exptr^.name) do
		    outputcodebyte(ord(exptr^.name[i]));
		  for i := 1 to 3 - strlen(exptr^.name) MOD 4 do
		    outputcodebyte(0);
		  exptr := exptr^.nextext;
		  end;
		endofcode; { dump codefile buffer to the file }
		end;
	    end; { copyexts }

	  procedure copy1ref;
	    var
	      name: alpha;
	      relativetoprevious: addrrange;
	      extoffset: integer;
	      flags: flagtype;
	      t: reftype;
	      i: shortint;
	      variantrec2,
	      variantrec: record case boolean of
			    true: (l: integer);
			    false: (b: packed array[0..3] of byt);
			  end;

	    procedure bumprefbuffer;
	      { Not to be confused with dumprefbuffer.  This routine
		handles the buffering for reading in the temporary
		ref file. }
	      begin
	      copyblock := copyblock + 1;
	      copybite := 0;
	      with refile do
		if (block <> copyblock) or (bite <> 0) then
		  if blockread(fileid,buffer^,1,copyblock) <> 1 then
		    begin ioresult := ord(zcatchall); escape(-10); end;
	      end; { bumprefbuffer }

	    begin
	      with refile do
		begin
		name[0] := chr(buffer^[copybite]);
		copybite := copybite + 1;
		if copybite > 511 then bumprefbuffer;
		for i := 1 to ord(name[0]) do
		  begin
		  name[i] := chr(buffer^[copybite]);
		  copybite := copybite + 1;
		  if copybite > 511 then bumprefbuffer;
		  end;
		if strlen(name) <> 0 then extoffset := extaddress(name);
		t := reftype(buffer^[copybite]);
		copybite := copybite + 1;
		if copybite > 511 then bumprefbuffer;
		for i := 0 to 3 do
		  begin
		  variantrec.b[i] := buffer^[copybite];
		  copybite := copybite + 1;
		  if copybite > 511 then bumprefbuffer;
		  end;
		relativetoprevious := variantrec.l - previousref;
		previousref := variantrec.l;
		with flags do
		  begin
		  if t = rel16v then valueextend := true
				else valueextend := false;
		  case t of
		    abs16:
		      begin
		      if strlen(name) = 0 then typ := relocatable
					  else typ := general;
		      size := sw;
		      patchable := false;
		      end;
		    abs32:
		      begin
		      if strlen(name) = 0 then typ := relocatable
					  else typ := general;
		      size := sl;
		      patchable := false;
		      end;
		    rel16,rel16v:
		      begin
		      typ := general;
		      size := sw;
		      patchable := true;
		      end;
		    glob16:
		      begin
		      typ := global;
		      size := sw;
		      patchable := false;
		      end;
		    rel32:
		      begin
		      typ := general;
		      size := sl;
		      patchable := false;
		      end;
		  end;
		  if relativetoprevious < 256 then longoffset := false
					      else longoffset := true;
		  end; { with flags }
		outputcodebyte(flags.b);
		sizeofrefs := sizeofrefs + 1;
		if relativetoprevious < 256 then
		  begin
		  outputcodebyte(relativetoprevious);
		  sizeofrefs := sizeofrefs + 1;
		  end
		else
		  begin
		  variantrec2.l := relativetoprevious;
		  for i := 1 to 3 do outputcodebyte(variantrec2.b[i]);
		  sizeofrefs := sizeofrefs + 3;
		  end;
		if t = rel16v then
		  begin
		  variantrec.l := -variantrec.l;
		  for i := 0 to 3 do outputcodebyte(variantrec.b[i]);
		  sizeofrefs := sizeofrefs + 4;
		  end;
		if flags.typ = general then
		  begin
		  if not (t in [rel16,rel16v,rel32]) then {only one ref pointer (bit 0 on)}
		    extoffset := extoffset + 1;
		  outputcodeword(extoffset);
		  sizeofrefs := sizeofrefs + 2;
		  end;
		if t in [rel16,rel16v,rel32] then
		  begin
		  outputcodeword(3); { subtract recocation delta }
		  sizeofrefs := sizeofrefs + 2;
		  end;
		end;
	    end; { copy1ref }

	  begin { copyrefs }
	  with refile do
	    begin
	    refstartblock := defstartblock + (sizeofdefs + 511) DIV 512;
	    sizeofrefs := 0;
	    codephile.bytecount := (refstartblock - codephile.startblock) * 512;
	    codephile.windowptr := codephile.bytecount;
	    if block <> 0 then { dump lst ref block to refile }
	      begin
	      if bite > 0 then
		if blockwrite(fileid,buffer^,1,block) <> 1 then
		  file_warn(907,ioresult);
	      if blockread(fileid,buffer^,1,0) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	    previousref := 0;
	    copyblock := 0; copybite := 0;
	    while (copyblock <> block) or (copybite <> bite) do copy1ref;
	    endofcode; { dump codefile buffer^ to the file }
	    copyexts;
	    end;
	  end; { copyrefs }

	procedure fixheaderecord;
	  { output a module header at the beginning of the codefile }

	  var
	    i,j: shortint;
	    variantrec: record case boolean of
			  true: (l: addrrange);
			  false: (b: packed array[0..3] of byt);
			end;
	    directory: module_directory;

	  begin
	    with directory do
	      begin
	      date := globaldate;
	      revision := crevid;
	      { produced by compiler }
	      if modcal then producer := 'M'
			else producer := 'P';
	      system_id := ord(crevno[1]) - ord('0');
	      notice := gcopyright;
	      executable := (startaddr <> -1); { -1 means no main program }
	      relocatable_size := totalbytesofcode;
	      relocatable_base := 0;
	      if countglobals then
		begin
		if curproc = outerblock then global_size := -lcmax
		else global_size := -lc;
		end
	      else global_size := 0;
	      global_base := 0;
	      ext_block := extstartblock - codephile.headerblock;
	      ext_size := sizeofexts;
	      def_block := defstartblock - codephile.headerblock;
	      def_size := sizeofdefs;
	      source_block := sourceblock;
	      source_size := sourcesize;
	      text_records := 1;
	      morebytes[0] := strlen(currentglobal^);
	      for i := 1 to morebytes[0] do
		morebytes[i] := ord(currentglobal^[i]);
	      {even byte allign}
	      i := morebytes[0] + 1 + ord(not odd(morebytes[0]));
	      if startaddr <> -1 then { put out start address }
		begin
		morebytes[i] := 82; { signed long, relocatable, value extend }
		i := i + 1;
		morebytes[i] := 6;  { offset = 6 }
		i := i + 1;
		variantrec.l := startaddr;
		for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
		i := i + 4;
		end;
	      variantrec.l := codephile.startblock - codephile.headerblock;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := totalbytesofcode;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := refstartblock - codephile.headerblock;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := sizeofrefs;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      { load address general value record (gvr) }
	      morebytes[i] := 82; { signed long, relocatable, value extend }
	      i := i + 1;
	      morebytes[i] := 6;  { offset = 6 }
	      i := i + 1;
	      for j := 0 to 3 do morebytes[i+j] := 0;
	      i := i + 4;
	      directory_size := fixedpart + i;
	      module_size := ((extstartblock - codephile.headerblock)
			   + (sizeofexts + 511) DIV 512) * 512;
	      end; { with directory }
	    with codephile do
	      begin
	      if blockwrite(fileid,directory,1,headerblock) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      with libraryptr^[nextmodule] do
		begin
		dfirstblk := headerblock;
		dlastblk := headerblock + directory.module_size DIV 512;
		if strlen(currentglobal^) > fnlength then
		  currentglobal^[0] := chr(fnlength);
		dtid := currentglobal^;
		{ no. of bytes in last block }
		dlastbyte := ((sizeofexts-1) MOD 512) + 1;
		daccess := globaldate;
		dfkind := codefile;
		headerblock := dlastblk;
		end;
	      end; { with codephile }
	    if nextmodule + 1 <= maxdir then
	      nextmodule := nextmodule + 1
	    else error(705);
	  end; { fixheaderecord }

	begin { modulewrapup }
	if totalerrors = 0 then
	  if modulecodeout then
	    begin
	    if countglobals then
	      begin
	      curglobaltemp := curglobalname;
	      curglobalname := NIL;
	      outputdef(currentglobal^,0,global,0);
	      curglobalname := curglobaltemp;
	      end;
	    totalbytesofcode := codephile.bytecount;
	    endofcode;          { dump all buffered code bytes to the file }
	    exttop := NIL;
	    copydefs;           { append all defs to the end of the code file }
	    copyrefs;           { append all refs to the end of the code file }
	    fixheaderecord;     { fix up the module header information }
	    codeout := true;
	    end;
	end; { modulewrapup }

      procedure pactos(plgth: shortint; var pa: pachstring; var s: string);
	begin
	s[0] := chr(plgth);
	moveleft(pa[1],s[1],plgth);
	end;

      procedure callstdproc( s: alpha );
	var lattr: attrtype;
	begin
	lattr.callmode := callmode;
	with lattr do
	  begin
	  addrmode := namedconst; offset := 0;
	  new(constptr);
	  with constptr^ do
	    begin isdumped := false; newident(namep,s) end;
	  end;
	emit1(jsr,lattr);
	end;

      procedure callIOproc( s: alpha );
	var op: attrtype;
	begin callstdproc(s);
	if iocheck then
	  begin
	  with SBind do
	    begin
	    storage := long;
	    offset := ioresultptr^.vaddr;
	    gloptr := sysglobalptr;
	    end;
	  emit1(tst,SBind);
	  SBind.gloptr := NIL;
	  with op do begin storage := bytte; offset := 2 end;
	  emit1(beq,op);
	  op.smallval := 3;
	  emit1(trap,op);
	  end;
	end; {callIOproc}

      procedure getprokconst(fprocp: ctp; var at: attrtype);
	var
	  nametemp: alpha;
	begin
	at.callmode := callmode;
	with at do
	  begin addrmode := namedconst;
	  storage := long; offset := 0;
	  new(constptr);
	  with constptr^ do
	    if fprocp^.alias then
	      begin
	      namep := fprocp^.othername;
	      fprocp^.isrefed := true;
	      isdumped := false;
	      end
	    else if fprocp^.isdumped then
	      begin
	      isdumped := true;
	      location := fprocp^.location;
	      end
	    else
	      begin
	      if not fprocp^.extdecl and
		 not fprocp^.isexported then
		nametemp := itostr(fprocp^.forwid) +
			    fprocp^.namep^
	      else nametemp := fprocp^.namep^;
	      if fprocp^.othername <> NIL then
		newident(namep,
		  fprocp^.othername^ +
		  '_' + nametemp)
	      else
		newident(namep,nametemp);
	      fprocp^.isrefed := true;
	      isdumped := false;
	      end;
	  end;
	end; {getprokconst}

      procedure getbrattr
		    {var flbl: addrrange; defined: boolean; var battr: attrtype};
	{ Returns attributes for a Bcc instruction in battr^.
	  If defined, the branch is backward to flbl.
	  Otherwise, the PC, byte, and block numbers for the forward reference
	  are returned in flbl }
	var
	  PCtemp: addrrange;
	begin
	  PCtemp := codephile.bytecount + 2;
	  with battr do
	    if defined then
	      begin
	      offset := flbl - PCtemp;
	      if offset >= -128 then storage := bytte
	      else storage := wrd;
	      end
	    else
	      begin
	      offset := 0; storage := wrd;
	      flbl := PCtemp;
	      end;
	end; {getbrattr}

      procedure emitstringlit(sp: csp);
	var s: 0..strglgth;
	begin
	  with sp^ do
	    begin
	    s := 0;
	    if slgth = 0 then outputcodeword(0)
	    else while s < slgth do
	      begin
		if s=0 then if cclass = STRNG then
		  outputcodebyte(slgth);
		s := s+1; outputcodebyte(ord(sval[s]));
	      end;
	    if odd(codephile.bytecount) then outputcodebyte(0);
	    end;
	end; {emitstringlit}

      procedure getmultattr(* rcount: shortint; A1isfree: boolean;
							   var at: attrtype *);
	{get register list attributes for move multiple using 'rcount'
	 registers.  Assumes D0-D7 and A2-A5 are available; use of A1 is
	 controlled by 'A1isfree'}

	const numDregs = 8;
	  minmove = 2;
	  maxmove = 13;
	var
	  i : shortint;
	  j : regtype;
	begin
	  if (rcount < minmove) or (rcount > maxmove-1+ord(A1isfree)) then
	    escape(-8);
	  with at do
	    begin
	    for j := A to D do
	      for i := 0 to 7 do
		regs[j,i] := false;
	    addrmode := multiple;
	    if rcount <= numDregs then
	      for i := 0 to rcount-1 do regs[D,i] := true
	    else
	      begin
	      for i := 0 to numDregs-1 do regs[D,i] := true;
	      for i := (2-ord(A1isfree)) to (rcount-numDregs+1-ord(A1isfree)) do
		regs[A,i] := true;
	      end;
	    end; { with at }
	end; {getmultattr}

      procedure emitshift(*shiftcount: bitrange; reg: regrange;
			  shiftype: opcodetype; shiftsize: stortype*);
	var
	  shiftemp : regrange;
	  opnd1,
	  opnd2 : attrtype;
	begin
	  if shiftcount <> 0 then
	    if shiftcount > 8 then begin
	      shiftemp := getreg(D);
	      opnd1.smallval := shiftcount;
	      with opnd2 do
		begin addrmode := inDreg; regnum := shiftemp; end;
	      emit2(moveq,opnd1,opnd2);
	      with opnd1 do
		begin
		addrmode := inDreg; regnum := reg; storage := shiftsize;
		end;
	      emit2(shiftype,opnd2,opnd1);
	      freeit(D,shiftemp);
	      end
	    else begin
	      with opnd1 do
		begin addrmode := immediate; smallval := shiftcount; end;
	      with opnd2 do
		begin
		addrmode := inDreg; regnum := reg; storage := shiftsize;
		end;
	      emit2(shiftype,opnd1,opnd2);
	      end;
	end; {emitshift}

      procedure getmask(bitoffset,bitsize,masksize: shortint; var mask:integer);
	{ Games are played here because 32 bit UNSIGNED math is not available }
	var
	  topbit : (on,off);
	  variantrec : packed record case boolean of
			 true: (i: integer);
			 false: (bit1: 0..1);
		       end;
	begin
	  mask := 0;
	  if bitsize <> 0 then
	    begin
	    bitoffset := bitoffset + (32-masksize);
	    if bitoffset = 0 then { avoid 32 bit math overflow }
	      begin
	      topbit := on;
	      bitoffset := 1;
	      bitsize := bitsize - 1;
	      end
	    else
	      topbit := off;
	    if bitsize = 31 then mask := maxint
	    else
	      begin
	      if bitsize = 0 then mask := 0
	      else
		mask := (power_table[bitsize]-1) *
					   power_table[32-(bitoffset + bitsize)];
	      if topbit = on then { turn on sign bit in mask}
		begin
		variantrec.i := mask;
		variantrec.bit1 := 1;
		mask := variantrec.i;
		end;
	      end;
	    end;
	end; { getmask }

      procedure getcomplmaskattr(* bitoffset, bitsize, masksize: shortint;
							    var at :attrtype *);
	begin
	  getmask(bitoffset,bitsize,masksize,at.smallval);
	  with at do
	    begin
	    if smallval = maxint then smallval := minint
	    else smallval := -(smallval + 1);                 { 1's complement }
	    case masksize of
	      8: storage := bytte;
	     16: storage := wrd;
	     32: storage := long;
	    end; {case}
	    addrmode := immediate;
	    end;
	end; { getcomplmaskattr }

      procedure getmaskattr (* bitoffset, bitsize, masksize: shortint;
							  var at : attrtype *);
	begin
	  getmask(bitoffset,bitsize,masksize,at.smallval);
	  with at do
	    begin
	    case masksize of
	      8: storage := bytte;
	     16: storage := wrd;
	     32: storage := long;
	    end; {case}
	    addrmode := immediate;
	    end;
	end;

      procedure dumpstconst(*fsp: stp; var fvalu: valu*);
	{ Inserts structured constant into code file.
	  Modified for M68K by Sam Sands;
	  original VPM version by Donn Terry}

	const
	  wbytes = 2;       {number of bytes in a DC.W}
	  lbytes = 4;       {number of bytes in a DC.L}

	var
	  offset: addrrange;  {bytes generated so far}
	  packbuf:  shortint; {16 bit (DC.W) code bit buffer}
	  packbit:  shortint; {number of bits in packword}
	  curglobaltemp: alphaptr;

	procedure flush;  {output the code bit buffer}
	  var
	    variantrec: packed record case boolean of
			  true: (w: shortint);
			  false: (b1: byt;
				  b2: byt);
			end;
	  begin
	  if packbit >0 then
	    if packbit > 8 then
	      begin
	      outputcodeword(packbuf);
	      offset := offset + wbytes;
	      end
	    else
	      begin
	      variantrec.w := packbuf;
	      outputcodebyte(variantrec.b1);
	      offset := offset + 1;
	      end;
	  packbuf := 0;
	  packbit := 0;
	  end;

	procedure dmpcnst(fsp: stp; fvalu: valu;
			 packing: boolean;
			 posn, width: shortint);
$if bigsets$
	   const
		oldsetwordsize = (oldsethigh + 1 + setelemsize - 1)
				div setelemsize;
$end$

	  var
	    vctmp: vcref;
	    i,w,b: integer;
	    setsize: shortint;
	    variantrec: record case boolean of
			  true: (r: real);
			  false: (l1: integer;
				  l2: integer);
			end;
$if bigsets$
	   s : setrecptr;       (* current set record item *)
	   j : shortint;        (* simple local counter *)
	   limit : shortint;    (* ordinal limit for set rec *)
	   variantset : record case boolean of
			   true: (sett: set of setlow..oldsethigh);
			   false: (pad: shortint;
				  words: packed array
					   [0..oldsetwordsize-1] of shortint)
			 end;
$end$

	  procedure outbyte(i: shortint);        {output a bool or a char}
	    begin
	    flush;
	    outputcodebyte(i);                  { DC.B }
	    offset := offset + 1;
	    end;

	  procedure outword(i: shortint);   {output an enumerated type}
	    begin
	    flush;
	    outputcodeword(i);                  { DC.W }
	    offset := offset + wbytes;
	    end;

	  procedure outlong(i: integer);
	    begin
	    flush;
	    outputcodelong(i);                  { DC.L }
	    offset := offset + lbytes;
	    end;

	  procedure outpacked(i: integer);        {pack a 32 bit quantity}

	  var z,j: integer;

	  begin  {outpacked}
	    if posn = 0 then
	      begin
	      flush;        {starting over}
	      if width > 16 then
		if odd(offset) then outbyte(0);
	      end;
	    if posn >= 16 then posn := posn - 16;
	    packbit := posn + width;       {right end of field}
	    if packbit > 32 then
	      begin
	      flush;
	      if odd(offset) then outbyte(0);
	      posn := 0;
	      packbit := width;
	      end;
	    if width < 32 then
	      begin
	      if i < 0 then i := i - minint;
	      if width < 31 then
		begin
		z := 1;
		for j:= 1 to width do z := z + z;
		i := i mod z;
		end;
	      end;
	    z := i;
	    j := 16 - packbit;
	    while j<0 do begin if z < 0 then z := (z + 32768) div 2 + 16384
			       else z := z div 2;
			       j := j + 1;
			 end;
	    while j>0 do begin if z < 16384 then z := z + z
			       else z := (z - 16384)*2 - 32768;
			       j := j - 1;
			 end;
	    packbuf := packbuf + z;
	    if packbit >= 16 then
	      begin flush;
		    width := width - (16 - posn);
		    posn := 16;
		    if width > 0 then outpacked(i);
	      end;
	  end; {outpacked}

	  procedure outputpaoc
		      (aisstrng: boolean;
		       unpacksize: integer;
		       lgth: integer;
		       anyvar val: bigpac);
	  var
	    i: shortint;
	  begin
	  flush;
	  if odd(offset) then outbyte(0);
	  if aisstrng then
	    begin
	    outputcodebyte(lgth);        { DC.B }
	    offset := offset + 1;
	    end;
	  for i := 1 to lgth do
	    begin
	    $RANGE OFF$
	    outputcodebyte(ord(val[i])); { DC.B }
	    $IF rangechecking$
	    $RANGE ON$
	    $END$
	    offset := offset + 1;
	    end;
	  for i := lgth + 1 to
	      unpacksize-ord(aisstrng) do
	    begin
	    outputcodebyte(ord(' '));     { DC.B }
	    offset := offset + 1;
	    end;
	  end; {outputpaoc}

	  procedure dumparray;
	  var
	    elpos: bitrange;
	    i: integer;

	    procedure innerarray;
	    begin
	      with fvalu.valp^.kstruc^ do
		begin vctmp := scvcp;
		elpos := 0;
		while vctmp <> NIL do
		  with scstp^,vctmp^ do
		    begin
		    if aispackd then
		      begin
		      dmpcnst(aeltype,vcval,true,elpos,aelbitsize);
		      elpos := elpos+aelbitsize;
		      if elpos+aelbitsize > bitsperword then elpos := 0;
		      end
		    else
		      begin
		      dmpcnst(aeltype,vcval,false,0,0);
		      if aelsize <> aeltype^.unpacksize then
			outbyte(0);
		      end;
		    vctmp := vctmp^.vcnxt;
		    end;
		end;
	    end; {inner array}

	  begin {dumparray}
	  flush;
	  if odd(offset) then outbyte(0);
	  with fvalu.valp^.kstruc^ do
	    if (scstp^.aeltype = char_ptr) and scstp^.aispackd then
	      if scvcp^.vcval.valp^.cclass = paofch then
		{packed array of char literal is treated specially}
		with scvcp^.vcval.valp^ do
		  outputpaoc(fsp^.aisstrng,
			     fsp^.unpacksize,
			     slgth,
			     sval)
	      else if scvcp^.vcval.valp^.cclass = bigpaoc then
		{big packed array of char literal is treated specially}
		with scvcp^.vcval.valp^ do
		  outputpaoc(fsp^.aisstrng,
			     fsp^.unpacksize,
			     paoclgth,
			     paocval)
	      else {not paofch literal} innerarray
	    else {not pa of char type} innerarray;
	  flush;
	  end; {dumparray}

	procedure dumprecord;
	  var end_offset: addrrange;   {for short variants}
	      k: integer;
	      fieldbit: bitrange;
	  begin {inner record}
	  with fvalu.valp^.kstruc^ do
	    begin
	    flush;
	    if (scstp^.align <> 1) and odd(offset) then outbyte(0);
	    end_offset:=offset+scstp^.unpacksize;
	    vctmp := scvcp;
	    while vctmp <> NIL do
	      begin
	      with vctmp^ do
	      if vid <> NIL then
		with vid^ do
		begin
		if fispackd then
		  begin
		  if scstp^.unpacksize <> 1 then
		    fieldbit := (fldfbit+(8*ord(odd(offset)))) MOD 16
		  else fieldbit := fldfbit;
		  dmpcnst(idtype,vcval,true,
		       fieldbit,idtype^.bitsize);
		  end
		else dmpcnst(idtype,vcval,false,0,0);
		vctmp := vctmp^.vcnxt;
		end
	      end;
	    if end_offset>offset then flush;
	    if end_offset>offset then
		begin {fill out remainder of short variant}
		  {  DS.B end_offset-offset }
		  for k := 1 to end_offset-offset do outputcodebyte(0);
		  offset := end_offset;
		end;
	    end;
	  end; {dumprecord}

	  begin {dmpcnst}
	  if fsp <> NIL then
	    with fvalu do
	      begin
	      if fsp^.form = subrange then fsp := fsp^.rangetype;
	      if fsp^.form = scalar then
		if packing then outpacked(ival)
		else {not packing}
		  if (fsp = boolptr) or (fsp = char_ptr) then outbyte(ival)
		  else if fsp = intptr then
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    outlong(ival);
		    end
		  else
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    if intval {enumerated type or shortint} then
		      outword(ival)
		    else escape(-8);
		    end
	      else if fsp^.form = pointer then
		begin
		flush;
		if odd(offset) then outbyte(0);
		offset := offset+4;
		outputcodelong(0); { DC.L 0  (nilvalue = 0) }
		end
	      else if fsp^.form = reals then
		begin
		flush;
		if odd(offset) then outbyte(0);
		variantrec.r := fvalu.valp^.rval;
		outlong(variantrec.l1);
		outlong(variantrec.l2);
		end
	      else {not a scalar or pointer} if valp <> NIL then
		with valp^ do
		case cclass of
		  strctconst:  {structure within the structure}
			if kstruc <> NIL then
			  with kstruc^ do
			  if scstp <> NIL then
			    case scstp^.form of
			      arrays: dumparray;
			      records: dumprecord;
			      power:
				if scvcp <> NIL then
				  with scvcp^ do
				    dmpcnst(scstp,vcval,packing,posn,width)
			    end; {case form}
		  pset:
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    setsize := ((plgth+setelembits-1) div setelembits)
						* setelemsize;
		    outword(setsize);           (* size in bytes *)
$if bigsets$
		  if plgth > 0 then
		   begin
		   s := pval;
		   while s <> NIL do
		    with s^ do
		     begin
		       variantset.pad := 0;
		       for j := 0 to oldsetwordsize-1 do
			  variantset.words[j] := 0;
		       variantset.sett := val;
		       if nxt = NIL then (* last set record *)
			 limit := (plgth-1) MOD (oldsethigh+1)
		       else limit := oldsethigh;
		       for j := 0 to (limit div setelembits) do
			 outword(variantset.words[j]);
		       s := nxt;
		     end;
		   end;
$end$
$if not bigsets$
		    for w:=0 to mydiv(plgth-1,setelembits) do
		      begin
			if w*16 in pval then packbuf:=packbuf+(-32768);
			b:=1;
			for i:=15 downto 1 do
			  begin
			    if (w*16)+i in pval then
			       packbuf:=packbuf+b;
			    if i>1 then b:=b+b;
			  end;
			outword(packbuf); packbuf:=0;
		      end;
$end$
		    for w := 1 to fsp^.unpacksize - (setsize+setlensize) do
		      outbyte(0);
		    end;
		  paofch:
		    outputpaoc(fsp^.aisstrng,
			       fsp^.unpacksize,
			       slgth,
			       sval);
		  bigpaoc:
		    outputpaoc(fsp^.aisstrng,
			       fsp^.unpacksize,
			       paoclgth,
			       paocval);
		  otherwise error(682)
		  end {case cclass};
	      end; {with fvalu}
	  end; {dmpcnst}

	begin {dumpstconst}
	if (fsp <> NIL) and putcode
	   and (totalerrors = 0) then
	  begin
	  with fvalu.valp^ do
	    begin isdumped := true;
	    if (namep <> NIL) and (level = 1) then
	      begin
	      curglobaltemp := curglobalname;
	      curglobalname := NIL;
	      outputdef(namep^,codephile.bytecount,relocatable,0);
	      curglobalname := curglobaltemp;
	      end;
	    location := codephile.bytecount;
	    end;
	  offset := 0;
	  packbit := 0;
	  packbuf := 0;
	  dmpcnst(fsp,fvalu,false,0,0);
	  flush;
	  if odd(codephile.bytecount) then outputcodebyte(0);
	  end;
	end; {dumpstconst}

      function insertnode (fconexp : csp; var fpoolptr : csp) : csp;
	 { add constant to pool list }
	 begin {insertnode}
	   with fconexp^ do
	     begin
	     insertnode := fconexp; conlbl := NIL;
	     next := fpoolptr ; fpoolptr := fconexp;
	     end {with}
	 end; {insertnode}

      $IF MC68020$
      function insertwrdpair(fconexp : csp; var fwrdpairptr : csp): csp;
	{ add word size bound pair to pool list }
	begin
	with fconexp^ do
	  begin
	  if fwrdpairptr = NIL then
	    insertwrdpair := insertnode(fconexp,fwrdpairptr)
	  else if lower < fwrdpairptr^.lower then
	    insertwrdpair := insertnode(fconexp,fwrdpairptr)
	  else if lower = fwrdpairptr^.lower then
	    begin
	    if upper < fwrdpairptr^.upper then
	      insertwrdpair := insertnode(fconexp,fwrdpairptr)
	    else if upper = fwrdpairptr^.upper then
	      insertwrdpair := fwrdpairptr
	    else
	      insertwrdpair := insertwrdpair(fconexp,fwrdpairptr^.next)
	    end
	  else
	    insertwrdpair := insertwrdpair(fconexp,fwrdpairptr^.next);
	  end;
	end; { insertwrdpair }

      function insertlongpair(fconexp : csp; var flongpairptr : csp): csp;
	{ add long size bound pair to pool list }
	begin
	with fconexp^ do
	  begin
	  if flongpairptr = NIL then
	    insertlongpair := insertnode(fconexp,flongpairptr)
	  else if lower < flongpairptr^.lower then
	    insertlongpair := insertnode(fconexp,flongpairptr)
	  else if lower = flongpairptr^.lower then
	    begin
	    if upper < flongpairptr^.upper then
	      insertlongpair := insertnode(fconexp,flongpairptr)
	    else if upper = flongpairptr^.upper then
	      insertlongpair := flongpairptr
	    else
	      insertlongpair := insertlongpair(fconexp,flongpairptr^.next)
	    end
	  else
	    insertlongpair := insertlongpair(fconexp,flongpairptr^.next);
	  end;
	end; { insertlongpair }
      $END$

       function insertreel(fconexp: csp; var freelptr: csp): csp;
	 {insert real constant in list, ordered according to value}
	 begin
	   with fconexp^ do
	     begin
	     if freelptr = NIL then insertreel := insertnode(fconexp,freelptr)
	     else if rval < freelptr^.rval
	       then insertreel := insertnode(fconexp,freelptr)
	     else if rval = freelptr^.rval {already in}
	       then insertreel := freelptr
	     else insertreel := insertreel(fconexp,freelptr^.next);
	     end;
	 end; {insertreel }

       function insertset (fconexp : csp; var fsetptr : csp) : csp;
	 { insert set constant in list, ordered according to length }
	 begin {insertset}
	   with fconexp^ do
	     begin
	       if fsetptr = NIL then insertset := insertnode(fconexp,fsetptr)
	       else if plgth < fsetptr^.plgth
		    then insertset := insertnode(fconexp,fsetptr)
	       else if (plgth = fsetptr^.plgth) and
		       (pval = fsetptr^.pval) { already in }
		    then insertset := fsetptr
	       else insertset := insertset(fconexp,fsetptr^.next)
	     end
	 end; {insertset}

       function insertstring (fconexp : csp; var fstrptr : csp) : csp;
	 var
	   lgth: 0..strglgth;

	 function scompare(length: shortint; var a,b: paoc): boolean;
	 var i: 0..strglgth; equal: boolean;
	 begin i:=0; equal:=true;
	   while (i<length) and equal do
	   begin i:=i+1; equal:= (a[i]=b[i]); end;
	   scompare := equal;
	 end;

	 { insert string constant in list, ordered according to length }
	 begin {insertstring}
	   with fconexp^ do
	     if fstrptr = NIL then insertstring := insertnode(fconexp,fstrptr)
	     else begin
	       lgth := fstrptr^.slgth;
	       if slgth < lgth
		    then insertstring := insertnode(fconexp,fstrptr)
	       else if (slgth = lgth) and
		      (cclass = fstrptr^.cclass) and
		      scompare(lgth,sval,fstrptr^.sval)
		    {already in}
		    then insertstring := fstrptr
	       else insertstring := insertstring(fconexp,fstrptr^.next)
	     end
	 end; {insertstring}

       function poolit ( konst : csp) : csp;
	 { add constant to pool, if not already in, and return
	   the csp for the constant in the pool }
	 begin {poolit}
	   case konst^.cclass of
	     paofch,
	     strng : poolit := insertstring(konst,stringhead);
	     pset : poolit := insertset(konst,sethead);
	     reel : poolit := insertreel(konst,reelhead);
	     $IF MC68020$
	     chk2_bounds : if konst^.size = wrd then
			     poolit := insertwrdpair(konst,wrdpairhead)
			   else {size = long}
			     poolit := insertlongpair(konst,longpairhead);
	     $END$
	     otherwise escape(-8);
	   end {case}
	 end; {poolit}

       procedure poolenum(* fsp: stp *);
	 label 1;
	 var lsp: stp;
       begin lsp := enumhead;
       while lsp <> NIL do
	 if lsp = fsp then goto 1
	 else lsp := lsp^.next;
       fsp^.next := enumhead;
       fsp^.enumlbl := NIL;
       enumhead := fsp;
    1: end;

       procedure dumpconsts;
	 { emit the constant pool }
$if bigsets$
	 const
		oldsetwordsize = (oldsethigh + 1 + setelemsize - 1)
					div setelemsize;
$end$
	 var
	   w : shortint;
	   p : csp;
$if bigsets$
	   s : setrecptr;       (* current set record item *)
	   j : shortint;        (* simple local counter *)
	   limit : shortint;    (* ordinal limit for set rec *)
	   variantrec : record case boolean of
			   true: (sett: set of setlow..oldsethigh);
			   false: (pad: shortint;
				  words: packed array
					   [0..oldsetwordsize-1] of shortint)
			 end;
$end$
$if not bigsets$
	   variantrec : record case boolean of
			  true: (sett: set of setlow..sethigh);
			  false: (pad: shortint;
				  words: packed array[0..15] of shortint);
			end;
$end$
	   variant : record case boolean of
		       true: (r: real);
		       false: (l1: integer;
			       l2: integer);
		     end;

	 procedure dumpenum;
	   var lcp: ctp; k: shortint;
	   begin
	   while enumhead <> NIL do
	     begin fixreflist(enumhead^.enumlbl);
	     lcp := enumhead^.fconst;
	     k := 0;
	     while lcp <> NIL do {count 'em}
	       begin k := k+1;
	       lcp := lcp^.next;
	       end;
	     outputcodeword(k);
	     lcp := enumhead^.fconst;
	     while lcp <> NIL do
	       with lcp^ do
		 begin
		 for k := 0 to strlen(namep^) do
		   outputcodebyte(ord(namep^[k]));
		 if odd(codephile.bytecount) then outputcodebyte(0);
		 lcp := lcp^.next;
		 end;
	     enumhead := enumhead^.next;
	     end;
	   end;

	 begin {dumpconsts}
	   { emit set constants }
	   p := sethead;
	   while p <> NIL do
	     begin { for each set constant }
	     fixreflist(p^.conlbl);  { fix local refs to pooled constant }
	     with p^ do
	       begin
	       { emit word containing size of set (in bytes) }
$if bigsets$
		outputcodeword( ( (plgth + (setelembits-1)) div
					setelembits ) * setelemsize );
$end$
$if not bigsets$
	       outputcodeword(((plgth + 15) div 16) * 2) ; { DC.W }
$end$
	       if plgth<>0 then
		 begin
  $if bigsets$
		   s := pval;
		   while s <> NIL do
		    with s^ do
		     begin
			variantrec.pad := 0;
		       for w := 0 to oldsetwordsize-1 do
			  variantrec.words[w] := 0;
		       variantrec.sett := val;
		       if nxt = NIL then (* last set record *)
			 limit := (plgth-1) MOD (oldsethigh+1)
		       else limit := oldsethigh;
		       for w := 0 to (limit div setelembits) do
			 outputcodeword(variantrec.words[w]);
		       s := nxt;
		     end;
  $end$
  $if not bigsets$
		   variantrec.sett := pval;
		   for w := 0 to (plgth - 1) div 16 do { for each word }
		     outputcodeword(variantrec.words[w]);
  $end$
		 end; {plgth<>0}
	     end; {with}
	     p := p^.next
	   end; {while}

	   { emit string constants }
	   p := stringhead;
	   while p <> NIL do { for each string constant }
	     begin
	     fixreflist(p^.conlbl);
	     emitstringlit(p);
	     p := p^.next;
	     end; {while}

	   { emit real constants }
	   p := reelhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     variant.r := p^.rval;
	     outputcodelong(variant.l1);
	     outputcodelong(variant.l2);
	     p := p^.next;
	     end;

	   $IF MC68020$
	   { emit chk2 bound pairs }
	   p := wrdpairhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     outputcodeword(p^.lower);
	     outputcodeword(p^.upper);
	     p := p^.next;
	     end;
	   p := longpairhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     outputcodelong(p^.lower);
	     outputcodelong(p^.upper);
	     p := p^.next;
	     end;
	   $END$

	   dumpenum; {emit enumerated consts}
	 end; {dumpconsts}

    procedure clear(newproc: boolean);
      { initialize register descriptors.  Newproc = true
	for initial call for each procedure body }
      var rn: regrange; rt: regtype;
      begin
	for rt := A to F do
	  for rn := 0 to maxreg do
	    if not((rt=A) and (rn in dedicatedregs)) then
	      with reg[rt,rn] do
		begin allocstate := free;
		usesleft := 0;
		if not newproc and (usage = withrecbase) then
		  curcontents^ := oldcontents;
		usage := other;
		end;
	with reg[A,localbase] do
	  begin allocstate := locked;
	  usesleft := maxint;
	  usage := basereg;
	  baselevel := bodylev;
	  end;
	with reg[A,SB] do
	  begin allocstate := locked;
	  usesleft := maxint;
	  usage := basereg;
	  baselevel := 1;
	  end;
	reg[A,SP].allocstate := locked;
      end; {clear}

     procedure getlocstorage(size: addrrange; var at: attrtype);
      begin
	lc := lc-size;
	if odd(lc) then lc := lc-1;
	if lc < lcmax then lcmax := lc;
	with at do
	  begin
	  addrmode := locinreg;
	  if bodylev = 1 then
	    begin
	    regnum := SB;
	    gloptr := currentglobal;
	    end
	  else
	    begin
	    regnum := localbase;
	    gloptr := NIL;
	    end;
	  offset := lc;
	  indexed := false;
	  packd := false;
	  access := direct;
	  end;
      end;

    procedure freeit( rt: regtype; rn: regrange );
      begin
	with reg[rt,rn] do
	  begin
	  if (rt=A) and (usage <> other) then
	    if usesleft > 0 then usesleft := usesleft-1
	    else escape(-8);
	  if ((usesleft=0) or (usage=other)) and (allocstate <> locked) then
	    allocstate := free;
	  end;
      end; {freeit}

    function getreg(classwanted: regtype): regrange;
      label 1;
      var r: regrange;
	freewithreg,freebasereg: -1..maxreg;
	freelevel: shortint; { static level of free base register }
      begin
      if classwanted = D then
	for r := 0 to maxreg do
	  begin if reg[D,r].allocstate = free then goto 1 end
      else if classwanted = A then {requested A register}
	begin freewithreg := -1;
	freebasereg := -1; freelevel := maxplevel+1;
	for r := 0 to SB-1 do
	  with reg[A,r] do
	    if allocstate = free then
	      case usage of
		other: goto 1; {allocate}
		basereg:
		  if baselevel < freelevel then
		    begin freebasereg := r; freelevel := baselevel end;
		withrecbase: freewithreg := r;
		end; {case}
	if freebasereg >= 0 then
	  begin r := freebasereg; forgetbasereg(r); goto 1 end
	else if freewithreg >= 0 then
	  begin r := freewithreg; forgetbasereg(r); goto 1 end;
	end {requested A register}
      else if classwanted = F then
	for r := 0 to maxreg do
	  begin if reg[F,r].allocstate = free then goto 1 end;
      errorwithinfo(684, 'Expression too complex in line ' + itostr(linenum));
      r := 0;
      clear(false); { aviod same error again }
   1: getreg := r;
      reg[classwanted,r].allocstate := allocated;
      end; {getreg}

    procedure getregattr( classwanted: regtype; var attr: attrtype );
      begin
      with attr do
	begin
	regnum := getreg(classwanted);
	if classwanted = D then
	  addrmode := inDreg
	else
	  addrmode := inAreg;
	storage := long;
	packd := false;
	end;
      end; {getregattr}

    function closestbasereg
       (* flevel: addrrange; var fdist: levrange): levrange *);
      var r: -1..maxreg;
	dist: levrange; tempdist: shortint;
      begin
	dist := reg[A,localbase].baselevel-flevel;
	closestbasereg := localbase;
	r := SB-1;
	while (dist > 0) and (r >= 0) do
	  begin
	  with reg[A,r] do
	    if usage = basereg then
	      begin tempdist := baselevel-flevel;
	      if tempdist >= 0 then
		if tempdist < dist then
		  begin dist := tempdist; closestbasereg := r end;
		end;
	  r := r-1;
	  end;
	fdist := dist;
      end; {closestbasereg}

    procedure movestatic(* flevel: addrrange; var at: attrtype *);
      { generate code to move base address of accessible activation having
	static level flevel.
	Emits ' MOVE.L <source>,"at" }
      var ldist,k: levrange;
	closereg: regrange;
	op1,op2: attrtype;
      begin
	ldist := bodylev-flevel;
	if ldist = 0 then {base of current activation}
	  with op1 do
	    begin
	      addrmode := inAreg; regnum := localbase;
	      emit2(move,op1,at);
	    end
	else {intermediate}
	  begin closereg := closestbasereg(flevel,ldist);
	  if ldist <= 1 then
	    with op1 do
	      begin
	      if ldist = 0 then
		begin addrmode := inAreg; regnum := closereg; end
	      else
		begin
		addrmode := locinreg; regnum := closereg;
		offset := staticdisp; indexed := false;
		gloptr := NIL;
		end;
	      emit2(move,op1,at);
	      end
	  else {2 or more levels distant}
	    begin
	    with op1 do
	      begin
	      addrmode := locinreg; regnum := closereg;
	      offset := staticdisp; indexed := false;
	      gloptr := NIL;
	      end;
	    getregattr(A,op2);
	    emit2(movea,op1,op2);
	    op1.regnum := op2.regnum;
	    for k := 1 to ldist-2 do
	      emit2(movea,op1,op2);
	    with reg[A,op2.regnum] do
	      begin
	      usage := basereg; baselevel := flevel+1; allocstate := free;
	      end;
	    emit2(move,op1,at);
	    end; { >= 2 levels distant}
	  end; {intermediate}
      end; {movestatic}

    function getbasereg(* flevel: addrrange): regrange *);
      var r1,r2: regrange; ldist,k: levrange; lop,rop: attrtype;
      begin
	if flevel = 1 then getbasereg := SB
	else if flevel = bodylev then getbasereg := localbase
	else
	  begin r1 := closestbasereg(flevel,ldist);
	  if ldist = 0 then
	    with reg[A,r1] do
	      begin getbasereg := r1;
	      usesleft := usesleft+1;
	      allocstate := allocated;
	      end
	  else {chase static link}
	    begin
	    with lop do
	      begin addrmode := locinreg; regnum := r1;
	      indexed := false; offset := staticdisp;
	      gloptr := NIL;
	      end;
	    getregattr(A,rop);
	    emit2(movea,lop,rop);
	    if ldist >= 2 then
	      begin lop.regnum := rop.regnum;
	      for k:=2 to ldist do emit2(movea,lop,rop);
	      end;
	    getbasereg := rop.regnum;
	    with reg[A,rop.regnum] do
	      begin usage := basereg;
	      baselevel := flevel;
	      allocstate := allocated;
	      usesleft := 1
	      end;
	    end; {ldist<>0}
	  end; {flevel<>bodylev}
      end; {getbasereg}

    procedure forgetbasereg(* r: regrange *);
      { erase unallocated activation or WITH record base register contents
	for register A.r }
    begin
    with reg[A,r] do
      if allocstate = free then
	begin
	if usage = withrecbase then
	curcontents^ := oldcontents;
	usage := other;
	end;
    end; {forgetbasereg}

    procedure forgetbaseregs;
      { erase unallocated activation or WITH record base register contents
	for all A registers }
      var r: regrange;
      begin
      for r := 0 to maxreg do
	forgetbasereg(r);
      end; {forgetbaseregs}

    function addrinreg(* fexp: exptr): boolean *);
      begin
      with fexp^.attr^ do
	addrinreg := (addrmode = locinreg) and
	  (offset = 0) and (access = direct) and
	  (gloptr = NIL) and not indexed;
      end;

    procedure liftattr(* father,son: exptr *);
      { propagate attributes up tree, but preserve father's storage size
	and next attribute pointer }
      var
	s: stortype;
	p: attrptr;
      begin
	with father^,attr^ do
	  begin
	  s := storage;
	  p := next;
	  attr^ := son^.attr^;
	  storage := s;
	  next := p;
	  end;
      end; {liftattr}

    procedure getsignbit(fsp: stp; fattr: attrptr);
      var lo,hi: valu;
      begin
      if fsp^.form = subrange then
	fsp := fsp^.rangetype;
      fattr^.signbit :=
	(fsp <> boolptr) and (fsp <> char_ptr);
      end; {getsignbit}

    procedure checkoffset(fexp: exptr);
      var
	op: attrtype;
	offsetmin,offsetmax : shortint;
	toffset: integer;
	taccess : accesstype;
	tstorage : stortype;
	taddrmode : addrtype;
	tindexed : boolean;
      begin
      with fexp^, attr^ do
      $IF MC68020$
	if indexed and
	   (addrmode in [shortabs,longabs,prel,namedconst,labelledconst]) then
	  begin
	  tindexed := indexed;
	  indexed := false;
	  taccess := access;
	  access := direct;
	  loadaddress(fexp,true);
	  indexed := tindexed;
	  access := taccess;
	  end;
      $END$
      $IF not MC68020$
	begin
	if indexed then
	  begin
	  offsetmin := -128;
	  offsetmax := 127;
	  end
	else
	  begin
	  offsetmin := -32768;
	  offsetmax := 32767;
	  end;
	if (indexed and
	   ((addrmode in [shortabs,longabs,prel,namedconst,labelledconst]) or
	   ((addrmode = locinreg) and (gloptr <> NIL)))) or
	   (offset < offsetmin) or
	   (offset > offsetmax) then
	  begin
	  tindexed := indexed;
	  indexed := false;
	  taccess := access;
	  access := direct;
	  if (offset > 32767) or (offset < -32768)
	     or ((gloptr <> NIL) and (offset <> 0)) then
	    begin
	    toffset := offset;
	    offset := 0;
	    end
	  else toffset := 0;
	  if not addrinreg(fexp) then
	    loadaddress(fexp,true)
	  else with reg[A,regnum] do
	    if (usage <> other) then
	      if (usesleft > 1) then {make copy}
		begin
		getregattr(A,op);
		tstorage := storage;
		emit2(lea,attr^,op);
		regnum := op.regnum;
		offset := 0;
		gloptr := NIL;
		storage := tstorage;
		end
	      else { simulate forgetbasereg }
		begin
		if usage = withrecbase then
		  curcontents^ := oldcontents;
		usage := other;
		end;
	  if toffset <> 0 then
	    begin
	    taddrmode := addrmode;
	    {fexp^.attr^.}addrmode := inAreg;
	    tstorage := storage;
	    if (toffset < -32768) or (toffset > 32767) then
	      {fexp^.attr^.}storage := long
	    else {fexp^.attr^.}storage := wrd;
	    with op do
	      begin
	      addrmode := immediate;
	      smallval := toffset;
	      emit2(adda,op,fexp^.attr^);
	      end;
	    storage := tstorage;
	    addrmode := taddrmode;
	    end;
	  indexed := tindexed;
	  access := taccess;
	  end;
	end;
      $END$
      end;

    procedure freeregs(* attrp: attrptr *);
      begin
	with attrp^ do
	  if addrmode = inDreg then freeit(D,regnum)
	  else if addrmode = inFreg then
	    begin
	    freeit(F,regnum);
	    $IF not MC68020$
	    freeit(F,regnum+1);
	    $END$
	    end
	  else if addrmode in memorymodes then
	    begin
	    if addrmode = locinreg then freeit(A,regnum);
	    if indexed then freeit(D,indexreg);
	    end;
      end; {freeregs}

    function min(a,b: integer): integer;
      begin
	if a<b then min := a else min := b;
      end;

    function mydiv(a,b: integer): integer;
      begin
      mydiv := (a - (a mod b)) div b;
      end;

    procedure fixliteral(* fexp: exptr; store: stortype; signed: boolean *);
      { fexp is a literal node. Storage and signed are the desired values
	for fexp^.attr^.storage and fexp^.attr^.signbit. If this literal
	cannot be represented in a data item with those attributes, its
	attributes will be set to reflect the minimum size that it can
	be represented in.}

      begin
	with fexp^, attr^, litval do
	  begin { determine minimum necessary }
	  if (ival >= -128) and (ival <= 127) then
	    begin storage := bytte; signbit := true; end
	  else if (ival >= 0) and (ival <= 255) then
	    begin storage := bytte; signbit := false; end
	  else if (ival >= -32768) and (ival <= 32767) then
	    begin storage := wrd; signbit := true; end
	  else if (ival >= 0) and (ival <= 65535) then
	    begin storage := wrd; signbit := false; end
	  else
	    begin storage := long; signbit := true; end;
	  { consider desired storage and signbit }
	  if store > storage then
	    if (not signed) and (ival < 0) then
	      begin storage := succ(store); signbit := true; end
	    else
	      begin storage := store; signbit := signed; end
	  else if store = storage then
	    if signed and not signbit then
	      begin storage := succ(storage); signbit := true; end
	    else if not signed and signbit then
	      if ival < 0 then
		begin storage := succ(storage); signbit := true; end
	      else
		signbit := false
	  else {store < storage}
	    if not signbit then
	      begin storage := succ(storage); signbit := true; end;
	  end;
      end; { fixliteral}

    function itostr(i:integer) : string80;
      var
	s: string80;
	j: shortint;
	chrstr: string[1];
      begin
	s := '';
	chrstr[0] := chr(1);
	while i > 0 do
	  begin
	  j := i MOD 10;
	  i := i DIV 10;
	  chrstr[1] := chr(ord('0')+j);
	  s := chrstr + s;
	  end;
	itostr := s;
      end;

    procedure genutilsinit;
      begin {genutils}
      codeerror := false;
      nullstring := '';
      dot_code := '.CODE';
      with SBdir do
	begin addrmode := inAreg; regnum := SB; storage := long; end;
      with SBind do
	begin
	  addrmode := locinreg; regnum := SB;
	  indexed := false; gloptr := NIL;
	  end;
      with A6dir do
	begin addrmode := inAreg; regnum := localbase; storage := long; end;
      with A6ind do
	begin
	  addrmode := locinreg; regnum := localbase;
	  indexed := false; gloptr := NIL;
	  end;
      with SPdir do
	begin addrmode := inAreg; regnum := SP end;
      with SPind do
	begin addrmode := locinreg; regnum := SP;
	offset := 0; indexed := false; gloptr := NIL;
	end;
      with SPplus do
	begin addrmode := postincr; regnum := SP end;
      with SPminus do
	begin addrmode := predecr; regnum := SP end;
      with immed0 do
	begin addrmode := immediate; smallval := 0 end;
      end; {genutilsinit}


@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 2488
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 2488
				{ file GENUTIL }

    import
      assemble,genmove,ci,fs;
    implement
      type
	pachstring = packed array[1..strglgth] of char;
      var
	codelinestart: 0..1023;
	nullstring: string[1];
	dot_code: string[5];

      procedure codeinit;
	begin
	  codeout := false; startaddr := -1;
	  codephile.headerblock := 2;
	  nextmodule := 1;
	end;

      procedure moduleinit (* modulenameptr: alphaptr *);
	begin
	uniquenum := 0;
	currentglobal := modulenameptr;
	modulecodeout := false;
	with codephile do
	  begin
	  bytecount := 0;
	  windowptr := 0;
	  startblock := headerblock + 1;
	  sourceblock := 1;
	  sourcesize := 0;
	  end;
	with defile do
	  begin
	  block := 0;
	  bite := 0;
	  end;
	def_ext_top := 1;
	with refile do
	  begin
	  block := 0;
	  bite := 0;
	  end;
	outputdef('_BASE',0,relocatable,0);
	end; { codeinit }

      procedure file_warn(errornum,iores: shortint);
	var
	  s: string[10];
	  i: integer;
	  message: string[50];
	const
	  error_opening = 'Error opening ';
	  error_writing = 'Error writing ';

	begin
	error(errornum);
	setstrlen(s,0);
	strwrite(s,1,i,iores:1);
	message := ' file, ioresult(' + s + ')';

	case errornum of
	  903: message := error_opening + 'code' + message;
	  904: message := error_opening + 'ref' + message;
	  905: message := error_opening + 'def' + message;
	  906: message := error_writing + 'code' + message;
	  907: message := error_writing + 'ref' + message;
	  908: message := error_writing + 'def' + message;
	end;
	warning(linenumber,message);
	end;

      procedure dumpbuffer;
	var
	  block: shortint;
	begin
	with codephile do
	  begin
	  if totalerrors = 0 then
	    begin
	    if not codefileopen then
	      begin
	      reset(fileid,file_name);
	      close(fileid,'PURGE');  { Purge any existing file }
	      fmaketype(fileid,file_name,
			nullstring,dot_code);
	      if ioresult <> 0 then
		file_warn(903,ioresult);
	      codefileopen := true;
	      end;
	    block := startblock + (windowptr DIV 512);
	    if blockwrite(fileid,buffer^,coderecs,block) <> coderecs then
	      file_warn(906,ioresult);
	    end;
	  windowptr := bytecount;
	  end;
	end; { dumpbuffer }

      procedure outputcodebyte (* b: shortint *);
	var
	  block, bite: shortint;
	begin
	  with codephile do
	    begin
	    modulecodeout := true;
	    block := (bytecount - windowptr) DIV 512 + 1;
	    bite := (bytecount - windowptr) MOD 512;
	    buffer^[block,bite] := b;
	    bytecount := bytecount + 1;
	    if (block = coderecs) and (bite = 511) then { buffer is full }
	      dumpbuffer;
	    end;
	end; { outputcodebyte }

      procedure outputcodeword (* w: shortint *);
	var
	  variantrec: packed record case boolean of
			true: (w: shortint);
			false: (b1: byt;
				b2: byt);
		      end;
	begin
	  variantrec.w := w;
	  outputcodebyte(variantrec.b1);
	  outputcodebyte(variantrec.b2);
	end; { outputcodeword }

      procedure outputcodelong (* l: integer *);
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;
	begin
	  variantrec.l := l;
	  for i := 0 to 3 do outputcodebyte(variantrec.b[i]);
	end; { outputcodelong }

      procedure fixbyte (* pc: addrrange; value: shortint *);
	var
	  fixbuffer: bytebufs;
	  bite,block: shortint;
	begin
	  if (pc >= 0) and (value <> 0) then with codephile do
	    if pc >= windowptr then { byte is in current buffer }
	      begin
	      bite := (pc - windowptr) MOD 512;
	      block := (pc - windowptr) DIV 512 + 1;
	      buffer^[block,bite] := buffer^[block,bite] + value;
	      end
	    else { patch up on disk }
	      begin
	      block := startblock + (pc DIV 512);
	      bite := pc MOD 512;
	      if blockread(fileid,fixbuffer,1,block) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      fixbuffer[bite] := fixbuffer[bite] + value;
	      if blockwrite(fileid,fixbuffer,1,block) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	end; { fixbyte }

      procedure fixword ( pc: addrrange; value: shortint );
	var
	  fixbuffer: array[1..2] of bytebufs;
	  numberofblocks: shortint;
	  bite1,block1,
	  bite2,block2: shortint;
	  variantrec: packed record case boolean of
			true: (w: shortint);
			false: (b1: byt;
				b2: byt);
		      end;
	begin
	if totalerrors = 0 then
	  if (pc >= 0) and (value <> 0) then with codephile do
	    if pc >= windowptr then { word is in current buffer }
	      begin
	      bite1 := (pc - windowptr) mod 512;
	      block1 := (pc - windowptr) DIV 512 + 1;
	      variantrec.b1 := buffer^[block1,bite1];
	      bite2 := (pc - windowptr + 1) MOD 512;
	      block2 := (pc - windowptr + 1) DIV 512 + 1;
	      variantrec.b2 := buffer^[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      buffer^[block1,bite1] := variantrec.b1;
	      buffer^[block2,bite2] := variantrec.b2;
	      end
	    else { patch up on disk }
	      begin
	      block1 := startblock + (pc DIV 512);
	      bite1 := pc MOD 512;
	      if bite1 < 511 then numberofblocks := 1 {word is all in one block}
			     else numberofblocks := 2;{word crosses boundry}
	      if blockread(fileid,fixbuffer,numberofblocks,block1)
							 <> numberofblocks then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      variantrec.b1 := fixbuffer[1,bite1];
	      block2 := 1 + (bite1 + 1) DIV 512;
	      bite2 := (bite1 + 1) MOD 512;
	      variantrec.b2 := fixbuffer[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      fixbuffer[1,bite1] := variantrec.b1;
	      fixbuffer[block2,bite2] := variantrec.b2;
	      if blockwrite(fileid,fixbuffer,numberofblocks,block1)
							  <> numberofblocks then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	end; { fixword }

      $IF MC68020$
      procedure fixlong ( pc: addrrange; value: integer );
	{ Assumes that the location being fixed currently has a value of 0 }
	var
	  variantrec : record case boolean of
			 true: (i: integer);
			 false:(s1: shortint;
				s2: shortint);
		       end;
	begin
	variantrec.i := value;
	fixword(pc,variantrec.s1);
	fixword(pc+2,variantrec.s2);
	end; {fixlong}
      $END$

      procedure fixreflist (* listptr: reflistptr *);
	{ listptr is a ptr to a linked list of 16-bit pc relative
	  references to the current pc.  This routine patches all
	  of those references. }
	var
	  patchbuf: array[1..2] of bytebufs;
	  patchblock,          {indicates the current block(s) in the patchbuf}
	  blocksin: shortint;  {number of blocks read into patchbuf}

	procedure diskpatch (pc: addrrange; value: shortint);
	  var
	    variantrec: packed record case boolean of
			  true: (w: shortint);
			  false: (b1: byt;
				  b2: byt);
			end;
	    bite1,block1,
	    bite2,block2: shortint;
	  begin
	    with codephile do
	      begin
	      block1 := startblock + (pc DIV 512);
	      bite1 := pc MOD 512;
	      if block1 <> patchblock then
		if (block1 <> patchblock + 1) or (bite1 = 511) then
		  begin
		  if patchblock <> 0 then
		    if blockwrite(fileid,patchbuf,blocksin,patchblock)<>blocksin
		      then begin ioresult := ord(zcatchall); escape(-10); end;
		  if bite1 < 511 then blocksin := 1
				 else blocksin := 2;
		  patchblock := block1;
		  if blockread(fileid,patchbuf,blocksin,patchblock) <> blocksin
		    then begin ioresult := ord(zcatchall); escape(-10); end;
		  end
		else
		  if blocksin <> 2 then { read in second part of buffer }
		    begin
		    if blockread(fileid,patchbuf[2],1,patchblock+1) <> 1
		      then begin ioresult := ord(zcatchall); escape(-10); end;
		    blocksin := 2;
		    end;
	      block1 := 1 + block1 - patchblock;
	      block2 := block1 + (bite1 + 1) DIV 512;
	      bite2 := (bite1 + 1) MOD 512;
	      variantrec.b1 := patchbuf[block1,bite1];
	      variantrec.b2 := patchbuf[block2,bite2];
	      variantrec.w := variantrec.w + value;
	      patchbuf[block1,bite1] := variantrec.b1;
	      patchbuf[block2,bite2] := variantrec.b2;
	      end;
	  end; { diskpatch }

	procedure dumpatches;
	  begin
	    if patchblock <> 0 then with codephile do
	      if blockwrite(fileid,patchbuf,blocksin,patchblock) <> blocksin
		then
		begin
		ioresult := ord(zcatchall);
		escape(-10);
		end;
	  end; { dumpatches }

	begin { fixreflist }
	if totalerrors = 0 then
	  begin
	  patchblock := 0;
	  while listptr <> NIL do
	    with listptr^ do
	      begin
	      if pc <> -1 then { -1 => branch not emitted }
		if (codephile.bytecount - pc) > 32767 then
		  error(671)
		else
		  if pc >= codephile.windowptr then
		    fixword(pc,codephile.bytecount-pc)
		  else
		    diskpatch(pc,codephile.bytecount-pc);
	      listptr := next;
	      end; { with listptr^ }
	  dumpatches;
	  end;
	end; { fixreflist }

      procedure outputref(name: alpha; loc: addrrange; t: reftype);
	{ temporarily output refs to a file }
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;

	procedure dumprefbuffer;
	  begin
	    with refile do
	      begin
	      if blockwrite(fileid,buffer^,1,block) <> 1 then
		file_warn(907,ioresult);
	      block := block + 1;
	      bite := 0;
	      end;
	  end; { dumprefbuffer }

	begin
	if totalerrors = 0 then
	  with refile do
	    begin
	    upc(name);               { added 4/12/84 }
	    buffer^[bite] := strlen(name);
	    bite := bite + 1;
	    if bite > 511 then dumprefbuffer;
	    for i := 1 to strlen(name) do
	      begin
	      buffer^[bite] := ord(name[i]);
	      bite := bite +1;
	      if bite > 511 then dumprefbuffer;
	      end;
	    buffer^[bite] := ord(t);
	    bite := bite + 1;
	    if bite > 511 then dumprefbuffer;
	    variantrec.l := loc;
	    for i := 0 to 3 do
	      begin
	      buffer^[bite] := variantrec.b[i];
	      bite := bite + 1;
	      if bite > 511 then dumprefbuffer;
	      end;
	    end;
	end; { outputref }

      procedure outputdef(name: string255;
			  loc: addrrange;
			  t: reloctype;
			  extnumber: shortint);
	var
	  i: shortint;
	  variantrec: record case boolean of
			true: (l: integer);
			false: (b: packed array[0..3] of byt);
		      end;
	  flags: flagtype;

	procedure dumpdefbuffer;
	  begin
	    with defile do
	      begin
	      if blockwrite(fileid,buffer^,1,block) <> 1 then
		file_warn(908,ioresult);
	      block := block + 1;
	      bite := 0;
	      end;
	  end; { dumpdefbuffer }

	begin
	if curglobalname <> NIL then
	  name := curglobalname^ + '_' + name;
	if totalerrors = 0 then
	  with defile do
	    begin
	    buffer^[bite] := strlen(name);
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    for i := 1 to strlen(name) do
	      begin
	      upc(name);
	      buffer^[bite] := ord(name[i]);
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    if not(odd(strlen(name))) then { pad to an even byte }
	      begin
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    with flags do
	      begin
	      typ := t;
	      size := sl;
	      patchable := false;
	      valueextend := true;
	      longoffset := false;
	      end;
	    buffer^[bite] := flags.b;
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    { output length of GVR in offset field }
	    if t = general then { has ref pointer }
	      buffer^[bite] := 8
	    else
	      buffer^[bite] := 6;
	    bite := bite + 1;
	    if bite > 511 then dumpdefbuffer;
	    { output value extension }
	    variantrec.l := loc;
	    for i := 0 to 3 do
	      begin
	      buffer^[bite] := variantrec.b[i];
	      bite := bite + 1;
	      if bite > 511 then dumpdefbuffer;
	      end;
	    if t = general then { has ref pointer }
	      begin
	      variantrec.l := extnumber + 1;
	      for i := 2 to 3 do
		begin
		buffer^[bite] := variantrec.b[i];
		bite := bite + 1;
		if bite > 511 then dumpdefbuffer;
		end;
	      end;
	    end; { with defile }
	end; { outputdef }

      procedure outputextdef(name: alpha;
			     loc: addrrange;
			     ext: alpha);
	{ output a def which references an ext }
	var
	  i,extnumber: shortint;
	  found: boolean;
	  globalnametemp: alphaptr;
	begin
	if ext = currentglobal^ then
	  extnumber := 4 {global delta }
	else
	  begin
	  extnumber := 8;
	  found := false;
	  i := 1;
	  while (i < def_ext_top) and not found do
	    begin
	    if def_ext_table[i] = ext then
	      found := true
	    else
	      extnumber := extnumber +
		   strlen(def_ext_table[i]) + 4 -
		   (strlen(def_ext_table[i]) mod 4);
	    i := i + 1;
	    end;
	  if not found then
	    if def_ext_top <= max_module_nesting then
	      begin
	      def_ext_table[def_ext_top] := ext;
	      def_ext_top := def_ext_top + 1;
	      end
	    else
	      error(663); { poor error number }
	  end;
	{ output def without module name prefix }
	globalnametemp := curglobalname;
	curglobalname := NIL;
	outputdef(name,loc,general,extnumber);
	curglobalname := globalnametemp;
	end;

      procedure codewrapup (* term: termtype *);

	procedure libraryheader;
	  begin
	    with libraryptr^[0] do
	      begin
	      dfirstblk := 0;
	      dlastblk := 2;
	      dfkind := untypedfile;
	      if strlen(outerblock^.namep^) > vnlength then
		outerblock^.namep^[0] := chr(vnlength);
	      dvid := outerblock^.namep^;
	      deovblk := dlastblk - 1;
	      dnumfiles := nextmodule - 1;
	      dloadtime := 0;
	      dlastboot:= globaldate;
	      end;
	    if blockwrite(codephile.fileid,libraryptr^,2,0) <> 2 then
	      begin ioresult := ord(zcatchall); escape(-10); end;
	  end;

	begin { codewrapup }
	  if (term = normal) and codeout and
	     (totalerrors = 0) then
	    begin
	    libraryheader;
	    close(codephile.fileid,'lock');
	    if ioresult <> 0 then
	      escape(-10);
	    with userinfo^ do
	      begin
	      gotcode := true;
	      codefid := file_name;
	      end;
	    end
	  else
	    begin
	    writeln;
	    writeln('No codefile generated.');
	    close(codephile.fileid,'purge');
	    end;
	  close(refile.fileid,'purge');
	  close(defile.fileid,'purge');
	end;

      procedure endofcode;
	{ append current memory code buffer to code file }
	var
	  numberofblocks,
	  block: shortint;
	begin
	if totalerrors = 0 then
	  with codephile do
	    begin
	    numberofblocks := (bytecount - windowptr + 511) DIV 512;
	    if numberofblocks > 0 then
	      begin
	      block := startblock + windowptr DIV 512;
	      if not codefileopen then
		begin
		reset(fileid,file_name);
		close(fileid,'PURGE');  { Purge any existing file }
		fmaketype(fileid,file_name,
			  nullstring,dot_code);
		codefileopen := true;
		end;
	      if blockwrite(fileid,buffer^,numberofblocks,block)
							    <> numberofblocks
		then file_warn(906,ioresult);
	      end;
	    end;
	end; { endofcode }

      procedure importexportstart(s: alphaptr);
	var
	  i: shortint;
	const
	  modu = 'MODULE ';
	begin
	if putcode and (totalerrors = 0) then
	  begin
	  for i := 1 to 7 do
	    outputcodebyte(ord(modu[i]));
	  for i := 1 to strlen(s^) do
	    outputcodebyte(ord(s^[i]));
	  outputcodebyte(ord(';'));
	  outputcodebyte(13{EOL});
	  end;
	end;

      procedure outputsymbol;
	{ Output the symblo that is between
	  symbolstart and symcursor.  Do not
	  let the symbol cross a block boundry
	  on the code file. }

	var
	  symbolsize,i: shortint;
	begin
	if putcode and (totalerrors = 0) then
	  with codephile do
	    begin
	    symbolsize := symcursor - symbolstart - 1;
	    if odd(bytecount DIV 512) and
	       ((bytecount+symbolsize+2) DIV 512 >
	       bytecount DIV 512) then
		 begin
		 outputcodebyte(13{EOL});
		 outputcodebyte(0);
		 end;
	    if (bytecount+symbolsize+1) DIV 512 > bytecount DIV 512 then
	      begin
	      while (bytecount+symbolsize+1) DIV 512 >
		    (bytecount+1) DIV 512 do
		outputcodebyte(32{blank});
	      outputcodebyte(13{EOL});
	      end;
	    for i := symbolstart to symcursor-1 do
	      outputcodebyte(ord(symbuf[i]));
	    end;
	end;

      procedure importexportwrapup;
	begin
	with codephile do
	  begin
	  if putcode and (totalerrors = 0) then
	    begin
	    if odd(bytecount DIV 512) and
	       ((bytecount+6) DIV 512 >
		bytecount DIV 512) then
	      outputcodebyte(0);
	    while (bytecount+6) DIV 512 >
		   bytecount DIV 512 do
	      outputcodebyte(32{blank});
	    outputcodebyte(ord('E'));
	    outputcodebyte(ord('N'));
	    outputcodebyte(ord('D'));
	    outputcodebyte(ord(';'));
	    outputcodebyte(13{EOL});
	    outputcodebyte(3);  { import export text terminator }
	    sourcesize := bytecount;
	    endofcode;
	    startblock := startblock +
			(sourcesize+511) DIV 512;
	    end;          { dump buffer to file }
	  bytecount := 0;
	  windowptr := 0;
	  modulecodeout := false;
	  end;
	end;

      procedure modulewrapup(countglobals: boolean);
	type
	  extptr = ^extentry;
	  extentry = record
		       nextext: extptr;
		       name: alpha;
		     end;
	var
	  curglobaltemp: alphaptr;
	  exttop: extptr;

	function extaddress (var name: alpha) : integer;
	  { search the exttable for "name" and return its position.
	    If it is not in the table put it at the end and return
	    its position. }
	  var
	    exptr: extptr;
	    done: boolean;
	    result: integer;
	    i: shortint;
	  begin
	    result := 8; { first two entries are reserved }
	    if exttop = NIL then
	      begin
	      newwords(exttop,(strlen(name)+2) DIV 2 + 4);
	      { cannot use normal string assignment for name field }
	      for i := 0 to strlen(name) do
		exttop^.name[i] := name[i];
	      exttop^.nextext := NIL;
	      end
	    else
	      begin
	      exptr := exttop;
	      done := false;
	      repeat
		if exptr^.name = name then done := true
		else
		  begin
		  result := result + strlen(exptr^.name) + 4
				   - (strlen(exptr^.name) MOD 4);
		  if exptr^.nextext = NIL then
		    begin
		    newwords(exptr^.nextext,(strlen(name)+2) DIV 2 + 4);
		    { cannot use string assignment for name field }
		    for i := 0 to strlen(name) do
		      exptr^.nextext^.name[i] := name[i];
		    exptr^.nextext^.nextext := NIL;
		    done := true;
		    end;
		  end;
		exptr := exptr^.nextext;
	      until done;
	      end;
	    extaddress := result;
	  end; { extaddress }

	procedure copydefs;
	  { append defile to codefile }
	  var
	    dontcare,i: shortint;
	    alphavar: alpha;
	  begin
	    with defile do
	      begin
	      defstartblock := codephile.startblock+totalbytesofcode DIV 512 + 1;
	      sizeofdefs := block * 512 + bite;
	      if block <> 0 then { dump last def block to defile }
		begin
		if bite > 0 then
		  begin
		  if blockwrite(fileid,buffer^,1,block) <> 1 then
		    file_warn(908,ioresult);
		  end
		else
		  begin
		  block := block - 1;
		  bite := 512;
		  end;
		if blockread(fileid,buffer^,1,0) <> 1 then
		  begin ioresult := ord(zcatchall); escape(-10); end;
		end;
	      if (block <> 0) or (bite <> 0) then
		for i := 0 to block do
		  begin
		  if blockwrite(codephile.fileid,buffer^,1,defstartblock+i) <> 1
		    then file_warn(906,ioresult);
		   if i <> block then
		    if blockread(fileid,buffer^,1,i+1) <> 1 then
		      begin ioresult := ord(zcatchall); escape(-10); end;
		  end; { for }
	      end;
	      for i := 1 to def_ext_top - 1 do
		begin
		alphavar := def_ext_table[i];
		dontcare := extaddress(alphavar);
		end;
	  end; { copydefs }

	procedure copyrefs;
	  var
	    copyblock,copybite: shortint;
	    flags: flagtype;
	    previousref: addrrange;

	  procedure copyexts;
	    var
	      exptr: extptr;
	      i: shortint;
	    begin { copyexts }
	      with codephile do { use codefile buffer routines for exts }
		begin
		extstartblock := refstartblock + (sizeofrefs + 511) DIV 512;
		sizeofexts := 8; { first 8 bytes are reserved }
		bytecount := (extstartblock - startblock) * 512;
		windowptr := bytecount;
		bytecount := bytecount + 8;
		exptr := exttop;
		while exptr <> NIL do
		  begin
		  sizeofexts := sizeofexts + strlen(exptr^.name) + 4
			      - (strlen(exptr^.name) MOD 4);
		  {upc(exptr^.name);         DELETED 4/12/84 }
		  for i := 0 to strlen(exptr^.name) do
		    outputcodebyte(ord(exptr^.name[i]));
		  for i := 1 to 3 - strlen(exptr^.name) MOD 4 do
		    outputcodebyte(0);
		  exptr := exptr^.nextext;
		  end;
		endofcode; { dump codefile buffer to the file }
		end;
	    end; { copyexts }

	  procedure copy1ref;
	    var
	      name: alpha;
	      relativetoprevious: addrrange;
	      extoffset: integer;
	      flags: flagtype;
	      t: reftype;
	      i: shortint;
	      variantrec2,
	      variantrec: record case boolean of
			    true: (l: integer);
			    false: (b: packed array[0..3] of byt);
			  end;

	    procedure bumprefbuffer;
	      { Not to be confused with dumprefbuffer.  This routine
		handles the buffering for reading in the temporary
		ref file. }
	      begin
	      copyblock := copyblock + 1;
	      copybite := 0;
	      with refile do
		if (block <> copyblock) or (bite <> 0) then
		  if blockread(fileid,buffer^,1,copyblock) <> 1 then
		    begin ioresult := ord(zcatchall); escape(-10); end;
	      end; { bumprefbuffer }

	    begin
	      with refile do
		begin
		name[0] := chr(buffer^[copybite]);
		copybite := copybite + 1;
		if copybite > 511 then bumprefbuffer;
		for i := 1 to ord(name[0]) do
		  begin
		  name[i] := chr(buffer^[copybite]);
		  copybite := copybite + 1;
		  if copybite > 511 then bumprefbuffer;
		  end;
		if strlen(name) <> 0 then extoffset := extaddress(name);
		t := reftype(buffer^[copybite]);
		copybite := copybite + 1;
		if copybite > 511 then bumprefbuffer;
		for i := 0 to 3 do
		  begin
		  variantrec.b[i] := buffer^[copybite];
		  copybite := copybite + 1;
		  if copybite > 511 then bumprefbuffer;
		  end;
		relativetoprevious := variantrec.l - previousref;
		previousref := variantrec.l;
		with flags do
		  begin
		  if t = rel16v then valueextend := true
				else valueextend := false;
		  case t of
		    abs16:
		      begin
		      if strlen(name) = 0 then typ := relocatable
					  else typ := general;
		      size := sw;
		      patchable := false;
		      end;
		    abs32:
		      begin
		      if strlen(name) = 0 then typ := relocatable
					  else typ := general;
		      size := sl;
		      patchable := false;
		      end;
		    rel16,rel16v:
		      begin
		      typ := general;
		      size := sw;
		      patchable := true;
		      end;
		    glob16:
		      begin
		      typ := global;
		      size := sw;
		      patchable := false;
		      end;
		    rel32:
		      begin
		      typ := general;
		      size := sl;
		      patchable := false;
		      end;
		  end;
		  if relativetoprevious < 256 then longoffset := false
					      else longoffset := true;
		  end; { with flags }
		outputcodebyte(flags.b);
		sizeofrefs := sizeofrefs + 1;
		if relativetoprevious < 256 then
		  begin
		  outputcodebyte(relativetoprevious);
		  sizeofrefs := sizeofrefs + 1;
		  end
		else
		  begin
		  variantrec2.l := relativetoprevious;
		  for i := 1 to 3 do outputcodebyte(variantrec2.b[i]);
		  sizeofrefs := sizeofrefs + 3;
		  end;
		if t = rel16v then
		  begin
		  variantrec.l := -variantrec.l;
		  for i := 0 to 3 do outputcodebyte(variantrec.b[i]);
		  sizeofrefs := sizeofrefs + 4;
		  end;
		if flags.typ = general then
		  begin
		  if not (t in [rel16,rel16v,rel32]) then {only one ref pointer (bit 0 on)}
		    extoffset := extoffset + 1;
		  outputcodeword(extoffset);
		  sizeofrefs := sizeofrefs + 2;
		  end;
		if t in [rel16,rel16v,rel32] then
		  begin
		  outputcodeword(3); { subtract recocation delta }
		  sizeofrefs := sizeofrefs + 2;
		  end;
		end;
	    end; { copy1ref }

	  begin { copyrefs }
	  with refile do
	    begin
	    refstartblock := defstartblock + (sizeofdefs + 511) DIV 512;
	    sizeofrefs := 0;
	    codephile.bytecount := (refstartblock - codephile.startblock) * 512;
	    codephile.windowptr := codephile.bytecount;
	    if block <> 0 then { dump lst ref block to refile }
	      begin
	      if bite > 0 then
		if blockwrite(fileid,buffer^,1,block) <> 1 then
		  file_warn(907,ioresult);
	      if blockread(fileid,buffer^,1,0) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      end;
	    previousref := 0;
	    copyblock := 0; copybite := 0;
	    while (copyblock <> block) or (copybite <> bite) do copy1ref;
	    endofcode; { dump codefile buffer^ to the file }
	    copyexts;
	    end;
	  end; { copyrefs }

	procedure fixheaderecord;
	  { output a module header at the beginning of the codefile }

	  var
	    i,j: shortint;
	    variantrec: record case boolean of
			  true: (l: addrrange);
			  false: (b: packed array[0..3] of byt);
			end;
	    directory: module_directory;

	  begin
	    with directory do
	      begin
	      date := globaldate;
	      revision := crevid;
	      { produced by compiler }
	      if modcal then producer := 'M'
			else producer := 'P';
	      system_id := ord(crevno[1]) - ord('0');
	      notice := gcopyright;
	      executable := (startaddr <> -1); { -1 means no main program }
	      relocatable_size := totalbytesofcode;
	      relocatable_base := 0;
	      if countglobals then
		begin
		if curproc = outerblock then global_size := -lcmax
		else global_size := -lc;
		end
	      else global_size := 0;
	      global_base := 0;
	      ext_block := extstartblock - codephile.headerblock;
	      ext_size := sizeofexts;
	      def_block := defstartblock - codephile.headerblock;
	      def_size := sizeofdefs;
	      source_block := sourceblock;
	      source_size := sourcesize;
	      text_records := 1;
	      morebytes[0] := strlen(currentglobal^);
	      for i := 1 to morebytes[0] do
		morebytes[i] := ord(currentglobal^[i]);
	      {even byte allign}
	      i := morebytes[0] + 1 + ord(not odd(morebytes[0]));
	      if startaddr <> -1 then { put out start address }
		begin
		morebytes[i] := 82; { signed long, relocatable, value extend }
		i := i + 1;
		morebytes[i] := 6;  { offset = 6 }
		i := i + 1;
		variantrec.l := startaddr;
		for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
		i := i + 4;
		end;
	      variantrec.l := codephile.startblock - codephile.headerblock;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := totalbytesofcode;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := refstartblock - codephile.headerblock;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      variantrec.l := sizeofrefs;
	      for j := 0 to 3 do morebytes[i+j] := variantrec.b[j];
	      i := i + 4;
	      { load address general value record (gvr) }
	      morebytes[i] := 82; { signed long, relocatable, value extend }
	      i := i + 1;
	      morebytes[i] := 6;  { offset = 6 }
	      i := i + 1;
	      for j := 0 to 3 do morebytes[i+j] := 0;
	      i := i + 4;
	      directory_size := fixedpart + i;
	      module_size := ((extstartblock - codephile.headerblock)
			   + (sizeofexts + 511) DIV 512) * 512;
	      end; { with directory }
	    with codephile do
	      begin
	      if blockwrite(fileid,directory,1,headerblock) <> 1 then
		begin ioresult := ord(zcatchall); escape(-10); end;
	      with libraryptr^[nextmodule] do
		begin
		dfirstblk := headerblock;
		dlastblk := headerblock + directory.module_size DIV 512;
		if strlen(currentglobal^) > fnlength then
		  currentglobal^[0] := chr(fnlength);
		dtid := currentglobal^;
		{ no. of bytes in last block }
		dlastbyte := ((sizeofexts-1) MOD 512) + 1;
		daccess := globaldate;
		dfkind := codefile;
		headerblock := dlastblk;
		end;
	      end; { with codephile }
	    if nextmodule + 1 <= maxdir then
	      nextmodule := nextmodule + 1
	    else error(705);
	  end; { fixheaderecord }

	begin { modulewrapup }
	if totalerrors = 0 then
	  if modulecodeout then
	    begin
	    if countglobals then
	      begin
	      curglobaltemp := curglobalname;
	      curglobalname := NIL;
	      outputdef(currentglobal^,0,global,0);
	      curglobalname := curglobaltemp;
	      end;
	    totalbytesofcode := codephile.bytecount;
	    endofcode;          { dump all buffered code bytes to the file }
	    exttop := NIL;
	    copydefs;           { append all defs to the end of the code file }
	    copyrefs;           { append all refs to the end of the code file }
	    fixheaderecord;     { fix up the module header information }
	    codeout := true;
	    end;
	end; { modulewrapup }

      procedure pactos(plgth: shortint; var pa: pachstring; var s: string);
	begin
	s[0] := chr(plgth);
	moveleft(pa[1],s[1],plgth);
	end;

      procedure callstdproc( s: alpha );
	var lattr: attrtype;
	begin
	lattr.callmode := callmode;
	with lattr do
	  begin
	  addrmode := namedconst; offset := 0;
	  new(constptr);
	  with constptr^ do
	    begin isdumped := false; newident(namep,s) end;
	  end;
	emit1(jsr,lattr);
	end;

      procedure callIOproc( s: alpha );
	var op: attrtype;
	begin callstdproc(s);
	if iocheck then
	  begin
	  with SBind do
	    begin
	    storage := long;
	    offset := ioresultptr^.vaddr;
	    gloptr := sysglobalptr;
	    end;
	  emit1(tst,SBind);
	  SBind.gloptr := NIL;
	  with op do begin storage := bytte; offset := 2 end;
	  emit1(beq,op);
	  op.smallval := 3;
	  emit1(trap,op);
	  end;
	end; {callIOproc}

      procedure getprokconst(fprocp: ctp; var at: attrtype);
	var
	  nametemp: alpha;
	begin
	at.callmode := callmode;
	with at do
	  begin addrmode := namedconst;
	  storage := long; offset := 0;
	  new(constptr);
	  with constptr^ do
	    if fprocp^.alias then
	      begin
	      namep := fprocp^.othername;
	      fprocp^.isrefed := true;
	      isdumped := false;
	      end
	    else if fprocp^.isdumped then
	      begin
	      isdumped := true;
	      location := fprocp^.location;
	      end
	    else
	      begin
	      if not fprocp^.extdecl and
		 not fprocp^.isexported then
		nametemp := itostr(fprocp^.forwid) +
			    fprocp^.namep^
	      else nametemp := fprocp^.namep^;
	      if fprocp^.othername <> NIL then
		newident(namep,
		  fprocp^.othername^ +
		  '_' + nametemp)
	      else
		newident(namep,nametemp);
	      fprocp^.isrefed := true;
	      isdumped := false;
	      end;
	  end;
	end; {getprokconst}

      procedure getbrattr
		    {var flbl: addrrange; defined: boolean; var battr: attrtype};
	{ Returns attributes for a Bcc instruction in battr^.
	  If defined, the branch is backward to flbl.
	  Otherwise, the PC, byte, and block numbers for the forward reference
	  are returned in flbl }
	var
	  PCtemp: addrrange;
	begin
	  PCtemp := codephile.bytecount + 2;
	  with battr do
	    if defined then
	      begin
	      offset := flbl - PCtemp;
	      if offset >= -128 then storage := bytte
	      else storage := wrd;
	      end
	    else
	      begin
	      offset := 0; storage := wrd;
	      flbl := PCtemp;
	      end;
	end; {getbrattr}

      procedure emitstringlit(sp: csp);
	var s: 0..strglgth;
	begin
	  with sp^ do
	    begin
	    s := 0;
	    if slgth = 0 then outputcodeword(0)
	    else while s < slgth do
	      begin
		if s=0 then if cclass = STRNG then
		  outputcodebyte(slgth);
		s := s+1; outputcodebyte(ord(sval[s]));
	      end;
	    if odd(codephile.bytecount) then outputcodebyte(0);
	    end;
	end; {emitstringlit}

      procedure getmultattr(* rcount: shortint; A1isfree: boolean;
							   var at: attrtype *);
	{get register list attributes for move multiple using 'rcount'
	 registers.  Assumes D0-D7 and A2-A5 are available; use of A1 is
	 controlled by 'A1isfree'}

	const numDregs = 8;
	  minmove = 2;
	  maxmove = 13;
	var
	  i : shortint;
	  j : regtype;
	begin
	  if (rcount < minmove) or (rcount > maxmove-1+ord(A1isfree)) then
	    escape(-8);
	  with at do
	    begin
	    for j := A to D do
	      for i := 0 to 7 do
		regs[j,i] := false;
	    addrmode := multiple;
	    if rcount <= numDregs then
	      for i := 0 to rcount-1 do regs[D,i] := true
	    else
	      begin
	      for i := 0 to numDregs-1 do regs[D,i] := true;
	      for i := (2-ord(A1isfree)) to (rcount-numDregs+1-ord(A1isfree)) do
		regs[A,i] := true;
	      end;
	    end; { with at }
	end; {getmultattr}

      procedure emitshift(*shiftcount: bitrange; reg: regrange;
			  shiftype: opcodetype; shiftsize: stortype*);
	var
	  shiftemp : regrange;
	  opnd1,
	  opnd2 : attrtype;
	begin
	  if shiftcount <> 0 then
	    if shiftcount > 8 then begin
	      shiftemp := getreg(D);
	      opnd1.smallval := shiftcount;
	      with opnd2 do
		begin addrmode := inDreg; regnum := shiftemp; end;
	      emit2(moveq,opnd1,opnd2);
	      with opnd1 do
		begin
		addrmode := inDreg; regnum := reg; storage := shiftsize;
		end;
	      emit2(shiftype,opnd2,opnd1);
	      freeit(D,shiftemp);
	      end
	    else begin
	      with opnd1 do
		begin addrmode := immediate; smallval := shiftcount; end;
	      with opnd2 do
		begin
		addrmode := inDreg; regnum := reg; storage := shiftsize;
		end;
	      emit2(shiftype,opnd1,opnd2);
	      end;
	end; {emitshift}

      procedure getmask(bitoffset,bitsize,masksize: shortint; var mask:integer);
	{ Games are played here because 32 bit UNSIGNED math is not available }
	var
	  topbit : (on,off);
	  variantrec : packed record case boolean of
			 true: (i: integer);
			 false: (bit1: 0..1);
		       end;
	begin
	  mask := 0;
	  if bitsize <> 0 then
	    begin
	    bitoffset := bitoffset + (32-masksize);
	    if bitoffset = 0 then { avoid 32 bit math overflow }
	      begin
	      topbit := on;
	      bitoffset := 1;
	      bitsize := bitsize - 1;
	      end
	    else
	      topbit := off;
	    if bitsize = 31 then mask := maxint
	    else
	      begin
	      if bitsize = 0 then mask := 0
	      else
		mask := (power_table[bitsize]-1) *
					   power_table[32-(bitoffset + bitsize)];
	      if topbit = on then { turn on sign bit in mask}
		begin
		variantrec.i := mask;
		variantrec.bit1 := 1;
		mask := variantrec.i;
		end;
	      end;
	    end;
	end; { getmask }

      procedure getcomplmaskattr(* bitoffset, bitsize, masksize: shortint;
							    var at :attrtype *);
	begin
	  getmask(bitoffset,bitsize,masksize,at.smallval);
	  with at do
	    begin
	    if smallval = maxint then smallval := minint
	    else smallval := -(smallval + 1);                 { 1's complement }
	    case masksize of
	      8: storage := bytte;
	     16: storage := wrd;
	     32: storage := long;
	    end; {case}
	    addrmode := immediate;
	    end;
	end; { getcomplmaskattr }

      procedure getmaskattr (* bitoffset, bitsize, masksize: shortint;
							  var at : attrtype *);
	begin
	  getmask(bitoffset,bitsize,masksize,at.smallval);
	  with at do
	    begin
	    case masksize of
	      8: storage := bytte;
	     16: storage := wrd;
	     32: storage := long;
	    end; {case}
	    addrmode := immediate;
	    end;
	end;

      procedure dumpstconst(*fsp: stp; var fvalu: valu*);
	{ Inserts structured constant into code file.
	  Modified for M68K by Sam Sands;
	  original VPM version by Donn Terry}

	const
	  wbytes = 2;       {number of bytes in a DC.W}
	  lbytes = 4;       {number of bytes in a DC.L}

	var
	  offset: addrrange;  {bytes generated so far}
	  packbuf:  shortint; {16 bit (DC.W) code bit buffer}
	  packbit:  shortint; {number of bits in packword}
	  curglobaltemp: alphaptr;

	procedure flush;  {output the code bit buffer}
	  var
	    variantrec: packed record case boolean of
			  true: (w: shortint);
			  false: (b1: byt;
				  b2: byt);
			end;
	  begin
	  if packbit >0 then
	    if packbit > 8 then
	      begin
	      outputcodeword(packbuf);
	      offset := offset + wbytes;
	      end
	    else
	      begin
	      variantrec.w := packbuf;
	      outputcodebyte(variantrec.b1);
	      offset := offset + 1;
	      end;
	  packbuf := 0;
	  packbit := 0;
	  end;

	procedure dmpcnst(fsp: stp; fvalu: valu;
			 packing: boolean;
			 posn, width: shortint);
$if bigsets$
	   const
		oldsetwordsize = (oldsethigh + 1 + setelemsize - 1)
				div setelemsize;
$end$

	  var
	    vctmp: vcref;
	    i,w,b: integer;
	    setsize: shortint;
	    variantrec: record case boolean of
			  true: (r: real);
			  false: (l1: integer;
				  l2: integer);
			end;
$if bigsets$
	   s : setrecptr;       (* current set record item *)
	   j : shortint;        (* simple local counter *)
	   limit : shortint;    (* ordinal limit for set rec *)
	   variantset : record case boolean of
			   true: (sett: set of setlow..oldsethigh);
			   false: (pad: shortint;
				  words: packed array
					   [0..oldsetwordsize-1] of shortint)
			 end;
$end$

	  procedure outbyte(i: shortint);        {output a bool or a char}
	    begin
	    flush;
	    outputcodebyte(i);                  { DC.B }
	    offset := offset + 1;
	    end;

	  procedure outword(i: shortint);   {output an enumerated type}
	    begin
	    flush;
	    outputcodeword(i);                  { DC.W }
	    offset := offset + wbytes;
	    end;

	  procedure outlong(i: integer);
	    begin
	    flush;
	    outputcodelong(i);                  { DC.L }
	    offset := offset + lbytes;
	    end;

	  procedure outpacked(i: integer);        {pack a 32 bit quantity}

	  var z,j: integer;

	  begin  {outpacked}
	    if posn = 0 then
	      begin
	      flush;        {starting over}
	      if width > 16 then
		if odd(offset) then outbyte(0);
	      end;
	    if posn >= 16 then posn := posn - 16;
	    packbit := posn + width;       {right end of field}
	    if packbit > 32 then
	      begin
	      flush;
	      if odd(offset) then outbyte(0);
	      posn := 0;
	      packbit := width;
	      end;
	    if width < 32 then
	      begin
	      if i < 0 then i := i - minint;
	      if width < 31 then
		begin
		z := 1;
		for j:= 1 to width do z := z + z;
		i := i mod z;
		end;
	      end;
	    z := i;
	    j := 16 - packbit;
	    while j<0 do begin if z < 0 then z := (z + 32768) div 2 + 16384
			       else z := z div 2;
			       j := j + 1;
			 end;
	    while j>0 do begin if z < 16384 then z := z + z
			       else z := (z - 16384)*2 - 32768;
			       j := j - 1;
			 end;
	    packbuf := packbuf + z;
	    if packbit >= 16 then
	      begin flush;
		    width := width - (16 - posn);
		    posn := 16;
		    if width > 0 then outpacked(i);
	      end;
	  end; {outpacked}

	  procedure outputpaoc
		      (aisstrng: boolean;
		       unpacksize: integer;
		       lgth: integer;
		       anyvar val: bigpac);
	  var
	    i: shortint;
	  begin
	  flush;
	  if odd(offset) then outbyte(0);
	  if aisstrng then
	    begin
	    outputcodebyte(lgth);        { DC.B }
	    offset := offset + 1;
	    end;
	  for i := 1 to lgth do
	    begin
	    $RANGE OFF$
	    outputcodebyte(ord(val[i])); { DC.B }
	    $IF rangechecking$
	    $RANGE ON$
	    $END$
	    offset := offset + 1;
	    end;
	  for i := lgth + 1 to
	      unpacksize-ord(aisstrng) do
	    begin
	    outputcodebyte(ord(' '));     { DC.B }
	    offset := offset + 1;
	    end;
	  end; {outputpaoc}

	  procedure dumparray;
	  var
	    elpos: bitrange;
	    i: integer;

	    procedure innerarray;
	    begin
	      with fvalu.valp^.kstruc^ do
		begin vctmp := scvcp;
		elpos := 0;
		while vctmp <> NIL do
		  with scstp^,vctmp^ do
		    begin
		    if aispackd then
		      begin
		      dmpcnst(aeltype,vcval,true,elpos,aelbitsize);
		      elpos := elpos+aelbitsize;
		      if elpos+aelbitsize > bitsperword then elpos := 0;
		      end
		    else
		      begin
		      dmpcnst(aeltype,vcval,false,0,0);
		      if aelsize <> aeltype^.unpacksize then
			outbyte(0);
		      end;
		    vctmp := vctmp^.vcnxt;
		    end;
		end;
	    end; {inner array}

	  begin {dumparray}
	  flush;
	  if odd(offset) then outbyte(0);
	  with fvalu.valp^.kstruc^ do
	    if (scstp^.aeltype = char_ptr) and scstp^.aispackd then
	      if scvcp^.vcval.valp^.cclass = paofch then
		{packed array of char literal is treated specially}
		with scvcp^.vcval.valp^ do
		  outputpaoc(fsp^.aisstrng,
			     fsp^.unpacksize,
			     slgth,
			     sval)
	      else if scvcp^.vcval.valp^.cclass = bigpaoc then
		{big packed array of char literal is treated specially}
		with scvcp^.vcval.valp^ do
		  outputpaoc(fsp^.aisstrng,
			     fsp^.unpacksize,
			     paoclgth,
			     paocval)
	      else {not paofch literal} innerarray
	    else {not pa of char type} innerarray;
	  flush;
	  end; {dumparray}

	procedure dumprecord;
	  var end_offset: addrrange;   {for short variants}
	      k: integer;
	      fieldbit: bitrange;
	  begin {inner record}
	  with fvalu.valp^.kstruc^ do
	    begin
	    flush;
	    if (scstp^.align <> 1) and odd(offset) then outbyte(0);
	    end_offset:=offset+scstp^.unpacksize;
	    vctmp := scvcp;
	    while vctmp <> NIL do
	      begin
	      with vctmp^ do
	      if vid <> NIL then
		with vid^ do
		begin
		if fispackd then
		  begin
		  if scstp^.unpacksize <> 1 then
		    fieldbit := (fldfbit+(8*ord(odd(offset)))) MOD 16
		  else fieldbit := fldfbit;
		  dmpcnst(idtype,vcval,true,
		       fieldbit,idtype^.bitsize);
		  end
		else dmpcnst(idtype,vcval,false,0,0);
		vctmp := vctmp^.vcnxt;
		end
	      end;
	    if end_offset>offset then flush;
	    if end_offset>offset then
		begin {fill out remainder of short variant}
		  {  DS.B end_offset-offset }
		  for k := 1 to end_offset-offset do outputcodebyte(0);
		  offset := end_offset;
		end;
	    end;
	  end; {dumprecord}

	  begin {dmpcnst}
	  if fsp <> NIL then
	    with fvalu do
	      begin
	      if fsp^.form = subrange then fsp := fsp^.rangetype;
	      if fsp^.form = scalar then
		if packing then outpacked(ival)
		else {not packing}
		  if (fsp = boolptr) or (fsp = char_ptr) then outbyte(ival)
		  else if fsp = intptr then
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    outlong(ival);
		    end
		  else
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    if intval {enumerated type or shortint} then
		      outword(ival)
		    else escape(-8);
		    end
	      else if fsp^.form = pointer then
		begin
		flush;
		if odd(offset) then outbyte(0);
		offset := offset+4;
		outputcodelong(0); { DC.L 0  (nilvalue = 0) }
		end
	      else if fsp^.form = reals then
		begin
		flush;
		if odd(offset) then outbyte(0);
		variantrec.r := fvalu.valp^.rval;
		outlong(variantrec.l1);
		outlong(variantrec.l2);
		end
	      else {not a scalar or pointer} if valp <> NIL then
		with valp^ do
		case cclass of
		  strctconst:  {structure within the structure}
			if kstruc <> NIL then
			  with kstruc^ do
			  if scstp <> NIL then
			    case scstp^.form of
			      arrays: dumparray;
			      records: dumprecord;
			      power:
				if scvcp <> NIL then
				  with scvcp^ do
				    dmpcnst(scstp,vcval,packing,posn,width)
			    end; {case form}
		  pset:
		    begin
		    flush;
		    if odd(offset) then outbyte(0);
		    setsize := ((plgth+setelembits-1) div setelembits)
						* setelemsize;
		    outword(setsize);           (* size in bytes *)
$if bigsets$
		  if plgth > 0 then
		   begin
		   s := pval;
		   while s <> NIL do
		    with s^ do
		     begin
		       variantset.pad := 0;
		       for j := 0 to oldsetwordsize-1 do
			  variantset.words[j] := 0;
		       variantset.sett := val;
		       if nxt = NIL then (* last set record *)
			 limit := (plgth-1) MOD (oldsethigh+1)
		       else limit := oldsethigh;
		       for j := 0 to (limit div setelembits) do
			 outword(variantset.words[j]);
		       s := nxt;
		     end;
		   end;
$end$
$if not bigsets$
		    for w:=0 to mydiv(plgth-1,setelembits) do
		      begin
			if w*16 in pval then packbuf:=packbuf+(-32768);
			b:=1;
			for i:=15 downto 1 do
			  begin
			    if (w*16)+i in pval then
			       packbuf:=packbuf+b;
			    if i>1 then b:=b+b;
			  end;
			outword(packbuf); packbuf:=0;
		      end;
$end$
		    for w := 1 to fsp^.unpacksize - (setsize+setlensize) do
		      outbyte(0);
		    end;
		  paofch:
		    outputpaoc(fsp^.aisstrng,
			       fsp^.unpacksize,
			       slgth,
			       sval);
		  bigpaoc:
		    outputpaoc(fsp^.aisstrng,
			       fsp^.unpacksize,
			       paoclgth,
			       paocval);
		  otherwise error(682)
		  end {case cclass};
	      end; {with fvalu}
	  end; {dmpcnst}

	begin {dumpstconst}
	if (fsp <> NIL) and putcode
	   and (totalerrors = 0) then
	  begin
	  with fvalu.valp^ do
	    begin isdumped := true;
	    if (namep <> NIL) and (level = 1) then
	      begin
	      curglobaltemp := curglobalname;
	      curglobalname := NIL;
	      outputdef(namep^,codephile.bytecount,relocatable,0);
	      curglobalname := curglobaltemp;
	      end;
	    location := codephile.bytecount;
	    end;
	  offset := 0;
	  packbit := 0;
	  packbuf := 0;
	  dmpcnst(fsp,fvalu,false,0,0);
	  flush;
	  if odd(codephile.bytecount) then outputcodebyte(0);
	  end;
	end; {dumpstconst}

      function insertnode (fconexp : csp; var fpoolptr : csp) : csp;
	 { add constant to pool list }
	 begin {insertnode}
	   with fconexp^ do
	     begin
	     insertnode := fconexp; conlbl := NIL;
	     next := fpoolptr ; fpoolptr := fconexp;
	     end {with}
	 end; {insertnode}

      $IF MC68020$
      function insertwrdpair(fconexp : csp; var fwrdpairptr : csp): csp;
	{ add word size bound pair to pool list }
	begin
	with fconexp^ do
	  begin
	  if fwrdpairptr = NIL then
	    insertwrdpair := insertnode(fconexp,fwrdpairptr)
	  else if lower < fwrdpairptr^.lower then
	    insertwrdpair := insertnode(fconexp,fwrdpairptr)
	  else if lower = fwrdpairptr^.lower then
	    begin
	    if upper < fwrdpairptr^.upper then
	      insertwrdpair := insertnode(fconexp,fwrdpairptr)
	    else if upper = fwrdpairptr^.upper then
	      insertwrdpair := fwrdpairptr
	    else
	      insertwrdpair := insertwrdpair(fconexp,fwrdpairptr^.next)
	    end
	  else
	    insertwrdpair := insertwrdpair(fconexp,fwrdpairptr^.next);
	  end;
	end; { insertwrdpair }

      function insertlongpair(fconexp : csp; var flongpairptr : csp): csp;
	{ add long size bound pair to pool list }
	begin
	with fconexp^ do
	  begin
	  if flongpairptr = NIL then
	    insertlongpair := insertnode(fconexp,flongpairptr)
	  else if lower < flongpairptr^.lower then
	    insertlongpair := insertnode(fconexp,flongpairptr)
	  else if lower = flongpairptr^.lower then
	    begin
	    if upper < flongpairptr^.upper then
	      insertlongpair := insertnode(fconexp,flongpairptr)
	    else if upper = flongpairptr^.upper then
	      insertlongpair := flongpairptr
	    else
	      insertlongpair := insertlongpair(fconexp,flongpairptr^.next)
	    end
	  else
	    insertlongpair := insertlongpair(fconexp,flongpairptr^.next);
	  end;
	end; { insertlongpair }
      $END$

       function insertreel(fconexp: csp; var freelptr: csp): csp;
	 {insert real constant in list, ordered according to value}
	 begin
	   with fconexp^ do
	     begin
	     if freelptr = NIL then insertreel := insertnode(fconexp,freelptr)
	     else if rval < freelptr^.rval
	       then insertreel := insertnode(fconexp,freelptr)
	     else if rval = freelptr^.rval {already in}
	       then insertreel := freelptr
	     else insertreel := insertreel(fconexp,freelptr^.next);
	     end;
	 end; {insertreel }

       function insertset (fconexp : csp; var fsetptr : csp) : csp;
	 { insert set constant in list, ordered according to length }
	 begin {insertset}
	   with fconexp^ do
	     begin
	       if fsetptr = NIL then insertset := insertnode(fconexp,fsetptr)
	       else if plgth < fsetptr^.plgth
		    then insertset := insertnode(fconexp,fsetptr)
	       else if (plgth = fsetptr^.plgth) and
		       (pval = fsetptr^.pval) { already in }
		    then insertset := fsetptr
	       else insertset := insertset(fconexp,fsetptr^.next)
	     end
	 end; {insertset}

       function insertstring (fconexp : csp; var fstrptr : csp) : csp;
	 var
	   lgth: 0..strglgth;

	 function scompare(length: shortint; var a,b: paoc): boolean;
	 var i: 0..strglgth; equal: boolean;
	 begin i:=0; equal:=true;
	   while (i<length) and equal do
	   begin i:=i+1; equal:= (a[i]=b[i]); end;
	   scompare := equal;
	 end;

	 { insert string constant in list, ordered according to length }
	 begin {insertstring}
	   with fconexp^ do
	     if fstrptr = NIL then insertstring := insertnode(fconexp,fstrptr)
	     else begin
	       lgth := fstrptr^.slgth;
	       if slgth < lgth
		    then insertstring := insertnode(fconexp,fstrptr)
	       else if (slgth = lgth) and
		      (cclass = fstrptr^.cclass) and
		      scompare(lgth,sval,fstrptr^.sval)
		    {already in}
		    then insertstring := fstrptr
	       else insertstring := insertstring(fconexp,fstrptr^.next)
	     end
	 end; {insertstring}

       function poolit ( konst : csp) : csp;
	 { add constant to pool, if not already in, and return
	   the csp for the constant in the pool }
	 begin {poolit}
	   case konst^.cclass of
	     paofch,
	     strng : poolit := insertstring(konst,stringhead);
	     pset : poolit := insertset(konst,sethead);
	     reel : poolit := insertreel(konst,reelhead);
	     $IF MC68020$
	     chk2_bounds : if konst^.size = wrd then
			     poolit := insertwrdpair(konst,wrdpairhead)
			   else {size = long}
			     poolit := insertlongpair(konst,longpairhead);
	     $END$
	     otherwise escape(-8);
	   end {case}
	 end; {poolit}

       procedure poolenum(* fsp: stp *);
	 label 1;
	 var lsp: stp;
       begin lsp := enumhead;
       while lsp <> NIL do
	 if lsp = fsp then goto 1
	 else lsp := lsp^.next;
       fsp^.next := enumhead;
       fsp^.enumlbl := NIL;
       enumhead := fsp;
    1: end;

       procedure dumpconsts;
	 { emit the constant pool }
$if bigsets$
	 const
		oldsetwordsize = (oldsethigh + 1 + setelemsize - 1)
					div setelemsize;
$end$
	 var
	   w : shortint;
	   p : csp;
$if bigsets$
	   s : setrecptr;       (* current set record item *)
	   j : shortint;        (* simple local counter *)
	   limit : shortint;    (* ordinal limit for set rec *)
	   variantrec : record case boolean of
			   true: (sett: set of setlow..oldsethigh);
			   false: (pad: shortint;
				  words: packed array
					   [0..oldsetwordsize-1] of shortint)
			 end;
$end$
$if not bigsets$
	   variantrec : record case boolean of
			  true: (sett: set of setlow..sethigh);
			  false: (pad: shortint;
				  words: packed array[0..15] of shortint);
			end;
$end$
	   variant : record case boolean of
		       true: (r: real);
		       false: (l1: integer;
			       l2: integer);
		     end;

	 procedure dumpenum;
	   var lcp: ctp; k: shortint;
	   begin
	   while enumhead <> NIL do
	     begin fixreflist(enumhead^.enumlbl);
	     lcp := enumhead^.fconst;
	     k := 0;
	     while lcp <> NIL do {count 'em}
	       begin k := k+1;
	       lcp := lcp^.next;
	       end;
	     outputcodeword(k);
	     lcp := enumhead^.fconst;
	     while lcp <> NIL do
	       with lcp^ do
		 begin
		 for k := 0 to strlen(namep^) do
		   outputcodebyte(ord(namep^[k]));
		 if odd(codephile.bytecount) then outputcodebyte(0);
		 lcp := lcp^.next;
		 end;
	     enumhead := enumhead^.next;
	     end;
	   end;

	 begin {dumpconsts}
	   { emit set constants }
	   p := sethead;
	   while p <> NIL do
	     begin { for each set constant }
	     fixreflist(p^.conlbl);  { fix local refs to pooled constant }
	     with p^ do
	       begin
	       { emit word containing size of set (in bytes) }
$if bigsets$
		outputcodeword( ( (plgth + (setelembits-1)) div
					setelembits ) * setelemsize );
$end$
$if not bigsets$
	       outputcodeword(((plgth + 15) div 16) * 2) ; { DC.W }
$end$
	       if plgth<>0 then
		 begin
  $if bigsets$
		   s := pval;
		   while s <> NIL do
		    with s^ do
		     begin
			variantrec.pad := 0;
		       for w := 0 to oldsetwordsize-1 do
			  variantrec.words[w] := 0;
		       variantrec.sett := val;
		       if nxt = NIL then (* last set record *)
			 limit := (plgth-1) MOD (oldsethigh+1)
		       else limit := oldsethigh;
		       for w := 0 to (limit div setelembits) do
			 outputcodeword(variantrec.words[w]);
		       s := nxt;
		     end;
  $end$
  $if not bigsets$
		   variantrec.sett := pval;
		   for w := 0 to (plgth - 1) div 16 do { for each word }
		     outputcodeword(variantrec.words[w]);
  $end$
		 end; {plgth<>0}
	     end; {with}
	     p := p^.next
	   end; {while}

	   { emit string constants }
	   p := stringhead;
	   while p <> NIL do { for each string constant }
	     begin
	     fixreflist(p^.conlbl);
	     emitstringlit(p);
	     p := p^.next;
	     end; {while}

	   { emit real constants }
	   p := reelhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     variant.r := p^.rval;
	     outputcodelong(variant.l1);
	     outputcodelong(variant.l2);
	     p := p^.next;
	     end;

	   $IF MC68020$
	   { emit chk2 bound pairs }
	   p := wrdpairhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     outputcodeword(p^.lower);
	     outputcodeword(p^.upper);
	     p := p^.next;
	     end;
	   p := longpairhead;
	   while p <> NIL do
	     begin
	     fixreflist(p^.conlbl);
	     outputcodelong(p^.lower);
	     outputcodelong(p^.upper);
	     p := p^.next;
	     end;
	   $END$

	   dumpenum; {emit enumerated consts}
	 end; {dumpconsts}

    procedure clear(newproc: boolean);
      { initialize register descriptors.  Newproc = true
	for initial call for each procedure body }
      var rn: regrange; rt: regtype;
      begin
	for rt := A to F do
	  for rn := 0 to maxreg do
	    if not((rt=A) and (rn in dedicatedregs)) then
	      with reg[rt,rn] do
		begin allocstate := free;
		usesleft := 0;
		if not newproc and (usage = withrecbase) then
		  curcontents^ := oldcontents;
		usage := other;
		end;
	with reg[A,localbase] do
	  begin allocstate := locked;
	  usesleft := maxint;
	  usage := basereg;
	  baselevel := bodylev;
	  end;
	with reg[A,SB] do
	  begin allocstate := locked;
	  usesleft := maxint;
	  usage := basereg;
	  baselevel := 1;
	  end;
	reg[A,SP].allocstate := locked;
      end; {clear}

     procedure getlocstorage(size: addrrange; var at: attrtype);
      begin
	lc := lc-size;
	if odd(lc) then lc := lc-1;
	if lc < lcmax then lcmax := lc;
	with at do
	  begin
	  addrmode := locinreg;
	  if bodylev = 1 then
	    begin
	    regnum := SB;
	    gloptr := currentglobal;
	    end
	  else
	    begin
	    regnum := localbase;
	    gloptr := NIL;
	    end;
	  offset := lc;
	  indexed := false;
	  packd := false;
	  access := direct;
	  end;
      end;

    procedure freeit( rt: regtype; rn: regrange );
      begin
	with reg[rt,rn] do
	  begin
	  if (rt=A) and (usage <> other) then
	    if usesleft > 0 then usesleft := usesleft-1
	    else escape(-8);
	  if ((usesleft=0) or (usage=other)) and (allocstate <> locked) then
	    allocstate := free;
	  end;
      end; {freeit}

    function getreg(classwanted: regtype): regrange;
      label 1;
      var r: regrange;
	freewithreg,freebasereg: -1..maxreg;
	freelevel: shortint; { static level of free base register }
      begin
      if classwanted = D then
	for r := 0 to maxreg do
	  begin if reg[D,r].allocstate = free then goto 1 end
      else if classwanted = A then {requested A register}
	begin freewithreg := -1;
	freebasereg := -1; freelevel := maxplevel+1;
	for r := 0 to SB-1 do
	  with reg[A,r] do
	    if allocstate = free then
	      case usage of
		other: goto 1; {allocate}
		basereg:
		  if baselevel < freelevel then
		    begin freebasereg := r; freelevel := baselevel end;
		withrecbase: freewithreg := r;
		end; {case}
	if freebasereg >= 0 then
	  begin r := freebasereg; forgetbasereg(r); goto 1 end
	else if freewithreg >= 0 then
	  begin r := freewithreg; forgetbasereg(r); goto 1 end;
	end {requested A register}
      else if classwanted = F then
	for r := 0 to maxreg do
	  begin if reg[F,r].allocstate = free then goto 1 end;
      errorwithinfo(684, 'Expression too complex in line ' + itostr(linenum));
      r := 0;
      clear(false); { aviod same error again }
   1: getreg := r;
      reg[classwanted,r].allocstate := allocated;
      end; {getreg}

    procedure getregattr( classwanted: regtype; var attr: attrtype );
      begin
      with attr do
	begin
	regnum := getreg(classwanted);
	if classwanted = D then
	  addrmode := inDreg
	else
	  addrmode := inAreg;
	storage := long;
	packd := false;
	end;
      end; {getregattr}

    function closestbasereg
       (* flevel: addrrange; var fdist: levrange): levrange *);
      var r: -1..maxreg;
	dist: levrange; tempdist: shortint;
      begin
	dist := reg[A,localbase].baselevel-flevel;
	closestbasereg := localbase;
	r := SB-1;
	while (dist > 0) and (r >= 0) do
	  begin
	  with reg[A,r] do
	    if usage = basereg then
	      begin tempdist := baselevel-flevel;
	      if tempdist >= 0 then
		if tempdist < dist then
		  begin dist := tempdist; closestbasereg := r end;
		end;
	  r := r-1;
	  end;
	fdist := dist;
      end; {closestbasereg}

    procedure movestatic(* flevel: addrrange; var at: attrtype *);
      { generate code to move base address of accessible activation having
	static level flevel.
	Emits ' MOVE.L <source>,"at" }
      var ldist,k: levrange;
	closereg: regrange;
	op1,op2: attrtype;
      begin
	ldist := bodylev-flevel;
	if ldist = 0 then {base of current activation}
	  with op1 do
	    begin
	      addrmode := inAreg; regnum := localbase;
	      emit2(move,op1,at);
	    end
	else {intermediate}
	  begin closereg := closestbasereg(flevel,ldist);
	  if ldist <= 1 then
	    with op1 do
	      begin
	      if ldist = 0 then
		begin addrmode := inAreg; regnum := closereg; end
	      else
		begin
		addrmode := locinreg; regnum := closereg;
		offset := staticdisp; indexed := false;
		gloptr := NIL;
		end;
	      emit2(move,op1,at);
	      end
	  else {2 or more levels distant}
	    begin
	    with op1 do
	      begin
	      addrmode := locinreg; regnum := closereg;
	      offset := staticdisp; indexed := false;
	      gloptr := NIL;
	      end;
	    getregattr(A,op2);
	    emit2(movea,op1,op2);
	    op1.regnum := op2.regnum;
	    for k := 1 to ldist-2 do
	      emit2(movea,op1,op2);
	    with reg[A,op2.regnum] do
	      begin
	      usage := basereg; baselevel := flevel+1; allocstate := free;
	      end;
	    emit2(move,op1,at);
	    end; { >= 2 levels distant}
	  end; {intermediate}
      end; {movestatic}

    function getbasereg(* flevel: addrrange): regrange *);
      var r1,r2: regrange; ldist,k: levrange; lop,rop: attrtype;
      begin
	if flevel = 1 then getbasereg := SB
	else if flevel = bodylev then getbasereg := localbase
	else
	  begin r1 := closestbasereg(flevel,ldist);
	  if ldist = 0 then
	    with reg[A,r1] do
	      begin getbasereg := r1;
	      usesleft := usesleft+1;
	      allocstate := allocated;
	      end
	  else {chase static link}
	    begin
	    with lop do
	      begin addrmode := locinreg; regnum := r1;
	      indexed := false; offset := staticdisp;
	      gloptr := NIL;
	      end;
	    getregattr(A,rop);
	    emit2(movea,lop,rop);
	    if ldist >= 2 then
	      begin lop.regnum := rop.regnum;
	      for k:=2 to ldist do emit2(movea,lop,rop);
	      end;
	    getbasereg := rop.regnum;
	    with reg[A,rop.regnum] do
	      begin usage := basereg;
	      baselevel := flevel;
	      allocstate := allocated;
	      usesleft := 1
	      end;
	    end; {ldist<>0}
	  end; {flevel<>bodylev}
      end; {getbasereg}

    procedure forgetbasereg(* r: regrange *);
      { erase unallocated activation or WITH record base register contents
	for register A.r }
    begin
    with reg[A,r] do
      if allocstate = free then
	begin
	if usage = withrecbase then
	curcontents^ := oldcontents;
	usage := other;
	end;
    end; {forgetbasereg}

    procedure forgetbaseregs;
      { erase unallocated activation or WITH record base register contents
	for all A registers }
      var r: regrange;
      begin
      for r := 0 to maxreg do
	forgetbasereg(r);
      end; {forgetbaseregs}

    function addrinreg(* fexp: exptr): boolean *);
      begin
      with fexp^.attr^ do
	addrinreg := (addrmode = locinreg) and
	  (offset = 0) and (access = direct) and
	  (gloptr = NIL) and not indexed;
      end;

    procedure liftattr(* father,son: exptr *);
      { propagate attributes up tree, but preserve father's storage size
	and next attribute pointer }
      var
	s: stortype;
	p: attrptr;
      begin
	with father^,attr^ do
	  begin
	  s := storage;
	  p := next;
	  attr^ := son^.attr^;
	  storage := s;
	  next := p;
	  end;
      end; {liftattr}

    procedure getsignbit(fsp: stp; fattr: attrptr);
      var lo,hi: valu;
      begin
      if fsp^.form = subrange then
	fsp := fsp^.rangetype;
      fattr^.signbit :=
	(fsp <> boolptr) and (fsp <> char_ptr);
      end; {getsignbit}

    procedure checkoffset(fexp: exptr);
      var
	op: attrtype;
	offsetmin,offsetmax : shortint;
	toffset: integer;
	taccess : accesstype;
	tstorage : stortype;
	taddrmode : addrtype;
	tindexed : boolean;
      begin
      with fexp^, attr^ do
      $IF MC68020$
	if indexed and
	   (addrmode in [shortabs,longabs,prel,namedconst,labelledconst]) then
	  begin
	  tindexed := indexed;
	  indexed := false;
	  taccess := access;
	  access := direct;
	  loadaddress(fexp,true);
	  indexed := tindexed;
	  access := taccess;
	  end;
      $END$
      $IF not MC68020$
	begin
	if indexed then
	  begin
	  offsetmin := -128;
	  offsetmax := 127;
	  end
	else
	  begin
	  offsetmin := -32768;
	  offsetmax := 32767;
	  end;
	if (indexed and
	   ((addrmode in [shortabs,longabs,prel,namedconst,labelledconst]) or
	   ((addrmode = locinreg) and (gloptr <> NIL)))) or
	   (offset < offsetmin) or
	   (offset > offsetmax) then
	  begin
	  tindexed := indexed;
	  indexed := false;
	  taccess := access;
	  access := direct;
	  if (offset > 32767) or (offset < -32768)
	     or ((gloptr <> NIL) and (offset <> 0)) then
	    begin
	    toffset := offset;
	    offset := 0;
	    end
	  else toffset := 0;
	  if not addrinreg(fexp) then
	    loadaddress(fexp,true)
	  else with reg[A,regnum] do
	    if (usage <> other) then
	      if (usesleft > 1) then {make copy}
		begin
		getregattr(A,op);
		tstorage := storage;
		emit2(lea,attr^,op);
		regnum := op.regnum;
		offset := 0;
		gloptr := NIL;
		storage := tstorage;
		end
	      else { simulate forgetbasereg }
		begin
		if usage = withrecbase then
		  curcontents^ := oldcontents;
		usage := other;
		end;
	  if toffset <> 0 then
	    begin
	    taddrmode := addrmode;
	    {fexp^.attr^.}addrmode := inAreg;
	    tstorage := storage;
	    if (toffset < -32768) or (toffset > 32767) then
	      {fexp^.attr^.}storage := long
	    else {fexp^.attr^.}storage := wrd;
	    with op do
	      begin
	      addrmode := immediate;
	      smallval := toffset;
	      emit2(adda,op,fexp^.attr^);
	      end;
	    storage := tstorage;
	    addrmode := taddrmode;
	    end;
	  indexed := tindexed;
	  access := taccess;
	  end;
	end;
      $END$
      end;

    procedure freeregs(* attrp: attrptr *);
      begin
	with attrp^ do
	  if addrmode = inDreg then freeit(D,regnum)
	  else if addrmode = inFreg then
	    begin
	    freeit(F,regnum);
	    $IF not MC68020$
	    freeit(F,regnum+1);
	    $END$
	    end
	  else if addrmode in memorymodes then
	    begin
	    if addrmode = locinreg then freeit(A,regnum);
	    if indexed then freeit(D,indexreg);
	    end;
      end; {freeregs}

    function min(a,b: integer): integer;
      begin
	if a<b then min := a else min := b;
      end;

    function mydiv(a,b: integer): integer;
      begin
      mydiv := (a - (a mod b)) div b;
      end;

    procedure fixliteral(* fexp: exptr; store: stortype; signed: boolean *);
      { fexp is a literal node. Storage and signed are the desired values
	for fexp^.attr^.storage and fexp^.attr^.signbit. If this literal
	cannot be represented in a data item with those attributes, its
	attributes will be set to reflect the minimum size that it can
	be represented in.}

      begin
	with fexp^, attr^, litval do
	  begin { determine minimum necessary }
	  if (ival >= -128) and (ival <= 127) then
	    begin storage := bytte; signbit := true; end
	  else if (ival >= 0) and (ival <= 255) then
	    begin storage := bytte; signbit := false; end
	  else if (ival >= -32768) and (ival <= 32767) then
	    begin storage := wrd; signbit := true; end
	  else if (ival >= 0) and (ival <= 65535) then
	    begin storage := wrd; signbit := false; end
	  else
	    begin storage := long; signbit := true; end;
	  { consider desired storage and signbit }
	  if store > storage then
	    if (not signed) and (ival < 0) then
	      begin storage := succ(store); signbit := true; end
	    else
	      begin storage := store; signbit := signed; end
	  else if store = storage then
	    if signed and not signbit then
	      begin storage := succ(storage); signbit := true; end
	    else if not signed and signbit then
	      if ival < 0 then
		begin storage := succ(storage); signbit := true; end
	      else
		signbit := false
	  else {store < storage}
	    if not signbit then
	      begin storage := succ(storage); signbit := true; end;
	  end;
      end; { fixliteral}

    function itostr(i:integer) : string80;
      var
	s: string80;
	j: shortint;
	chrstr: string[1];
      begin
	s := '';
	chrstr[0] := chr(1);
	while i > 0 do
	  begin
	  j := i MOD 10;
	  i := i DIV 10;
	  chrstr[1] := chr(ord('0')+j);
	  s := chrstr + s;
	  end;
	itostr := s;
      end;

    procedure genutilsinit;
      begin {genutils}
      codeerror := false;
      nullstring := '';
      dot_code := '.CODE';
      with SBdir do
	begin addrmode := inAreg; regnum := SB; storage := long; end;
      with SBind do
	begin
	  addrmode := locinreg; regnum := SB;
	  indexed := false; gloptr := NIL;
	  end;
      with A6dir do
	begin addrmode := inAreg; regnum := localbase; storage := long; end;
      with A6ind do
	begin
	  addrmode := locinreg; regnum := localbase;
	  indexed := false; gloptr := NIL;
	  end;
      with SPdir do
	begin addrmode := inAreg; regnum := SP end;
      with SPind do
	begin addrmode := locinreg; regnum := SP;
	offset := 0; indexed := false; gloptr := NIL;
	end;
      with SPplus do
	begin addrmode := postincr; regnum := SP end;
      with SPminus do
	begin addrmode := predecr; regnum := SP end;
      with immed0 do
	begin addrmode := immediate; smallval := 0 end;
      end; {genutilsinit}


@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.2
log
@Fixes for structured constants (1 byte leading field), expressions
with <var>*<const>+<const2> where <const>=0, relaxed allow_packed for
sizeof on packed elements
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d1538 1
a1538 5
		    begin
		    if fldfbit-(8*ord(odd(offset))) < 0 then
		      escape(-8);
		    fieldbit := fldfbit-(8*ord(odd(offset)));
		    end
@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.2
log
@Pws2unix automatic delta on Wed Nov 19 15:16:12 MST 1986
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@d1538 5
a1542 1
		    fieldbit := fldfbit-(8*ord(odd(offset)))
@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
