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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

43.1
date     90.03.20.14.07.30;  author jwh;  state Exp;
branches ;
next     42.2;

42.2
date     90.03.16.16.22.21;  author dew;  state Exp;
branches ;
next     42.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

21.1
date     87.08.12.14.12.49;  author bayes;  state Exp;
branches ;
next     20.2;

20.2
date     87.08.07.15.56.26;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.25.45;  author bayes;  state Exp;
branches ;
next     19.2;

19.2
date     87.07.28.11.50.22;  author larry;  state Exp;
branches ;
next     19.1;

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

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

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

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

15.1
date     87.04.13.09.39.34;  author jws;  state Exp;
branches ;
next     14.1;

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

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

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

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

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

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

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

7.1
date     86.11.20.14.18.44;  author hal;  state Exp;
branches ;
next     6.1;

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

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

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

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

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

1.1
date     86.06.30.16.03.12;  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
@$modcal$

{  SEGMENTER module -- Original author: Sam Sands                   }
{                      Reviewed by John Schmidt 5/83                }
{                                                                   }
{   Bug history:                                                    }
{      1. 5/24/83                                                   }
{         Larry Chapman (TAG) reported failure if STOP key was      }
{         hit while segment was loading. John S. verified bug,      }
{         determined hangup was in "loadtext" routine in loader.    }
{         Sam Sands suggested fix that was implemented by John S.   }
{         which repaired loader open file list pointer. Fix appears }
{         to work, and was verified by Sam, John, and Larry.        }
{                                                                   }
{      2. 3/35/85                                                   }
{         Fixes to flush 68020 I-cache before calling code. jws     }
{                                                                   }
{      3. 6/10/85                                                   }
{         The system variable 'INITSTACK' was not getting updated   }
{         for a call going through the segmenter.  The following    }
{         bug is the result of this.  If the entry point being      }
{         called is a main program and if at some point during      }
{         the execution of that program a NON-LOCAL goto is         }
{         executed where the destination is the main program that   }
{         was initially called, register A6 is incorrectly given    }
{         a value which corresponds to original main program.       }
{         This in turn causes the program envoked by the segmenter  }
{         to return to the command interpreter instead of the       }
{         environment that called it.  The fix implemented is to    }
{         save the value of 'INITSTACK', set up a proper new value, }
{         and restore the original value prior to returning to the  }
{         original scope.                                           }
{                                                                   }
{      4. 3/16/90                                                   }
{         The system variables heapbase and heapmax were not        }
{         getting updated for a call going through the              }
{         segmenter.  As a result, when both the segmenter          }
{         application and the called program were using heap_dispose}
{         the free list for the application was getting trashed.    }
{         This is only applicable for programs, not library entry   }
{         points (call_segment only)                                }

module segmenter;

import loader, ldr, sysglobals, MISC;             { JWS 5/24/83 }

export
  type segment_proc = procedure;
       proc_name    = string[120];

  procedure init_segmenter(anyvar lowcode,   highcode,
				  lowglobal, highglobal: byte);

  procedure load_segment     (filename: fid);
  procedure load_heap_segment(filename: fid);
  procedure unload_segment;
  procedure unload_all;

  procedure call_segment     (filename: fid);
  procedure call_segment_proc(filename: fid; symbol: proc_name);

  function find_proc(symbol: proc_name): segment_proc;
  function exists_proc(p: segment_proc): boolean;

  procedure segment_space(var code, global: integer);

implement

external module asm;
export
  function  allocate(size: integer): anyptr;
  procedure newbytes(var p: anyptr; size: integer);
  procedure flush_icache;
  function getA7 : integer;   { BAR 6/10/85 }
end;

import asm;

type  proc = procedure;

      trick_proc = record case boolean of
	     true:  (p: proc);
	     false: (ep, sl: integer);
	     end;

      state_ptr = ^state_rec;
      name_ptr  = ^proc_name;

      state_rec = record
	    savelist:  state_ptr;
	    restore_heap: boolean;
	    saveheap:  ^integer;
	    saveglob,
	    savecod:   integer;
	    saveentry,
	    savedef:   moddescptr;
	    savefiles: anyptr;
	    end;

var highglob, lowglob:     integer;
    lowcod,   highcod:     integer;
    segment_list:          state_ptr;
    initstack['INITSTACK'] : integer;   { BAR 6/10/85 }

