$listoff
stdenv;
(*--------------------------------------------
--
--             system standard environment for rtp
--
--   87.09.27   tog   first version.
--   92.06.04   hej   type bufparamtype added.
--   92.06.12   hej   a number of open routines added ( eg. for imc ).
--                    - type compilerid_type
--   92.06.19  hej    the type of index changed:  byte -> integer,
--                    - parameter of locktest changed: mailbox -> reference.
--
-----------------------------------------------
*)

(***** predefined constants *****)
const
(*alfalength = 12;*)
maxint = 32767;
minint = -32768;


(***** predefined types *****)
type

bit = 0..1;

byte = 0..255;


conn_service = (cs_normal, cs_high);

const create_ok=0;
      create_process_not_nil=1;
      create_program_not_linked=2;
      create_no_memory=3;

type create_result = create_ok .. create_no_memory;

const
maxpriority = 0;
minpriority = -2;
stdpriority = minpriority;

type
priotype = minpriority..maxpriority;


event_type = (not_event, message_event, answer_event,
              process_removed, port_closed, disconnected,
              letter_sent, letter_arrived,
              local_connect, remote_connect,
              reset_indication, reset_completion,
              credit, data_sent, data_arrived, data_overrun,
              dummy_letter, dummy_lcnct, dummy_rcnct,
              dummy_rindic, dummy_rcmpl, dummy_credit,
              dummy_sent, dummy_arrived,
              msl_message, msl_answer, test_event);

const link_ok=0;
      link_not_found=1;
      link_no_parameter_match=3;
      link_already_linked=6;

type link_result=link_ok..link_already_linked;

const unlink_ok=0;
      unlink_no_program_linked=1;
      unlink_program_busy=2;

type unlink_result=unlink_ok..unlink_program_busy;

const mem_private = 0;

type mem_type = mem_private..mem_private;

reason_type = (reason_ok, reason_name, reason_resource,
               reason_closed, reason_network);

scope_type = (anonymous, local, regional, global);

string(length: byte) = array(1..length) of char;

alfa = string(12);

activation = (a_interrupt, a_mailbox, a_delay);

control_type = packed record
                 rcv_all,
                 get_credit: boolean;
               end;


(* shielded type declarations *)
(******************************)

mailbox_ = record
             nulbyte: byte;
             mbx    : ^integer; -- ^proc or ^header
             chain  : ^integer; -- ^mbx
           end;

pool_ = record
          nulbyte: byte;
          mbx    : ^integer; -- ^proc or ^header
          chain  : ^integer; -- ^pool_
        end;

process_ = record
            data : ^integer; -- ^proc
            chain: ^integer; -- ^process
          end;


reference_ = record
               locked : byte;
               message: ^integer; -- ^header
               chain  : ^integer; -- ^ref
             end;


chain_ = record
           message:  ^integer; -- ^header
           start  :  ^integer; -- ^header
           length :   integer;
         end;

port_ = record
           index_limit : byte;
           imc_box     : ^mailbox;
           port_active : mailbox;
           port_ready  : mailbox;
           port_answer : mailbox;
        end;

program_descriptor = record
          count     : integer;
          paramtypes: ^integer;
          state     : integer;
          lbdr      : ^integer; -- ^lbdr
          name      : array(1..12) of char;
          chain     : ^integer; -- ^prog
        end;

(*****  predefined routines  *****)
(*********************************)


function abs(n: integer): integer;
openroutine;


procedure alloc( var r: reference; var p: pool; var ra: mailbox);
external;

function allocdelay(var r: reference; var p:pool; var ra: mailbox;
                     ms: integer): activation;
external;

function allocmempool(var p: pool; no_of_bufs, bufsize: integer;
mem: mem_type): integer;
external;

function allocpool=allocpool_rc
         (var p: pool; no_of_bufs, bufsize: integer): integer;
external;

procedure break(var proc: process; fault: integer);
external;

function bufcount(var r: reference): integer;
external;

function bufsize(var r: rtype    ): integer;
openroutine;


function bytecount(var r: rtype   ): integer;
external;

procedure chaindequeue(var ref: reference; var ch: chain);
external;

procedure chaindown(var ch: chain);
external;

procedure chainenqueue(var ref: reference; var ch: chain);
external;

function chainlength(var ch: chain): integer;
openroutine;


procedure chainreset(var ch: chain);
openroutine;


procedure chainstart(var ch: chain);
openroutine;


