$listoff
stdenv;     (* standard environment       TOG 870927 *)

(***** PREDEFINED CONSTANTS *****)
CONST
maxint = 32767;
minint = -32768;


(***** PREDEFINED TYPES *****)
TYPE

bit = 0..1;

byte = 0..255;

conn_service = (cs_normal, cs_high);

const create_ok=0;
--    no_memory=1;
      create_no_memory=1;
      
type create_result = create_ok .. create_no_memory;

const
minpriority = 254;
stdpriority = 200;
maxpriority = 129;

type
prio_type=maxpriority..minpriority;

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);

const link_ok=0;
      file_not_found=1;
      file_not_object=2;
      no_mem=3;
      missing_subprogram=4;
      link_already_linked=5;
      link_not_found=6;
              
--    already_linked=5;
--    external_not_found=6;
      
type link_result=link_ok..link_not_found;

const unlink_ok=0;
      unlink_no_program_linked=1;
      unlink_program_busy=2;
--    no_program_linked=1;
--    existing_incarnations=2;
      
type unlink_result = unlink_ok .. unlink_program_busy;

const mem_private = 0;
      mem_dualport = 1;
      mem_bord = 2;

type mem_type = MEM_PRIVATE .. MEM_BORD;

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_mailbox, a_delay);

control_type = packed record 
                 rcv_all,
                 get_credit: boolean;
               end;
               
(* shielded type declarations *)
(******************************)

mailbox_ = record
  mbx:          INTEGER;
  s:            INTEGER;
  next:         ^integer; --^mailbox_
end;

pool_ = record
  mbx:          INTEGER;
  s:            INTEGER;
  size:         INTEGER;
  mem:          BYTE;
  bufs:         INTEGER;
  next:         ^integer; --^pool_
end;

process_ = record
  proc:         INTEGER;
  next:         ^integer; --^process_
end;

reference_ = record
  topbuf:       INTEGER;
  locked:       INTEGER;
  next:         ^integer; --^reference_
end;

chain_ = record
  curbuf:       INTEGER;
  locked:       INTEGER;
  start:        INTEGER;
  length:       INTEGER;
  next:         ^integer; --^chain_
end;

port_ = record
  prt:          INTEGER;
  state:        BYTE;
  next:         ^integer; --^port_
end;

program_descriptor= record
  state:        BYTE;
  paramdesc:    ^integer;
  poolparam:    BYTE;
  LBDR:         ^integer; --^extenal_lbdr
  prgname:      array(1..13) of char;
  count:        INTEGER;
  paramptr:     ^integer;
  noparams:     BYTE;
  next:         ^integer; --program_descriptor
end;


(*****  PREDEFINED ROUTINES  *****)
(*********************************)

code
$ save nolist
$ include(pi3.dcl)
$ restore

%set(xvarno,0)

%*define(beginopen(rtn))(
rtne%rtn DW size%rtn
x%eval(%xvarno) DW y%eval(%xvarno)
)

%*define(endopen(rtn))(
size%rtn EQU $-rtne%rtn
y%eval(%xvarno) EQU $-x%eval(%xvarno)-2
%set(xvarno,%xvarno+1)
)

%*define(extcall(routine))(
y%eval(%xvarno) EQU $-x%eval(%xvarno)-2
       DB 1                 ; external call
       DW %routine
%set(xvarno,%xvarno+1)
x%eval(%xvarno) DW y%eval(%xvarno)
)

F_RANGE              EQU 52

routine_fault        EQU 1
routine_resume       EQU 2
routine_allocpool    EQU 3

CodeMacro PUSH src:Db(-128,127)
DB 6AH
DB src
endM


%*define(fault(fcode))(
	PUSH %fcode
        %extcall(routine_fault)          
)