procedure init_segmenter(anyvar lowcode,   highcode,
				lowglobal, highglobal: byte);
begin
 lowcod := integer(addr(lowcode));
 highcod := integer(addr(highcode));
 if highcod < lowcod then begin
			  lowcod := integer(addr(highcode));
			  highcod := integer(addr(lowcode));
			  end;
 lowglob := integer(addr(lowglobal));
 highglob := integer(addr(highglobal));
 if highglob < lowglob then begin
			  lowglob := integer(addr(highglobal));
			  highglob := integer(addr(lowglobal));
			  end;
 if odd(lowcod)   then lowcod   := lowcod + 1;
 if odd(lowglob)  then lowglob  := lowglob + 1;
 if odd(highcod)  then highcod  := highcod - 1;
 if odd(highglob) then highglob := highglob - 1;
end;

procedure segment_space(var code, global: integer);
begin
  code   := highcod  - lowcod;
  global := highglob - lowglob;
end;

procedure no_proc; begin escape(120); end;

function exists_proc(p: segment_proc): boolean;
begin
  exists_proc := not(p = no_proc);
end;

function find_proc(symbol: proc_name): segment_proc;
var
  modp: moddescptr;
  ptr, valueptr: addrec;
  found: boolean;
  proc_rec: trick_proc;
begin
find_proc := no_proc;
found := false;
modp := sysdefs;
while (modp<>nil) and not found do
  with modp^ do
    begin
      ptr := defaddr;
      while (ptr.a<defaddr.a+defsize) and not found do
	begin
	  found := ptr.syp^=symbol;
	  ptr.a := ptr.a+strlen(ptr.syp^)+1;
	  ptr.a := ptr.a+ord(odd(ptr.a));
	  valueptr.a := ptr.a+2;
	  if found then with proc_rec do
	    begin
	    sl := 0;
	    ep := valueptr.vep^.value;
	    find_proc := p;
	    end;
	  ptr.a := ptr.a+ptr.gvp^.short;
	end; {while}
      modp := link;
    end; {with modp^}
end;

procedure save_state(var state: state_rec; heapoff, codeoff: integer);
begin with state do
  begin
       savelist   := segment_list;      segment_list := addr(state);
  mark(saveheap);                       restore_heap := true;
       saveheap   := addr(saveheap^, heapoff);
       saveglob   := highglob;
       savecod    := lowcod + codeoff;
       savedef    := sysdefs;
       saveentry  := entrypoint;
       savefiles  := openfileptr;       openfileptr := anyptr(-1);
  end;
end;

procedure unload_segment;
begin
if segment_list = nil then escape(121) else
with segment_list^ do
  begin
	       segment_list := savelist;
  if restore_heap then release(saveheap);
	       highglob     := saveglob;
	       lowcod       := savecod;
	       sysdefs      := savedef;
	       entrypoint   := saveentry;
	       openfileptr  := savefiles;
  end;
end;

procedure unload_all;
begin
while segment_list <> nil do unload_segment;
end;

procedure load_seg(var filename: fid; p: proc);
var space: integer;
    modnum:    integer;
    highheap0: addrec;
    ESCTEMP: INTEGER;                 { JWS 5/24/83 }
    IOTEMP:  INTEGER;                 { JWS 5/24/83 }


begin
LOADFIB.PHP:=NIL;                     { JWS 5/24/83 }
try
  space := memavail - 5000;              {guess as to required stack space}
  if space <= 0 then escape(-2);
  mark(lowheap.p);
  highheap.a := lowheap.a + space; release(highheap.p);
  highheap0 := highheap;
  newmods := sysdefs;    endmod := sysdefs;

  openlinkfile(filename);
  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			    begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;

  if not allresolved then escape(119);

  highheap := highheap0;

  countcode;

  startglobal := highglob - a5;
  highglob := highglob - totalglobal;
  if highglob < lowglob then escape(117);
  zeromem(anyptr(highglob), totalglobal);
  call(p);