procedure chainup(var ch: chain);
external;

function ord(v: btype): integer; 
openroutine;


function ord(v: wtype): integer; openroutine;
function chr(v: byte): char;
openroutine;



function create(inspect incname: string; var prog: program_descriptor;
     var pr: process; size: integer; prio: integer): create_result;
external;

function creditcount(var r: reference): integer;
openroutine;


procedure dec(var v: byte);
openroutine;


procedure dec(var v: integer);
openroutine;


procedure delay(ms: integer);
openroutine;


function eventkind(var r: rtype): event_type;
openroutine;


procedure exception(c: integer);
external;

function hometest(var r: rtype; var p: pool): boolean;
external;

procedure inc(var v: byte);
openroutine;


procedure inc(var v:integer);
openroutine;


function index(var r:reference): integer;
openroutine;



function link(inspect incname: string;var prog: program_descriptor):
              link_result;
external;

function locked(var m:mailbox): boolean;
openroutine;


function locktest(var r: reference): boolean;
openroutine;


procedure new(var p: ptype); external;

function nil(var p:ptype  ): boolean; openroutine;
function nil(var p:process): boolean;
openroutine;


function nil(var p:reference): boolean;
openroutine;


function offset(var r:rtype    ): integer;
openroutine;


function open(var m:mailbox): boolean; openroutine;
function openpool(var p: pool): boolean;
openroutine;


function passive(var m:mailbox): boolean;
openroutine;


procedure pop(var b,s: reference);
openroutine;


function pred(v: btype): btype; openroutine;
function pred(v: wtype): wtype;
openroutine;


procedure push(var b,s: reference);
openroutine;


function reason(var r:reference): reason_type;
openroutine;


procedure release(var r: reference);
openroutine;


function releasepool(var p:pool; bufs: integer): integer;
external;

procedure remove(var pr: process);
external;

procedure resetevent(var r: rtype);
openroutine;


procedure resume(var pr: process);
external;

procedure return(var r:reference);
openroutine;


procedure setbytecount(var r: rtype    ; v: integer);
external;

procedure setoffset=setoffset_rc(var r: rtype    ; v: integer);
external;

procedure settop=settop____rc(var r: rtype    ; v: integer);
external;

procedure setu1(var r: rtype    ; v: byte);
external;

procedure setu2(var r: rtype    ; v: byte);
external;

procedure setu3(var r: rtype    ; v: byte);
external;

procedure setu4(var r: rtype    ; v: byte);
external;

procedure signal(var r: reference; var m:mailbox);
openroutine;


function stackdepth(var r:reference  ): integer;
external;

procedure start(var pr: process; prio: integer);
external;

procedure stop(var p: process);
external;

function succ(v:btype): btype; openroutine;
function succ(v:wtype): wtype;
openroutine;


procedure tofrom=tofrom____rc(var toref: reference; toindex: integer;
                 var fromref: reference; fromindex: integer;
                 bytes: integer );
external;

function top(var r:rtype    ): integer;
openroutine;


procedure trace = exception(f: integer);
external;

procedure stacktrace = exception(f: integer);
external;

function unlink(var prog: program_descriptor): integer;
external;

function u1(var r:rtype    ): byte;
openroutine;


function u2(var r:rtype    ): byte;
openroutine;


function u3(var r:rtype    ): byte;
openroutine;


function u4(var r:rtype    ): byte;
openroutine;


procedure wait( var r: reference; var m: mailbox);
openroutine;


function waitdelay(var r: reference; var m: mailbox;
                   ms: integer): activation;
external;

procedure closeport(var p: port);
external;

procedure connect(var p:port; index:1..maxint; var compl, disc: reference;
                  inspect remote_name:string; service: conn_service);
external;

procedure disconnect(var p:port; index:1..maxint);
external;

procedure getconnection(var p:port; index:1..maxint; var compl, disc:reference);
external;

procedure getcredit(var p:port; index:1..maxint; var credbuf: reference);
external;

procedure getreset(var p:port; index:1..maxint; var indic: reference);
external;

function maxconnections:integer;
external;

procedure openport(var p:port; var closebuf: reference;
                   inspect name:string; scope: scope_type;
                   no_of_cons: 0..maxint; cntrl: control_type);
external;

procedure receive(var p:port; index:1..maxint; var databuf: reference);
external;

procedure receiveall(var p:port; var databuf: reference);
external;

procedure reset(var p:port; index:1..maxint; var compl: reference);
external;

