⟦c5306c6f3⟧

TextFileVerbose

job bbl 6 600 time 6 0 perm mini 100 1 size 92000
(
mode list.yes
platonenv = set bs bblenv5
platonlib = assign platonlibv5
;o loaderout
  head 1 cpu
  pascal80  ,
    codesize.15000,
    spacing.15000,
,   codelist.yes,
    ioenvir
;o c
;convert loaderout
  bloaderv5 = set 1 mini
  bloaderv5 = move pass6code
  if ok.yes
    scope user bloaderv5
  finis
)

process loader(var sem_vector : system_vector);
const
next_block_answer             =  0;
rewind_answer                 =  2;
finis_answer                  = 12;
memtype                       = 3;
wordsize                      = 2;
fpadriversize                 = 256;
fpabuffersize                 = 768;
ok                            = 0;
writecode                     = 2;
readcode                      = 1;
no_of_fpabuffers              = 2;
no_of_opbuffers               = 2;
firstindex                    = 6;
fixed_descr_length            = 5 + alfalength div wordsize + 9;
blank                         = '            ';

type
descriptor_segment = record
descriptor_length : integer;
no_of_pages : integer;
pagesize : integer;
last_page_length : integer;
kind : integer;
name : alfa;
entry_point : addr;
exception_point : addr;
exit_point : addr;
default_appetite : integer;
last_param_offset : integer;
no_of_params : integer
end;

descriptortype = packed record
pip : integer;
time : packed record
compiler_version : 0..31;
hour : 0..31;
minute : 0..63
end
end;

fpabuffer = record
first,last,next : integer;
data : array(firstindex..firstindex+fpabuffersize - 1) of byte
end;

var
count         ,
i,j,k         : integer;
input         ,
output        : zone;
loadersem     ,
bisem         ,
fpasem        : semaphore;
oppool        : pool no_of_opbuffers of opbuffer;
fpapool       : pool no_of_fpabuffers of fpabuffer;
descriptorpool: pool 1 of descriptor_segment;
rampool       : semaphore;
eprompool     : semaphore;
descriptor    ,
r             : reference;
fpachild      : shadow;
fpachannel    : integer;
command       ,
firstname     ,
lastname      : alfa;
loadtest      : boolean := true;
copy          , 
continue_read , 
break         : boolean;
descrsize     ,
descrwords    ,
codewords     ,
bufferindex   ,
last_in_buffer,
ramindex      ,
current       : integer;

label
slut;

process fpadriver(var sem : semaphore);
const
firstindex         = 6;
fpabuffersize      = 768;
statusbuffersize   = 18;
(* answer bytes to fpa100 *)
next_block_answer  = 256 + 0;
rewind_answer      = 256 + 2;
finis_answer       = 256 + 12;
sense_answer       = 256 + 128;
(* controlwords to fpa100 *)
repeat_interrupt   = 2;
start_read         = 3;
(* start bytes from fpa100 *)
status_block       = 249;
data_block         = 251;
(* fpa100 status words *)
receive_block_end  = 16;
transmit_block_end = 64;

type
statusbuffer = record
first,last,next : integer;
data : array(firstindex..firstindex + statusbuffersize - 1) of byte
end;

var
status_in          : integer;
status_out         : integer;
block_answer       : integer ;
block_type         : integer;
last_in_buffer     : integer;
channel_msg        ,
status_msg         ,
buffer_msg         : reference;
statuspool         : pool 1 of statusbuffer;


procedure control(control_word : integer; var ch_msg : reference);
external;

procedure controlclr(control_word : integer; var ch_msg : reference);
external;

procedure inword(var word : integer; var ch_msg : reference);
external;


procedure sense(var status_in : integer; status_out : integer; var ch_msg : reference);
external;

procedure outword(word : integer; var ch_msg : reference);
external;

begin
alloc(status_msg,statuspool,sem);
lock status_msg as p : statusbuffer do
begin
p.first := firstindex;
p.last  := firstindex + statusbuffersize - 1;
end;
wait(channel_msg,sem);
channel channel_msg do
repeat
wait(buffer_msg,sem);

if not nil(status_msg) then
begin
with status_msg^ do
begin
u3 := 200;
u4 := 2  ; (* 800 msec *)
end;
sendtimer(status_msg)
end;

if ownertest(statuspool,buffer_msg) then
block_answer := sense_answer
else
block_answer := 256 + buffer_msg^.u3;

outword (block_answer, channel_msg);
controlclr(repeat_interrupt, channel_msg);
sense (status_in, status_out, channel_msg);