recover begin
	LOCKUP;                   { JWS 5/24/83 }
	ESCTEMP:=ESCAPECODE;      { JWS 5/24/83 }
	IOTEMP:=IORESULT;         { JWS 5/24/83 }
	unload_segment; {moved to ensure it's always done, whether the
			 file close escapes or not, and to release enough
			 memory for the dam call in closefiles.       SFB}

       {NOTE: closefiles assumes FIB is open. If openlinkfile escaped,
	it may not be. So check it ourselves. Also, we assume the
	loader's extra list contains only one file, loadfib.fbp^.  SFB}

	if loadfib.php <> nil then      {SFB}
	  if loadfib.fbp^.freadable then
	   CLOSEFILES;            { JWS 5/24/83 }
	IORESULT:=IOTEMP;         { JWS 5/24/83 }
	LOCKDOWN;                 { JWS 5/24/83 }
	escape(ESCTEMP);          { JWS 5/24/83 }
	end;
end;

procedure release_heap;
begin with segment_list^ do
  begin
  release(saveheap);
  restore_heap := false;
  end;
end;

procedure local(var filename: fid; p: proc);
var state: state_rec;

  procedure loadproc;
  begin
  highheap.a := highheap.a - totalreloc;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  startreloc := integer(allocate(totalreloc));
  loadtext(false);

  highheap.a := highheap.a - totaldefs;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  movedefs(integer(allocate(totaldefs)));
  release_heap;
  call(p);
  end;

begin
save_state(state, 0 , 0);
load_seg(filename, loadproc);
unload_segment;
end;

procedure call_segment     (filename: fid);

 procedure callit;
 var proc_rec: trick_proc;
     modptr: moddescptr;
     initstack_temp : integer;   { BAR 6/10/85 }
     recover_executed : boolean;{ BAR 6/10/85 }
     heapmaxsave:ANYPTR;        { DEW 3/16/90 }
     heapbasesave:ANYPTR;       { DEW 3/16/90 }
 begin
 modptr := entrypoint;
 while modptr<>nil do with modptr^ do
   begin
   if startaddr <> 0 then with proc_rec do
     begin
     sl := 0;
     ep := startaddr;
     flush_icache;
     recover_executed := false;     { BAR 6/10/85 }
     try                            { BAR 6/10/85 }
       initstack_temp := initstack; { BAR 6/10/85 }
       initstack := getA7 - 8;      { BAR 6/10/85 }
       heapmaxsave  := heapmax;     { DEW 3/16/90 }
       heapbasesave := heapbase;    { DEW 3/16/90 }
       call(p);
     recover
       recover_executed := true;    { BAR 6/10/85 }
     initstack := initstack_temp;   { BAR 6/10/85 }
     heapmax   := heapmaxsave;      { DEW 3/16/90 }
     heapbase  := heapbasesave;     { DEW 3/16/90 }
     if recover_executed then       { BAR 6/10/85 }
	escape(escapecode);         { BAR 6/10/85 }
     end;
   if lastmodule then modptr := nil else modptr := link;
   end;
 end;

begin
 local(filename, callit);
end;

procedure call_segment_proc(filename: fid; symbol: proc_name);
var p: segment_proc;
    initstack_temp : integer;  { BAR 6/10/85 }
    recover_executed : boolean;{ BAR 6/10/85 }

 procedure callit;
  begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(find_proc(symbol));
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end;

begin
p := find_proc(symbol);
if exists_proc(p) then begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(p);
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end
  else local(filename, callit);
end;

procedure load_segment     (filename: fid);
var state:  state_ptr;

  function code_space(size: integer): anyptr;
  begin
   if lowcod + size > highcod then escape(122)
   else
    begin
    code_space := anyptr(lowcod);
    lowcod := lowcod + size;
    end;
  end;

  procedure loadproc;
  begin
  startreloc := integer(code_space(totalreloc));
  loadtext(false);
  movedefs(integer(code_space(totaldefs)));
  release_heap;
  end;

begin
state := code_space(sizeof(state_rec));
save_state(state^, 0, -sizeof(state_rec));
load_seg(filename, loadproc);
end;

procedure load_heap_segment(filename: fid);
var state:  state_ptr;

  procedure loadproc;
  begin
  loadtext(true);
  movedefs(startreloc+totalreloc);
  release(anyptr(startdefs+totaldefs));
  end;

begin
newbytes(state, sizeof(state_rec));
save_state(state^, -sizeof(state_rec), 0);
mark(lowheap.p); startreloc := lowheap.a;
load_seg(filename, loadproc);
end;

end.
@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 417
$modcal$

{  SEGMENTER module -- Original author: Sam Sands                   }
{                      Reviewed by John Schmidt 5/83                }
{                                                                   }
{   Bug history:                                                    }
{      1. 5/24/83                                                   }
{         Larry Chapman (TAG) reported failure if STOP key was      }
{         hit while segment was loading. John S. verified bug,      }
{         determined hangup was in "loadtext" routine in loader.    }
{         Sam Sands suggested fix that was implemented by John S.   }
{         which repaired loader open file list pointer. Fix appears }
{         to work, and was verified by Sam, John, and Larry.        }
{                                                                   }
{      2. 3/35/85                                                   }
{         Fixes to flush 68020 I-cache before calling code. jws     }
{                                                                   }
{      3. 6/10/85                                                   }
{         The system variable 'INITSTACK' was not getting updated   }
{         for a call going through the segmenter.  The following    }
{         bug is the result of this.  If the entry point being      }
{         called is a main program and if at some point during      }
{         the execution of that program a NON-LOCAL goto is         }
{         executed where the destination is the main program that   }
{         was initially called, register A6 is incorrectly given    }
{         a value which corresponds to original main program.       }
{         This in turn causes the program envoked by the segmenter  }
{         to return to the command interpreter instead of the       }
{         environment that called it.  The fix implemented is to    }
{         save the value of 'INITSTACK', set up a proper new value, }
{         and restore the original value prior to returning to the  }
{         original scope.                                           }
{                                                                   }
{      4. 3/16/90                                                   }
{         The system variables heapbase and heapmax were not        }
{         getting updated for a call going through the              }
{         segmenter.  As a result, when both the segmenter          }
{         application and the called program were using heap_dispose}
{         the free list for the application was getting trashed.    }
{         This is only applicable for programs, not library entry   }
{         points (call_segment only)                                }

module segmenter;

import loader, ldr, sysglobals, MISC;             { JWS 5/24/83 }

export
  type segment_proc = procedure;
       proc_name    = string[120];

  procedure init_segmenter(anyvar lowcode,   highcode,
				  lowglobal, highglobal: byte);

  procedure load_segment     (filename: fid);
  procedure load_heap_segment(filename: fid);
  procedure unload_segment;
  procedure unload_all;

  procedure call_segment     (filename: fid);
  procedure call_segment_proc(filename: fid; symbol: proc_name);

  function find_proc(symbol: proc_name): segment_proc;
  function exists_proc(p: segment_proc): boolean;

  procedure segment_space(var code, global: integer);

implement

external module asm;
export
  function  allocate(size: integer): anyptr;
  procedure newbytes(var p: anyptr; size: integer);
  procedure flush_icache;
  function getA7 : integer;   { BAR 6/10/85 }
end;

import asm;

type  proc = procedure;

      trick_proc = record case boolean of
	     true:  (p: proc);
	     false: (ep, sl: integer);
	     end;

      state_ptr = ^state_rec;
      name_ptr  = ^proc_name;

      state_rec = record
	    savelist:  state_ptr;
	    restore_heap: boolean;
	    saveheap:  ^integer;
	    saveglob,
	    savecod:   integer;
	    saveentry,
	    savedef:   moddescptr;
	    savefiles: anyptr;
	    end;

var highglob, lowglob:     integer;
    lowcod,   highcod:     integer;
    segment_list:          state_ptr;
    initstack['INITSTACK'] : integer;   { BAR 6/10/85 }

procedure init_segmenter(anyvar lowcode,   highcode,
				lowglobal, highglobal: byte);
begin
 lowcod := integer(addr(lowcode));
 highcod := integer(addr(highcode));
 if highcod < lowcod then begin
			  lowcod := integer(addr(highcode));
			  highcod := integer(addr(lowcode));
			  end;
 lowglob := integer(addr(lowglobal));
 highglob := integer(addr(highglobal));
 if highglob < lowglob then begin
			  lowglob := integer(addr(highglobal));
			  highglob := integer(addr(lowglobal));
			  end;
 if odd(lowcod)   then lowcod   := lowcod + 1;
 if odd(lowglob)  then lowglob  := lowglob + 1;
 if odd(highcod)  then highcod  := highcod - 1;
 if odd(highglob) then highglob := highglob - 1;
end;

procedure segment_space(var code, global: integer);
begin
  code   := highcod  - lowcod;
  global := highglob - lowglob;
end;

procedure no_proc; begin escape(120); end;

function exists_proc(p: segment_proc): boolean;
begin
  exists_proc := not(p = no_proc);
end;

function find_proc(symbol: proc_name): segment_proc;
var
  modp: moddescptr;
  ptr, valueptr: addrec;
  found: boolean;
  proc_rec: trick_proc;
begin
find_proc := no_proc;
found := false;
modp := sysdefs;
while (modp<>nil) and not found do
  with modp^ do
    begin
      ptr := defaddr;
      while (ptr.a<defaddr.a+defsize) and not found do
	begin
	  found := ptr.syp^=symbol;
	  ptr.a := ptr.a+strlen(ptr.syp^)+1;
	  ptr.a := ptr.a+ord(odd(ptr.a));
	  valueptr.a := ptr.a+2;
	  if found then with proc_rec do
	    begin
	    sl := 0;
	    ep := valueptr.vep^.value;
	    find_proc := p;
	    end;
	  ptr.a := ptr.a+ptr.gvp^.short;
	end; {while}
      modp := link;
    end; {with modp^}
end;

procedure save_state(var state: state_rec; heapoff, codeoff: integer);
begin with state do
  begin
       savelist   := segment_list;      segment_list := addr(state);
  mark(saveheap);                       restore_heap := true;
       saveheap   := addr(saveheap^, heapoff);
       saveglob   := highglob;
       savecod    := lowcod + codeoff;
       savedef    := sysdefs;
       saveentry  := entrypoint;
       savefiles  := openfileptr;       openfileptr := anyptr(-1);
  end;
end;

procedure unload_segment;
begin
if segment_list = nil then escape(121) else
with segment_list^ do
  begin
	       segment_list := savelist;
  if restore_heap then release(saveheap);
	       highglob     := saveglob;
	       lowcod       := savecod;
	       sysdefs      := savedef;
	       entrypoint   := saveentry;
	       openfileptr  := savefiles;
  end;
end;

procedure unload_all;
begin
while segment_list <> nil do unload_segment;
end;

procedure load_seg(var filename: fid; p: proc);
var space: integer;
    modnum:    integer;
    highheap0: addrec;
    ESCTEMP: INTEGER;                 { JWS 5/24/83 }
    IOTEMP:  INTEGER;                 { JWS 5/24/83 }


begin
LOADFIB.PHP:=NIL;                     { JWS 5/24/83 }
try
  space := memavail - 5000;              {guess as to required stack space}
  if space <= 0 then escape(-2);
  mark(lowheap.p);
  highheap.a := lowheap.a + space; release(highheap.p);
  highheap0 := highheap;
  newmods := sysdefs;    endmod := sysdefs;

  openlinkfile(filename);
  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			    begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;

  if not allresolved then escape(119);

  highheap := highheap0;

  countcode;

  startglobal := highglob - a5;
  highglob := highglob - totalglobal;
  if highglob < lowglob then escape(117);
  zeromem(anyptr(highglob), totalglobal);
  call(p);
recover begin
	LOCKUP;                   { JWS 5/24/83 }
	ESCTEMP:=ESCAPECODE;      { JWS 5/24/83 }
	IOTEMP:=IORESULT;         { JWS 5/24/83 }
	unload_segment; {moved to ensure it's always done, whether the
			 file close escapes or not, and to release enough
			 memory for the dam call in closefiles.       SFB}

       {NOTE: closefiles assumes FIB is open. If openlinkfile escaped,
	it may not be. So check it ourselves. Also, we assume the
	loader's extra list contains only one file, loadfib.fbp^.  SFB}

	if loadfib.php <> nil then      {SFB}
	  if loadfib.fbp^.freadable then
	   CLOSEFILES;            { JWS 5/24/83 }
	IORESULT:=IOTEMP;         { JWS 5/24/83 }
	LOCKDOWN;                 { JWS 5/24/83 }
	escape(ESCTEMP);          { JWS 5/24/83 }
	end;
end;

procedure release_heap;
begin with segment_list^ do
  begin
  release(saveheap);
  restore_heap := false;
  end;
end;

procedure local(var filename: fid; p: proc);
var state: state_rec;

  procedure loadproc;
  begin
  highheap.a := highheap.a - totalreloc;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  startreloc := integer(allocate(totalreloc));
  loadtext(false);

  highheap.a := highheap.a - totaldefs;
  if highheap.a < lowheap.a then escape(-2);
  release(highheap.p);
  movedefs(integer(allocate(totaldefs)));
  release_heap;
  call(p);
  end;

begin
save_state(state, 0 , 0);
load_seg(filename, loadproc);
unload_segment;
end;

procedure call_segment     (filename: fid);

 procedure callit;
 var proc_rec: trick_proc;
     modptr: moddescptr;
     initstack_temp : integer;   { BAR 6/10/85 }
     recover_executed : boolean;{ BAR 6/10/85 }
     heapmaxsave:ANYPTR;        { DEW 3/16/90 }
     heapbasesave:ANYPTR;       { DEW 3/16/90 }
 begin
 modptr := entrypoint;
 while modptr<>nil do with modptr^ do
   begin
   if startaddr <> 0 then with proc_rec do
     begin
     sl := 0;
     ep := startaddr;
     flush_icache;
     recover_executed := false;     { BAR 6/10/85 }
     try                            { BAR 6/10/85 }
       initstack_temp := initstack; { BAR 6/10/85 }
       initstack := getA7 - 8;      { BAR 6/10/85 }
       heapmaxsave  := heapmax;     { DEW 3/16/90 }
       heapbasesave := heapbase;    { DEW 3/16/90 }
       call(p);
     recover
       recover_executed := true;    { BAR 6/10/85 }
     initstack := initstack_temp;   { BAR 6/10/85 }
     heapmax   := heapmaxsave;      { DEW 3/16/90 }
     heapbase  := heapbasesave;     { DEW 3/16/90 }
     if recover_executed then       { BAR 6/10/85 }
	escape(escapecode);         { BAR 6/10/85 }
     end;
   if lastmodule then modptr := nil else modptr := link;
   end;
 end;

begin
 local(filename, callit);
end;

procedure call_segment_proc(filename: fid; symbol: proc_name);
var p: segment_proc;
    initstack_temp : integer;  { BAR 6/10/85 }
    recover_executed : boolean;{ BAR 6/10/85 }

 procedure callit;
  begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(find_proc(symbol));
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end;

begin
p := find_proc(symbol);
if exists_proc(p) then begin
    flush_icache;                     {JWS 3/25/85}
    recover_executed := false;     { BAR 6/10/85 }
    try                            { BAR 6/10/85 }
      initstack_temp := initstack; { BAR 6/10/85 }
      initstack := getA7 - 8;      { BAR 6/10/85 }
      call(p);
    recover
      recover_executed := true;    { BAR 6/10/85 }
    initstack := initstack_temp;   { BAR 6/10/85 }
    if recover_executed then       { BAR 6/10/85 }
       escape(escapecode);         { BAR 6/10/85 }
  end
  else local(filename, callit);
end;

procedure load_segment     (filename: fid);
var state:  state_ptr;

  function code_space(size: integer): anyptr;
  begin
   if lowcod + size > highcod then escape(122)
   else
    begin
    code_space := anyptr(lowcod);
    lowcod := lowcod + size;
    end;
  end;

  procedure loadproc;
  begin
  startreloc := integer(code_space(totalreloc));
  loadtext(false);
  movedefs(integer(code_space(totaldefs)));
  release_heap;
  end;

begin
state := code_space(sizeof(state_rec));
save_state(state^, 0, -sizeof(state_rec));
load_seg(filename, loadproc);
end;

procedure load_heap_segment(filename: fid);
var state:  state_ptr;

  procedure loadproc;
  begin
  loadtext(true);
  movedefs(startreloc+totalreloc);
  release(anyptr(startdefs+totaldefs));
  end;

begin
newbytes(state, sizeof(state_rec));
save_state(state^, -sizeof(state_rec), 0);
mark(lowheap.p); startreloc := lowheap.a;
load_seg(filename, loadproc);
end;

end.
@


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.2
log
@Fixed the problem reported by TECAP with the SEGMENTER.  Defect 
occurs if both segmenter application and called program are
using heap_dispose on.  In this case, the segmenter application
would get its free list trashed.
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@d33 9
d301 2
d316 2
d322 2
@


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.2
log
@reverse order of unload_segment & closefiles
make closefiles contingent on file being open
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@d235 11
a245 1
	CLOSEFILES;               { JWS 5/24/83 }
a246 1
	unload_segment;
@


19.2
log
@increase slop from 3000 to 5000 so that cc works
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@d207 1
a207 1
  space := memavail - 3000;              {guess as to required stack space}
@


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.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


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.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


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
@@