procedure send(var p:port; index:1..maxint; var databuf: reference);
external;


(* implementation dependent standard routines and types*)

type

coded_date=packed record
             year_after_1900: 0..127;
             month: 0..12;
             day: 0..31;
           end;

coded_time=packed record
             compiler_version : 0..31;
             hour: 0..23;
             minute: 0..59;
           end;

coded_secs=packed record
             sec: 0..59;
             msec: 0..999;
           end;

coded_inc= packed record
             days: 0..31;
             hours: 0..23;
             mins: 0..59;
             secs: 0..59;
             msecs: 0..999;
           end;

delaytype= packed record
             prev_date: coded_date;
             prev_time: coded_time;
             prev_secs: coded_secs;
             inc : coded_inc;
           end;

clocktype= packed record
             date: coded_date;
             time: coded_time;
             secs: coded_secs;
           end;

tversion= record
            release, subrelease: byte;
          end;

compilerid_type = packed record
     packageidentification   : 0..7;
     compilerrelease         : 0..31;
     compilersubrelease      : 0..255
     end;

(*  package   ident_value  compiler        *)
--   sw2101        1      old rtp35  rc8000
--   sw2104        2      rtp86
--   sw2103        3      rtp35
--   sw2111        4      rtp2111    rc8000
--   sw2114        5      rtp


tmoduleversion= record
                  moduledate: coded_date;
                  moduletime: coded_time;
                  moduleversion: tversion;
                  compilationdate: coded_date;
                  compilationtime: coded_time;
$if target = rc3502
                  compilerid  : compilerid_type;
$endif
                end;

(*  *)
lookup_descriptor_segment = record
  name             : alfa;
  descriptor_length,
  no_of_pages      ,
  pagesize         ,
  last_page_length ,
  kind             : integer;
  default_appetite ,
  last_param_offset,
  no_of_params     : integer;
  date             : coded_date;
  time             : coded_time;
  source_date      : coded_date;
  source_time      : coded_time;
  version          : integer;
--  $  if target = rc3502
--   compilerid  : compilerid_type;
--  $  endif
end;

(*  *)

function alias( var p: port; inspect name: string ): boolean;
external;

function clock_difference( t1, t2: clocktype ): coded_inc;
external;

function clock_increment( t: clocktype; inc: coded_inc ): clocktype;
external;

function clock_less_than( t1, t2: clocktype ): boolean;
external;

function crc16( op1, op2 : integer ): integer;
openroutine;


function crc16buf( var r: reference;
  frombyte, tobyte : integer;
  quotient, startvalue : integer ): integer;
external;

function deletemailbox(inspect mbx_name: string): integer;
external;

function getclock: clocktype;
external;

function imcpresent: boolean;
external;

procedure getservers( var r: reference; inspect mask: string );
external;

function namemailbox(var m: mailbox; inspect mbx_name: string): integer;
external;

function ownname(var name:string): byte;
external;

function ownprogramname(var name:string): byte;
external;

procedure ownversion(var myversion: tmoduleversion);
external;

function searchmailbox(inspect mbx_name: string): ^mailbox;
external;

procedure sendadam=sendadam__rc(var ref: reference );
external;

procedure sendlinker=sendlinkerrc(var ref: reference );
external;

procedure sendtimer=sendtimer_rc(var ref: reference );
external;

procedure setownname(inspect name: string );
external;

procedure setpriority(priority : integer);
external;

function swap(n: integer): integer;
openroutine;


(* implementation demendent open routines *)

--procedure breakpoint;
--external;

procedure  definetimer( on: boolean );
external;

--function equalhome(var a: rtype    ; var b: rtype    ): boolean;
--external;

--function homeless(var r: rtype    ): boolean;
--external;

function madd( a, b: integer): integer;
openroutine;


function mmul( a, b: integer): integer;
openroutine;


function msub( a, b: integer): integer;
openroutine;


function rotate( a, shl: integer): integer;
openroutine;


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


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


function ult( a, b: integer): boolean;
openroutine;


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


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


function usub( a, b: integer): integer;
openroutine;



(* input-output  interrupt routines *)
procedure clearinterrupt;
openroutine;


procedure control(c: integer; var chmsg: reference);
openroutine;


procedure controlclr(c: integer);
openroutine;


function ctrwaitid(c: integer; ms: integer): activation;
openroutine;


function ctrwaitim(c: integer; var r: reference; var m: mailbox): activation;
openroutine;