%*define(get_buf_seg) local nonfault
        (POP    SI                          ;ES:SI:=ptr_reference
        POP     ES
        CMP     ES:[SI].LOCKED,0;
        JGE     %NONFAULT
         %fault(F_NIL)
;        MOV     AL,F_NIL                    ;reference=NIL
;        INT     31
%NONFAULT:
        MOV     ES,ES:[SI].TOPBUF           ;ES:=buffer-frame)
end;

function abs(n: integer): 0..maxint;
begin 1
        POP     AX        ;AX:=abs(topword)
        CMP     AX,0
        JGE     ABS_EXIT
        NEG     AX
        INTO
ABS_EXIT:
END;

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

function allocdelay = getbufdelay(var r: reference; var p:pool; var ra: mailbox; 
                                  ms: 0..maxint): activation;
external;

function allocmempool = allocpool(var p: pool; no_of_bufs, bufsize: 0..maxint;
mem: mem_type): 0..maxint;
EXTERNAL;

function allocpool(var p: pool; no_of_bufs, bufsize: 0..maxint): 0..maxint;
begin 1
	XOR	AX,AX
	PUSH	AX
	%extcall(routine_allocpool)
end;

procedure break(VAR proc: process; fault: integer);
EXTERNAL;

function bufcount(var r: reference): 0..maxint;
begin 0
        %GET_BUF_SEG
        MOV     AX,ES:BUFCOUNT
END;

function bufsize(var r: rtype    ): 0..maxint;
begin 0
        %GET_BUF_SEG
        MOV     AX,ES:DATASIZE
END;

function bytecount(var r: rtype   ): 0..maxint;
begin 0
        %get_buf_seg
        MOV AX,ES: bytecount
end;

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): 0..maxint;
begin 0
        POP SI
        POP ES
        MOV AX,ES:[SI].c_length
end;

procedure chainreset(var ch: chain);
external;

procedure chainstart(var ch: chain);
external;

procedure chainup(var ch: chain);
external;

function ord(v: btype): integer;
begin 0
        POP     AX
        XOR     AH,AH
END;

function chr(v: byte): char;    and
function ord(v: wtype): integer; 
begin 0
        POP     AX
END;

function create(inspect incname: string; var prog: program_descriptor;
     var pr: process; size: 0..maxint; prio: prio_type): create_result;
external;

function creditcount(var r: reference): 0..maxint;
begin 0
        %get_buf_seg
        MOV AL,ES:creditcount
end;

procedure dec(var v: byte);
begin 0
        POP SI
        POP ES
        DEC ES:BYTE ptr[SI]
end;

procedure dec(var v: integer);
begin 0
        POP SI
        POP ES
        DEC ES:WORD ptr[SI]
end;

procedure delay(ms: 0..maxint);
external;

function eventkind(var r: rtype): event_type;
begin 0
        %get_buf_seg
        MOV AL,ES: eventkind
end;

procedure exception = fault(c: integer);
external;

function hometest(var r: rtype; var p: pool): boolean;
begin 0
        POP BX                   ; BX:=pool.offset   
        POP AX                   ; AX:=pool.segment   
        %get_buf_seg             ; ES:=buffer frame
        CMP BX,ES:WORD PTR home  ; ZF:=(home.offs=pool.offs)
        JNE hometest_1           ; if ZF then
        SUB AX,ES:WORD PTR home+2;   ZF:=(home.base=pool.base)
        JE  hometest_2           ; if ZF then AL:=FF else AL:=0
hometest_1:
        MOV AL,0FFH
hometest_2:
        INC AL
end;

procedure inc(var v:byte);
begin 0
        POP SI
        POP ES
        INC ES:BYTE PTR[SI]
end;

procedure inc(var v:integer);
begin 0
        POP SI
        POP ES
        INC ES:WORD PTR[SI]
end;

function index(var r:reference): byte;
begin 0
        %get_buf_seg
        MOV AL,ES:index
end;

function link(inspect incname: string;var prog: program_descriptor): 
              link_result;
external;
 
function locked(var m:mailbox): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP AX,ES:[SI].s
        JLE loced_1
        INC AX