lock buffer_msg as p : record
first,last,next : integer
end do
with p do
begin
if status_in <> transmit_block_end then
block_answer := rewind_answer  (* prepare repetition on: reset or autoload etc *)
else
if block_answer <> finis_answer then
begin (* don't read after finis-answer has been sent *)

controlclr (start_read, channel_msg);
inword (block_type, channel_msg);
controlclr (repeat_interrupt, channel_msg);
inbyteblock (next, first, last, buffer_msg, channel_msg);
controlclr (repeat_interrupt, channel_msg);
sense (status_in, status_out, channel_msg);

if status_in <> receive_block_end then
block_answer := rewind_answer
else
if (block_type = status_block) and (next = 8 + first) then
block_answer := next_block_answer
else
if block_type <> data_block then
block_answer := rewind_answer;
end;

if (block_type = data_block) and (block_answer = next_block_answer) then
begin
if next > 15 + first then
next := next - 15
else
next := first
end
else
next := first;
end;

if ownertest(statuspool,buffer_msg) then
begin
with buffer_msg^ do
begin
u3 := 200;
u4 := 2; (* 800 msec *)
end;
sendtimer(buffer_msg)
end
else
return(buffer_msg);
until false
end; (* process fpadriver *)

function uadd(a,b : integer) : integer;
external;

function udiv(a,b : integer) : integer;
external;

function umod(a,b : integer) : integer;
external;

function umul(a,b : integer) : integer;
external;

function getbyte: byte;
begin
if bufferindex >= last_in_buffer then
if continue_read then
begin
r^.u3 := next_block_answer;
signal(r,fpasem);
wait(r,bisem);
lock r as buf : fpabuffer do
last_in_buffer := buf.next;
bufferindex := firstindex;
if last_in_buffer = firstindex then
continue_read := false;
<*
if loadtest then
begin
outtext(output,'buf.next = #');
outhex(output,last_in_buffer,5);
outchar(output,nl)
end
*>
end;

if bufferindex < last_in_buffer then
begin
lock r as buf : fpabuffer do
getbyte := buf.data(bufferindex);
bufferindex := bufferindex + 1;
end
else
getbyte := 0;  (* simulate byte *)
end; (* procedure getbyte *)

function getword : integer;
begin
getword := uadd(umul(getbyte,256),getbyte)
end;

procedure prepare_input;
begin
while openpool(fpapool) do
begin
alloc(r,fpapool,bisem);
lock r as p : fpabuffer do
begin
p.first := firstindex;
p.last  := firstindex + fpabuffersize - 1;
end;
if openpool(fpapool) then
begin
r^.u3 := rewind_answer;
signal(r,fpasem);  (* keep the last message for init *)
end;
end;
copy := false; (* start in skip mode *)
continue_read := true;
bufferindex := firstindex;
last_in_buffer := bufferindex;
ramindex := 0; (* index of aaaa word *)
end;

procedure reset_input;
begin
prepare_input;
end;

procedure terminate_input;
begin
rammodule(current).maxindex := ramindex; (* pick up final ramindex *)
r^.u3 := finis_answer;
signal(r,fpasem);
for i := 1 to no_of_fpabuffers do
begin
wait(r,bisem);
release(r)
end;
outtext(output,'load ok #');
outchar(output,nl);
outend(output);
end;

procedure reserveram(i : integer);
begin
(* check overflow in rammessage *)
end;

procedure takeram(i : integer);
begin
ramindex := ramindex + i
end;


procedure fpaload;
begin

prepare_input;

repeat

if not continue_read then
reset_input;

repeat

descrsize := getword;

if (descrsize > 0) and continue_read then
begin
(* read a descriptor segment to descriptor message *)
descrwords := descrsize div wordsize;
reserveram (descrwords);

lock descriptor as core: array(1..fixed_descr_length) of integer do
begin
core (1) := descrsize;
for i := 2 to fixed_descr_length do
core (i) := getword;
end;

if continue_read then
begin
lock descriptor as p : descriptor_segment do
begin
if p.name = firstname then
copy := true;
with p do
codewords := (no_of_pages - 1) * (pagesize div wordsize)
             + (last_page_length + 1) div wordsize;
if loadtest then
begin
<*
outtext(output,'descrsize=#');
outhex(output,descrwords,5);
*>
if copy then
outtext(output,' * copy * #')
else
outtext(output,' * skip * #');
outtext(output,p.name);
<*
outtext(output,'codesize= #');
outhex(output,codewords,5);
*>
outchar(output,nl);
end;
end;

if copy then
begin
lock descriptor as source : array(1..fixed_descr_length) of integer do
lock rammodule(current).r as core : module do
begin
for i := 1 to fixed_descr_length do
core(ramindex + i) := source(i);
takeram (fixed_descr_length);
reserveram (descrwords - fixed_descr_length + codewords);

for i := 1 to descrwords - fixed_descr_length + codewords do
core(ramindex +i) := getword;

takeram (descrwords - fixed_descr_length + codewords);
end;

lock descriptor as p : descriptor_segment do
if p.name = lastname then
begin
copy := false;
descrsize := -1 
end;
end
else
for i := 1 to descrwords - fixed_descr_length + codewords do
j := getword; (* skip codepages *)
end;

end;

until descrsize <= 0;

reserveram(1);

lock rammodule(current).r as core : module do
core(ramindex + 1) := -1; (*  temporary  a checksum later *)

takeram(1);

until continue_read;

terminate_input;

end; (* procedure fpaload *)


procedure writestring(no : integer);
const
max_no       = 24;
stringlength = 33;
type
stringtype   = array(1..stringlength) of char;
tabletype    = array(0..max_no) of stringtype;
const
table = tabletype(
'rc3502 loadersystem 81.05.01  #'  , (*  0 *)
'fpa100 receiver channel       #'  , (*  1 *)
'first program name            #'  , (*  6 *)
'last program name             #'  , (*  7 *)
'load application module #',         (*  8 *)
'from fpa in #',                     (*  9 *)
'*** install more ram memory !#',    (* 14 *)
'*** fpa100 reservation trouble !#', (* 15 *)
'*** fpa100 driver no stack !#',     (* 16 *)
' * * * finis loadergensys * * *#' );(* 20 *)
var
i : integer := 1;
begin
while table(no,i) <> "#" do
begin
outchar(output,table(no,i));
i := i + 1
end;
end; (* writestring *)

procedure writestringnl(no : integer);
begin
writestring(no);
outchar(output,nl)
end; (* writestringnl *)

procedure getparam(stringno : integer; var param : integer);
begin
opin(input);
writestring(stringno);
outtext(output,'? #');
outend(output);
opwait(input,oppool);
ininteger(input,param);
end; (* getparam *)

procedure getalfaparam(stringno : integer; var name : alfa);
begin
opin(input);
writestring(stringno);
outtext(output,'? #');
outend(output);
opwait(input,oppool);
name := blank;
inname(input,name);
end; (* get alfaparam *)

procedure outparam(stringno , i : integer);
begin
writestring(stringno);
outinteger(output,i,6);
outchar(output,nl);
end;  (* outparam *)

procedure outalfaparam(stringno : integer; var name : alfa);
begin
writestring(stringno);
outtext(output,name);
outchar(output,nl);
end;  (* outalfaparam *)

procedure minmax(min : integer; var x : integer; max : integer);
begin
if x < min then
x := min;
if x > max then
x := max
end; (* minmax *)

procedure error(i,j,k : integer);
begin
outtext(output,'*** error in');
outtext(output,' module :#');
outinteger(output,eprommodule(i,j).moduleno,3);
outtext(output,' word :#');
outinteger(output,k,5);
outchar(output,nl);
outend(output);
end;

function initpool(var s : semaphore; number,psize : integer) : integer;
(* size is number of words ! *)
const
opcode             = 0;
var 
r                  : reference;
stack              : reference;
begin
checkstack(initpool_appetite);
wait(own.exitref,own.secret_pointer^(stopsem)^);
with own.exitref^ do
begin
u1 := opcode;
u2 := number;
if psize < 0 then
psize := minint;
u3 := udiv(psize,256);
u4 := umod(psize,256);
answer := ref(own.exit_semaphore);
end;
signal(own.exitref,own.secret_pointer^(allocsem)^);
wait(stack,own.exit_semaphore);
initpool := stack^.u2;
pop(own.exitref,stack);
while not nil(stack) do
begin
pop(r,stack);
signal(r,s);
end;
release(own.exitref);
end;



begin  (* loader main program *)

openopzone(output,sem_vector(operatorsem),ref(output.free),
no_of_opbuffers - 1,oppool,writecode,0,0,0);

openopzone(input,sem_vector(operatorsem),ref(loadersem),
1,oppool,readcode,0,0,0);

writestringnl(0); (* inittext *)

getparam(1,fpachannel); (* fpa100 receiverchannel *)

minmax(0,fpachannel,123);

if reservech(r,fpachannel,-1) = ok then
begin
if create('fpa100rec',fpadriver(fpasem),fpachild,fpadriversize) = ok then
begin
start(fpachild,minpriority);
signal(r,fpasem); (* send channel message to driver *)
end
else
begin
writestringnl(16);
outend(output);
goto slut;
end
end
else
begin
writestringnl(15);
outend(output);
goto slut;
end;

outparam(1,fpachannel);
outend(output);

alloc(descriptor,descriptorpool,bisem);

current := 1; (* set current program index to first program *)

while current <= no_of_application_modules do
begin
getalfaparam(6,firstname);
getalfaparam(7,lastname);
outalfaparam(6,firstname);
outalfaparam(7,lastname);
outparam(8,current);
outparam(9,fpachannel);
outend(output);
fpaload;
current := current + 1;
end;

remove(fpachild);

slut:
writestringnl(20);
outend(output);

end; (* loader *)
.
«eof»
DataMuseum.dk

RC3500

⟦c5306c6f3⟧ TextFileVerbose

Derivation

TextFileVerbose