function ctrwaitimd(c: integer; var r: reference; var m: mailbox;
                   ms: integer ): activation;
openroutine;


function eoi : boolean;
openroutine;


type
 bufparamtype =  array ( 1..8 ) of byte;

procedure getbufparam(var bufparam : bufparamtype;
                      first, last: integer; var msg: reference);
openroutine;


procedure inbyteblock( var next : integer;
  first, last: integer;
  var msg : reference );
openroutine;


procedure inword(var word: integer; var chmsg: reference);
openroutine;


procedure inwordblock( var next : integer;
  first, last: integer;
  var msg : reference );
openroutine;


procedure inwordclr(var word: integer);
openroutine;


procedure iowbwc(bufparam : bufparamtype);
openroutine;


function messagekind( var r: reference ): integer;
openroutine;


procedure outbyteblock( var next : integer;
  first, last: integer;
  var msg : reference );
openroutine;


procedure outword(word : integer; var chmsg: reference);
openroutine;


procedure outwordblock( var next : integer;
  first, last: integer;
  var msg : reference );
openroutine;


procedure outwordclr(word : integer);
openroutine;


procedure sense(var status: integer; status_out : integer;
                var chmsg: reference);
openroutine;


procedure senseclr(var status: integer; status_out : integer;
                   compare, mask: integer);
openroutine;


procedure setinterrupt(var ch : reference);
openroutine;


function timedout: boolean;
openroutine;


procedure waiti;
openroutine;


function waitid( msecs: integer ): activation;
openroutine;


function waitim( var r: reference; var m : mailbox ): activation;
openroutine;


function waitimd ( var r: reference; var m : mailbox;
  msecs : integer ): activation;
openroutine;


(*             extra routines for imc                        *)
---------------------------------------------------------------

procedure excptcall ( errno: integer);
openroutine;


procedure signalx(var r: reference; var m:mailbox);
openroutine;


procedure returnx (var r:reference);
openroutine;


procedure setcreditcount ( var r:reference; credits: byte);
openroutine;


procedure seteventkind ( var r:reference; event: event_type);
openroutine;


procedure setindex ( var r:reference; index: byte);
openroutine;


procedure setreason ( var r:reference; reason: reason_type);
openroutine;


(*         other useful routines      *)
----------------------------------------

type
  xmem_no_type =  0..127;

  base_type  = packed record
    mem_no : xmem_no_type;
    nilbit : bit
    end;

  addr = record
   nulbyte : byte;
   base    : base_type;
   disp    : integer
  end;

  adr = record
   base    : base_type;
   disp    : integer
  end;


descriptor_segment = record
  descriptor_length,
  no_of_pages      ,
  pagesize         ,
  last_page_length ,
  kind             : integer;
  name             : alfa;
  entry_point      : addr;
  exception_point  : addr;
  default_appetite ,
  last_param_offset: integer;
  source_date      : coded_date;
  source_time      : coded_time;
  version          : integer;
  compilerid       : compilerid_type;
  no_of_params     : integer;
end;



function addptr ( anyptr: ^integer; incr: integer): ^integer;
openroutine;


function addrptr ( anyptr: ^integer): addr;
openroutine;


function baseinteger ( b: integer) : addr;
openroutine;


function carry : boolean;
openroutine;


procedure getaddr ( var dest: addr; src: addr);
openroutine;


procedure getbyte ( var dest: byte; srcaddr: addr);
openroutine;


function getid : integer;
openroutine;


procedure getinteger ( var dest: integer; srcaddr: addr);
openroutine;


procedure getlfgf ( var lf, gf: addr);
openroutine;


procedure getregister ( var dest: integer; index: integer);
openroutine;


function ptr ( a: byte): ^byte;
openroutine;


function ptr ( a: integer): ^integer;
openroutine;


function ptr ( p: ^integer): ^integer;
openroutine;


function ptr ( a: addr): ^integer;
openroutine;


function ptraddr ( a: addr): ^integer;
openroutine;


procedure putaddr ( a, b: addr);
openroutine;


procedure readbyte ( var dest, src: byte);
openroutine;


procedure readram ( var dest: byte; ramindex: integer);
openroutine;


procedure readword ( var dest, src: integer);
openroutine;


function ref_mailbox ( var m: mailbox): ^ mailbox;
openroutine;


procedure sensembx ( var r: reference; var m: mailbox);
openroutine;


procedure writeram ( ramindex, data: integer);
openroutine;


.