loced_1:
end;

procedure new(var p: ptype); external;

function nil(var p:ptype  ): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP ES:WORD PTR [SI]+2,0
        JNE nil_1
        INC AX
nil_1:
end;

function nil(var p:reference): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP ES:WORD PTR [SI]+2,0FFFFH
        JNE nil_2
        INC AX
nil_2:
end;

function nil(var p:process): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP AX,ES:WORD PTR [SI]
        JNE nil_3
        INC AL
nil_3:
end;

function offset(var r:rtype    ): 0..maxint;
begin 0
        %get_buf_seg
        MOV AX,ES:dataoffset
end;

function open(var m:mailbox): boolean; and
function openpool(var p: pool): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP AX,ES:[SI].s
        JGE open_1
        INC AX
open_1:
end;

(* ord see chr *)

function passive(var m:mailbox): boolean;
begin 0
        POP SI
        POP ES
        SUB AX,AX
        CMP AX,ES:[SI].s
        JNE passive_1
        INC AX
passive_1:
end;

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

function pred(v: btype): btype;
begin 0
        POP BX
        POP AX
        CMP AL,BL
        JNE  pred_1
        %fault(F_RANGE)
pred_1:
        DEC AL
end;

function pred(v: wtype): wtype;
begin 0
        POP BX
        POP AX
        CMP AX,BX
        JNE  pred_2
        %fault(F_RANGE)
pred_2:
        DEC AX
end;

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

function reason(var r:reference): reason_type;
begin 0
        %get_buf_seg
        MOV AL,ES:reason
end;

procedure release = putbuf(var r: reference);
external;

function releasepool(var p:pool; bufs: 1..maxint): 0..maxint;
external;

procedure remove(var pr: process);
external;

procedure resetevent(var r: rtype);
begin 0
        %get_buf_seg
        MOV ES:eventkind,not_event
end;

procedure resume(var pr: process);
external;

procedure return(var r:reference);
external;

procedure setbytecount(var r: rtype    ; v: 0..maxint);
begin 0
        pop BX
        %get_buf_seg
        MOV ES:bytecount,BX
end;

procedure setoffset(var r: rtype    ; v: 0..maxint);
begin 0
        pop BX
        %get_buf_seg
        cmp BX,ES:datasize
        jle setoff_1
        %fault(F_RANGE)
;       int 29      
setoff_1:
        MOV ES:dataoffset,BX
end;

procedure settop(var r: rtype    ; v: 0..maxint);
begin 0
        pop BX
        %get_buf_seg
        cmp BX,ES:datasize
        jle settop_1
	%fault(F_RANGE)
;       int 29      
settop_1:
        MOV ES:top,BX
end;

procedure setu1(var r: rtype    ; v: byte);
begin 0
        pop BX
        %get_buf_seg
        MOV ES:u1,BL
end;

procedure setu2(var r: rtype    ; v: byte);
begin 0
        pop BX
        %get_buf_seg
        MOV ES:u2,BL
end;

procedure setu3(var r: rtype    ; v: byte);
begin 0
        pop BX
        %get_buf_seg
        MOV ES:u3,BL
end;

procedure setu4(var r: rtype    ; v: byte);
begin 0
        pop BX
        %get_buf_seg
        MOV ES:u4,BL
end;

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

function stackdepth(var r:reference  ): 0..maxint;
begin 0
        %get_buf_seg
        MOV AX,ES:depth
end;

procedure start(var pr: process; prio: prio_type);
begin 0
        pop     ax
        cli 
        test    DS: byte ptr own.p_state, 1
        JNZ     start_1
        mov     DS: byte ptr own.priority, al
start_1:
        sti
        %extcall(routine_resume)
end;

procedure stop(var p: process);
external;

function succ(v:btype): btype;
begin 0
        POP     BX
        POP     AX
        CMP     AL,BL
        JNE     SUCC_1
        %fault(F_RANGE)
succ_1:
        INC     AL
end;

function succ(v:wtype): wtype;
begin 0
        POP     BX
        POP     AX
        CMP     AX,BX
        JNE     SUCC_2
        %fault(F_RANGE)
succ_2:
        INC     AX
end;

procedure tofrom(var toref: reference; toindex: integer;
                 var fromref: reference; fromindex: integer;
                 bytes: integer );
EXTERNAL;

function top(var r:rtype    ): 0..maxint;
begin 0
        %get_buf_seg
        MOV     AX,ES:top
end;

procedure trace(f: integer);
external;

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

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

function u1(var r:rtype    ): byte;
begin 0
        %get_buf_seg
        MOV     AL,ES:u1
end;

function u2(var r:rtype    ): byte;
begin 0
        %get_buf_seg
        MOV     AL,ES:u2
end;

function u3(var r:rtype    ): byte;
begin 0
        %get_buf_seg
        MOV     AL,ES:u3
end;

function u4(var r:rtype    ): byte;
begin 0
        %get_buf_seg
        MOV     AL,ES:u4
end;

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

function waitdelay(var r: reference; var m: mailbox;
                   ms: 0..maxint): 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:0..maxint;
external;

procedure openport(var p:port; var closebuf: reference;
                   inspect name:string; scope: scope_type;
                   no_of_cons: byte; 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;

(* general implementation dependent standard routines and types *)

type
coded_date=RECORD
             year_after_1900: 0..127;
             month: 0..12;
             day: 0..31;
           END;
           
coded_time=RECORD
             ? : 0..31;
             hour: 0..23;
             minute: 0..59;
           END;
           
coded_secs=RECORD
             sec: 0..59;
             msec: 0..999;
           END;

coded_inc= 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;

tmoduleversion= RECORD
                  moduledate: coded_date;
                  moduletime: coded_time;
                  moduleversion: tversion;
                  compilationdate: coded_date;
                  compilationtime: coded_time;
                END;

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

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

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

FUNCTION deletemailbox(INSPECT mbx_name: string): integer;
EXTERNAL;

FUNCTION getclock: clocktype;
EXTERNAL;

FUNCTION namemailbox(VAR m: mailbox; INSPECT mbx_name: string): integer;
EXTERNAL;

FUNCTION ownname = own_name(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 sendtimer(VAR ref: reference );
EXTERNAL;

PROCEDURE setownname(INSPECT name: string );
EXTERNAL;

function swap(n: integer): integer;
begin 1
        POP     AX
        XCHG    AL,AH
END;

(* implementation dependent open routines *)

procedure breakpoint;
begin 4
        INT 3
end;

function data_segment(var r:rtype    ): integer;
begin 0
        %get_buf_seg
        MOV AX,ES:datapart
end;

procedure disable;
begin 0
        CLI
end;

procedure enable;
begin 0
        STI
end;

function equalhome(var a: rtype    ; var b: rtype    ): boolean;
begin 0
        %GET_BUF_SEG
        MOV     AX,ES: WORD PTR HOME
        MOV     BX,ES: WORD PTR HOME+2
        %GET_BUF_SEG
        SUB     AX,ES: WORD PTR HOME
        JNE     EQUALHOME_1
        SUB     BX,ES: WORD PTR HOME+2
        JE      EQUALHOME_2
EQUALHOME_1:
        MOV     AL,0FFH
EQUALHOME_2:
        INC     AL
END;

function first(var r:rtype    ): 0..maxint;
begin 0
        %get_buf_seg
        MOV AX,ES:dataoffset
end;

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

function input_byte(ioport: integer): byte;
begin 0
        pop     dx
        in      al,dx
end;

function input_word(ioport: integer): integer;
begin 0
        pop     dx
        in      ax,dx
end;

function last(var r:rtype    ): -1..maxint-1;
begin 0
        %get_buf_seg
        MOV     AX,ES:top
        DEC     AX
end;

function next(var r: rtype   ): 0..maxint;
begin 0
        %get_buf_seg
        MOV AX,ES: bytecount
        ADD AX,ES: dataoffset
end;

function mailbox_state(var m:mailbox): integer; and
function pool_state(var m:pool): integer;
begin 0
        POP SI
        POP ES
        MOV AX,ES:[SI].s
end;

procedure output_byte(ioport: integer; data: byte);
begin 0
        pop     ax
        pop     dx
        out     dx,al
end;

procedure output_word(ioport: integer; data: integer);
begin 0
        pop     ax
        pop     dx
        out     dx,ax
end;

function own_stack_bound: integer;
begin 0
        mov     ax, word ptr own.stackbound
end;

function own_stack_size: integer;
begin 0
        mov     ax, word ptr own.stacksize
end;

function ownpriority: byte;
begin 0
        mov     al, DS: byte ptr own.priority
end;

function priority(var p: process): byte;
begin 0
        pop     di
        pop     es
        mov     ax, es: [di].procvar
        cmp     ax,0
        jnz     priority_1
        %fault(F_NIL)
;       mov     al, f_nil
;       int     31
priority_1:
        mov     es, ax
        mov     al, es: priority
end;

function ref(var m: mailbox):^mailbox;
begin
	POP BX
	POP ES
end;

function rest_of_delay: integer;
begin 0
        mov     ax, word ptr own.timer
end;

procedure setfirst(var r: rtype    ; v: 0..maxint);
begin 0
        pop BX
        %get_buf_seg
        cmp BX,ES:datasize
        jle setfir_1
	%fault(F_RANGE)
;       int 29      
setfir_1:
        MOV CX,ES:dataoffset
        SUB CX,BX
        MOV ES:dataoffset,BX
        ADD ES:bytecount,CX
        CMP ES:depth,1
        JBE setfir_2
        MOV AX,ES:bufcount
        MOV ES,ES:stack
        CMP ES:bufcount,AX
        JZ  setfir_1
setfir_2:
end;

procedure setlast(var r: rtype    ; v: -1..maxint-1);
begin 0
        pop BX
        inc BX
        %get_buf_seg
        cmp BX,ES:datasize
        jle setlas_1
	%fault(F_RANGE)
;       int 29      
setlas_1:
        MOV ES:top,BX
        CMP ES:depth,1
        JBE setlas_2
        MOV AX,ES:bufcount
        MOV ES,ES:stack
        CMP ES:bufcount,AX
        JZ  setlas_1
setlas_2:
end;

procedure setnext(var r: rtype    ; v: 0..maxint);
begin 0
        pop BX
        %get_buf_seg
setnex_1:      
        MOV CX,BX
        SUB CX,ES:dataoffset
        MOV ES:bytecount,CX
        CMP ES:depth,1
        JBE setnex_2
        MOV AX,ES:bufcount
        MOV ES,ES:stack
        CMP ES:bufcount,AX
        JZ  setnex_1
setnex_2:
end;

procedure setpriority(prio: integer);
begin 0
        pop     ax
        cli 
        test    DS: byte ptr own.p_state, 1
        JNZ     set_priority_1
        mov     DS: byte ptr own.priority, al
set_priority_1:
        sti
end;

function stack_bound(var p: process): integer;
begin 0
        pop     di
        pop     es
        mov     ax, es: [di].procvar
        cmp     ax,0
        jnz     stackbound_1
	%fault(F_NIL)
;       mov     al, f_nil
;       int     31
stackbound_1:
        mov     es, ax
        mov     al, es: priority
end;

function stack_size(var p: process): integer;
begin 0
        pop     di
        pop     es
        mov     ax, es: [di].procvar
        cmp     ax,0
        jnz     stacksize_1
	%fault(F_NIL)
;       mov     al, f_nil
;       int     31
stacksize_1:
        mov     es, ax
        mov     ax, es: stacksize
end;


.