<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00000001
$SET X5=ON                                                              00001000
$COPYRIGHT "(c) Copyright Hewlett-Packard Company 1983.  All ",   &     00003100
$          "rights reserved.  This program may be used with ",    &     00003200
$          "one computer system at a time and shall not ",        &     00003300
$          "otherwise be recorded, transmitted or stored in a ",  &     00003400
$          "retrieval system.  Copying or other reproduction of ",&     00003500
$          "this program is prohibited without the prior ",       &     00003600
$          "written consent of Hewlett-Packard Company."                00003700
     B.01.07 - softint to iowait mode bug  6-23-83           <<00001>>  00019100
             - result code in Create'IOwaitport              <<00002>>  00019200
     B.01.08 - provide default aft cleanup 06/29/83          <<00003>>  00019300
             - added better error checking 7-6-83            <<00004>>  00019400
     B.02.01 - allocated separate pools for portCB, context  <<00005>>  00019500
               area, and msg frame. Got rid of old           <<00005>>  00019600
               InitPortDST.           7-10-83                <<00005>>  00019700
     B.02.01.01 - added two words to portheader for STUD     <<00006>>  00019800
                see Rick Bartlett  07-25-83                             00019900
     B.02.01.02 - added begin/end to defines and extra       <<00007>>  00019910
                  fields to port dst header 7/29/83          <<00007>>  00019920
     B.02.01.03 - corrected DSTSize Calculation 8/5/83       <<00008>>  00019930
     B.02.01.04 - fixed IOWaitPortDispatcher  8/11/83        <<00009>>  00019940
                  removed extraneous timer call  8/26/83     <<00011>>  00019960
     B.02.01.05 - zero out PortDST by myself  09/06/83       <<00013>>  00019970
     B.02.01.06 - changed SysPort sq 3 to 0   9/9/83         <<00014>>  00019980
     B.02.02.01 - replace SendMsg, RcvMsg, PortStatus with   <<00015>>  00019981
                  "non-enabling" versions.  09/09/83         <<00015>>  00019982
     B.02.02.02 - changed SysPort sq 0 to 4   9/21/83        <<00016>>  00019983
     B.02.02.03 - fixed sq enable in Receive'Wait 10/06/83   <<00017>>  00019984
     B.02.02.04 - fixed iowait & dict dst expansion 10/17/83 <<00018>>  00019985
     B.02.02.05 - delayed deletion of portdst  11/22/83      <<00019>>  00019986
     B.02.02.06 - fixed sf#617 on Deleteport 1/11/84         <<00020>>  00019987
     B.02.02.07 - fixed cleanup when createport' is out                 00019988
                  of context frames.  1/12/84                <<00021>>  00019989
     B.02.02.08 - fixed waiting window in ReceiveMsg 1/20/84 <<00022>>  00019990
       last'error'no = pxfile(4).(8:8)#,                                00038500
       last'error'no = pxfile(2).(1:15)#,                               00043500
<< DS appln services has subtype 7 allocated; see Charles >>            00080500
<< RFA & PTOP has subtype 2 allocated; see John or Brian  >>            00081500
                                                                        00081600
<< *** defines and equates for byte move stuff *** >>                   00081605
equate                                                                  00081610
   mpe4'entlen = %20;      << PCB entlen; = %25 for mpe5 >>             00081615
define                                                                  00081620
   dst'maxp    = dst(0)#,                                               00081625
   dst'entlen  = lsl(2)#,                                               00081630
   dst'seglen  = lsl(3)&lsr(1)#,                                        00081635
   pcb'entlenp = pcb(1)#,                                               00081640
   qstat'cce   = tos:=qstat;tos.(6:1):=1;tos.(7:1):=0;qstat:=tos#,      00081645
   ccf         = (6:2)#;                                                00081650
define                                                                  00081655
   switch'db   = push(db);                                              00081660
                 if tos = %1000d then                                   00081665
                 begin                                                  00081670
                    at'sysdbi:=at'sysdbi-1;                             00081675
                    resetdb(-1);                                        00081680
                 end;                                                   00081685
                 save'dst:=exchangedb#,                                 00081690
   restore'db  = tos:=exchangedb(save'dst);                             00081695
                 if at'sysdb then tos:=setsysdb#;                       00081700
integer                                                                 00081705
   s0     = s-0,                                                        00081715
   s1     = s-1,                                                        00081720
   s2     = s-2,                                                        00081725
   qstat  = q-1;                                                        00081730
logical                                                                 00081735
   cy:=false,                                                           00081740
   lx     = x,                                                          00081745
   ls0    = s-0;                                                        00081750
integer pointer                                                         00081755
   ps0    = s-0;                                                        00081760
integer pointer PortCBPoolHead = DB + 13,                    <<00005>>  00139100
                PortCBPoolTail = DB + 14,                    <<00005>>  00139200
                CtxPoolHead  = DB + 15,                      <<00005>>  00139300
                CtxPoolTail  = DB + 16;                      <<00005>>  00139400
integer         PrimaryCount  = DB + 17,                     <<00006>>  00139500
                SecondaryCount = DB + 18,                    <<00006>>  00139600
                PortDSTMaxPorts = DB + 19,                   <<00007>>  00139700
                PortDSTNumPorts = DB + 20,                   <<00019>>  00139750
                PortDSTUserSize = DB + 21;                   <<00019>>  00139800
equate PortDSTHeaderSize = 22,                               <<00019>>  00140000
       MsgHarbHeaderSize = 13;                               <<00005>>  00141000
       PortCB'free = PortCB(4).(13:1)#,                      <<00019>>  00151000
DEFINE db'to'PortDST =                                                  00203100
  disable;                                                              00203200
  pdisable;                                                             00203210
  x := PORTDST & LSL(2);                                                00203300
  tos := dst(x:=x+2);  << bank >>                                       00203400
  tos := dst(x:=x+1);  << addr >>                                       00203500
  asmb(ddup);                                                           00203510
  asmb(xchd)#;                                                          00203600
                                                                        00203700
    do begin  << absent  >>                                    <<b9358>>00214000
  if = then enable  << Pool empty  >>                          <<b9358>>00351000
$EDIT VOID=00377238                                          <<00007>>  00377020
define allocate'ctx'frame =                                  <<00005>>  00377030
  begin                                                      <<00007>>  00377035
  disable;                                                   <<00005>>  00377040
  @msg := @CtxPoolHead;                                      <<00005>>  00377050
  if <> then                                                 <<00005>>  00377060
    begin                                                    <<00005>>  00377070
    @CtxPoolHead := CtxPoolHead;                             <<00005>>  00377080
    if = then @CtxPoolTail := 0;                             <<00005>>  00377090
    end;                                                     <<00005>>  00377100
  enable;                                                    <<00005>>  00377110
  end#;                                                      <<00007>>  00377115
                                                             <<00005>>  00377120
define release'ctx'frame =                                   <<00005>>  00377130
  begin                                                      <<00007>>  00377135
  msg := 0;                                                  <<00005>>  00377140
  disable;                                                   <<00005>>  00377150
  if @CtxPoolHead <> 0 then                                  <<00005>>  00377160
    begin << Pool not empty, queue to tail >>                <<00005>>  00377170
    @CtxPoolTail := CtxPoolTail := @msg;                     <<00005>>  00377180
    end                                                      <<00005>>  00377190
  else                                                       <<00005>>  00377200
    begin << Pool was empty >>                               <<00005>>  00377210
    @CtxPoolHead := @CtxPoolTail := @msg;                    <<00005>>  00377220
    end;                                                     <<00005>>  00377230
  enable;                                                    <<00005>>  00377240
  end#;                                                      <<00007>>  00377245
                                                             <<00005>>  00377250
define allocate'portCB'frame =                               <<00005>>  00377260
  begin                                                      <<00007>>  00377265
  disable;                                                   <<00005>>  00377270
  @msg := @PortCBPoolHead;                                   <<00005>>  00377280
  if <> then                                                 <<00005>>  00377290
    begin                                                    <<00005>>  00377300
    @PortCBPoolHead := PortCBPoolHead;                       <<00005>>  00377310
    if = then @PortCBPoolTail := 0;                          <<00005>>  00377320
    end;                                                     <<00005>>  00377330
  enable;                                                    <<00005>>  00377340
  end#;                                                      <<00007>>  00377345
                                                             <<00005>>  00377350
define release'portCB'frame =                                <<00005>>  00377360
  begin                                                      <<00007>>  00377365
  msg := 0;                                                  <<00005>>  00377370
  disable;                                                   <<00005>>  00377380
  if @PortCBPoolHead <> 0 then                               <<00005>>  00377390
    begin << Pool not empty, queue to tail >>                <<00005>>  00377400
    @PortCBPoolTail := PortCBPoolTail := @msg;               <<00005>>  00377410
    end                                                      <<00005>>  00377420
  else                                                       <<00005>>  00377430
    begin << Pool was empty >>                               <<00005>>  00377440
    @PortCBPoolHead := @PortCBPoolTail := @msg;              <<00005>>  00377450
    end;                                                     <<00005>>  00377460
  enable;                                                    <<00005>>  00377470
  end#;                                                      <<00007>>  00377475
                                                             <<00005>>  00377480
procedure resetdb(dbx);                                                 00399200
   value dbx; integer dbx;                                              00399300
   option privileged, external;                                         00399400
                                                                        00399500
integer procedure setsysdb;                                             00399600
   option privileged, external;                                         00399700
procedure loosesoftinterrupts;                               <<00003>>  00420100
  option  external;                                          <<00003>>  00420200
                                                                        00420300
    move Version := "A0202008";                              <<00022>>  01007000
    move Version := "B0202008";                              <<00022>>  01009000
  logical delete'port;                                       <<00020>>  01106500
      Send'S(FindProcessPort(SysPort'pin),4,4);              <<00016>>  01176000
      delete'port := PortCB'delete;                          <<00020>>  01206500
      if Old'DST <> PortDST then exchangedb(Old'DST);        <<00020>>  01207500
      if delete'port then                                    <<00020>>  01208000
$EDIT VOID=01210000                                          <<00020>>  01210000
    if not (0 <= Subqueue <= 4) then suddendeath(badport);   <<00016>>  01331000
<<3>> Suddendeath(badport);                                  <<00016>>  01337000
<<4>> PortEnable(DelayedPortId);                             <<00016>>  01337500
  if not (2 <= Length <= PortDSTMaxMsgSize) then             <<00004>>  01403000
  if not (2 <= Length <= PortDSTMaxMsgSize) then             <<00004>>  01423000
  if not (0 <= Subqueue <= PortDSTMaxSubqueue) then          <<00004>>  01432000
    suddendeath(badportcall);<< +*+ >>                       <<00004>>  01432500
  logical firstime := true;  << to signal saving state>>     <<00017>>  01666500
  if firstime then OldMask := PortCB'mask; << save state>>   <<00017>>  01697000
  firstime := false; << don't save original state anymore>>  <<00017>>  01697100
  if not (2 <= Length <= PortDSTMaxMsgSize) then             <<00004>>  01791000
  if not (2 <= Length <= PortDSTMaxMsgSize) then             <<00004>>  01811000
  if not (0 <= Subqueue <= PortDSTMaxSubqueue) then          <<00004>>  01820000
    suddendeath(badportcall);<< +*+ >>                       <<00004>>  01820500
    msg := 0;                                                <<00019>>  01882100
    move msg(1) := msg,(PortDSTMaxMsgSize - 1);              <<00019>>  01882200
        badparm3 = 3,                                        <<00019>>  02141500
        outoframes = 9,                                      <<00005>>  02143500
equate  deletepending = 11;                                  <<00019>>  02144500
  if plabel > 0 then                                         <<00019>>  02158500
    begin Result := badparm3; go to Exit; end;               <<00019>>  02158600
    PortId := 0D;                                            <<00005>>  02160500
    if PortDSTMaxPorts < 0 then                              <<00019>>  02164100
       begin Status := deletepending; go to Done; end;       <<00019>>  02164200
    allocate'portCB'frame;                                   <<00005>>  02164300
    if @msg = 0 then                                         <<00005>>  02164400
      begin Status := outoframes; go to Done; end;           <<00005>>  02164500
$EDIT VOID=02166000                                          <<00005>>  02166000
    allocate'ctx'frame;                                      <<00005>>  02178000
    if @msg = 0 then                                         <<00005>>  02178100
      begin                                                  <<00021>>  02178200
        Status := outoframes;                                <<00021>>  02178300
        PortId := 0D;                                        <<00021>>  02178400
        release'message'frame;                               <<00021>>  02178500
        go to Done;                                          <<00021>>  02178600
      end;                                                   <<00021>>  02178700
    PortDSTNumPorts := PortDSTNumPorts + 1;                  <<00019>>  02187500
  logical release;                                           <<00019>>  02219500
  if PortCB'free then goto Done;                             <<00019>>  02225500
    release'ctx'frame;                                       <<00005>>  02245000
    release'ctx'frame;                                       <<00005>>  02258000
  PortCB'free := true;                                       <<00019>>  02262100
  PortDSTNumPorts := PortDSTNumPorts - 1;                    <<00019>>  02262200
  release := (PortDSTNumPorts=0) land (PortDSTMaxPorts<0);   <<00019>>  02262300
  release'portCB'frame;                                      <<00005>>  02264000
Done:                                                        <<00019>>  02265500
  if release then RelDataSeg(PortDST);                       <<00019>>  02269500
procedure DeletePortDST(portdst);                            <<00019>>  02270100
  value                 portdst;                             <<00019>>  02270200
 integer                portdst;                             <<00019>>  02270300
  option privileged, uncallable;                             <<00019>>  02270400
                                                             <<00019>>  02270500
  begin                                                      <<00019>>  02270600
                                                             <<00019>>  02270710
  exchangedb'to'PortDST;                                     <<00019>>  02270720
  if PortDSTNumPorts = 0  then                               <<00019>>  02270730
     RelDataSeg(portdst)                                     <<00019>>  02270740
  else                                                       <<00019>>  02270750
     PortDSTMaxPorts := -PortDSTMaxPorts;                    <<00019>>  02270760
                                                             <<00019>>  02270770
  exchangedb'back;                                           <<00019>>  02270780
                                                             <<00019>>  02270790
end;                                                         <<00019>>  02270800
$EDIT VOID=02387000                                          <<00005>>  02330000
  integer NumPorts;                                          <<00005>>  02404500
  turn'traps'off;                                            <<00008>>  02409500
$EDIT VOID=02419000                                          <<00005>>  02418000
              UnitSize * MaxPorts +                          <<00005>>  02421000
              MaxMsgSize * (PrimaryPool + SecondaryPool);    <<00005>>  02421500
  if OVERFLOW then begin Result := dstoobig; go to Exit; end;<<00008>>  02421700
    PortSegSize := PortSegSize + MaxContextSize*MaxPorts;    <<00008>>  02423000
  PortDST := GetDataSeg(PortSegSize, PortSegSize);           <<00013>>  02426000
  PortSegSize := DST'Size(PortDST);                          <<00013>>  02428000
  move msg(1) := msg,(PortSegSize-1);                        <<00013>>  02432000
  PortDSTSize := PortSegSize;                                <<00013>>  02435000
  PortDSTMaxPorts := MaxPorts;                               <<00007>>  02440500
  PortDSTUserSize := UserRegSize;                            <<00007>>  02440520
                                                             <<00005>>  02442100
<< setup pool of Port Control Blocks >>                      <<00005>>  02442150
NumPorts := MaxPorts;                                        <<00005>>  02442200
while NumPorts > 0 do                                        <<00005>>  02442250
  begin                                                      <<00005>>  02442300
  release'PortCB'frame;                                      <<00005>>  02442350
  @msg := @msg + UnitSize;                                   <<00005>>  02442400
  NumPorts := NumPorts - 1;                                  <<00005>>  02442450
  end;                                                       <<00005>>  02442500
                                                             <<00005>>  02442550
if MaxContextSize > 0 then                                   <<00005>>  02442600
  begin   << setup pool of Context Areas >>                  <<00005>>  02442650
  NumPorts := MaxPorts;                                      <<00005>>  02442700
  while NumPorts > 0 do                                      <<00005>>  02442750
    begin                                                    <<00005>>  02442800
    release'Ctx'frame;                                       <<00005>>  02442850
    @msg := @msg + MaxContextSize;                           <<00005>>  02442900
    NumPorts := NumPorts - 1;                                <<00005>>  02442950
    end;                                                     <<00005>>  02442960
  end;                                                       <<00005>>  02442970
                                                             <<00005>>  02442980
<< setup pool of message frames >>                           <<00005>>  02442990
  while @msg <= PortDSTSize - MaxMsgSize do                  <<00005>>  02443000
      @msg := @msg + MaxMsgSize;                             <<00005>>  02446000
  PrimaryCount := PoolCnt;                                   <<00007>>  02450100
  SecondaryCount := SecondaryPool;                           <<00007>>  02450120
Exit:                                                        <<00005>>  02452500
end;  << InitPortDST' >>                                                02457000
    if not (2 <= Length <= PortDSTMaxMsgSize) then           <<00004>>  02554000
    if not (2 <= Length <= PortDSTMaxMsgSize) then           <<00004>>  02588000
  if not (2 <= Length <= PortDSTMaxMsgSize) then             <<00004>>  02629000
  if not (0 <= Subqueue <= PortDSTMaxSubqueue) then          <<00004>>  02650000
    suddendeath(badportcall);<< +*+ >>                       <<00004>>  02650500
    if @msg = 0 then suddendeath(badport); << +*+ >>                    02729500
$EDIT VOID=02892000                                          <<00011>>  02892000
                  pxfile,                                    <<00009>>  03290500
        tos := DST'Size(Old'DST) - S0;                       <<00009>>  03382000
  if S0.(6:2) = 1 then       << if CCL >>                    <<00009>>  03431100
    begin                                                               03431200
    push(dl);                                                <<00009>>  03431300
    @pxfile := tos - PS0(-3);                                <<00009>>  03431400
    last'error'no := S0.(0:8);                               <<00009>>  03431500
    end;                                                     <<00009>>  03431700
  if Result > 1 then Result := Result - 1;                   <<00002>>  03602500
  logical to'iowait'mode;                                    <<00001>>  03634500
  integer dl, ioqx;                                          <<00001>>  03634600
  integer pointer aft;                                       <<00001>>  03634700
  if (Plabel <> 0) and (IOWait'count > 0)                    <<00001>>  03641500
    then suddendeath(badportcall);                           <<00001>>  03641600
  to'iowait'mode := (Plabel = 0) land                        <<00001>>  03643500
    (IOWait'softint'plabel <> 0) land                        <<00001>>  03643600
    (IOWait'count > 0);                                      <<00001>>  03643700
  ioqx := IOWait'aftioqx;                                    <<00001>>  03643800
  if to'iowait'mode then begin                               <<00001>>  03648100
    disable;                                                 <<00001>>  03648200
    PortCB'enabled := false;                                 <<00001>>  03648300
    enable;                                                  <<00001>>  03648400
    push(dl);  dl := tos;                                    <<00001>>  03648500
    @aft := - AFTindex * aftsize + dl - aft'base;            <<00001>>  03648600
    aft(to'ioqx) := ioqx;                                    <<00001>>  03648700
    end;                                                     <<00001>>  03648800
  equate entrysize = 2;                                      <<00018>>  03720500
    while @Index'element < newsize - 2*entrysize do          <<00018>>  03743000
      @Index'element := Index'element :=                     <<00018>>  03745000
                       @Index'element + entrysize;           <<00018>>  03745500
    Index'element := 0;                                      <<00018>>  03747500
    CurrentDSTSize := @Index'element + entrysize;            <<00018>>  03748000
byte array warnmsg(0:46);                                               03887500
  intrinsic print;                                           <<00003>>  03889500
  move warnmsg :=                                            <<00003>>  03923500
   "CLOSE PROCEDURE MISSING FOR SUBTYPE   (IPC 001)";        <<00003>>  03923600
  sort'index := 0;                                           <<00003>>  03925500
  while (sort'index:= sort'index+1) <= num'entries do        <<00003>>  03926000
          subtype'plabel := 0;                               <<00003>>  03943000
          aft := 0;                                          <<00003>>  03944000
          move aft(1) := aft,(aftsize - 1);                  <<00003>>  03945000
          ascii(sort'subtype, 10, warnmsg(36));              <<00003>>  03946000
  print(warnmsg, -47, %40);                                  <<00003>>  03947000
          go to next;                                        <<00003>>  03947500
next: end;                                                   <<00003>>  03956000
  LooseSoftInterrupts;                                       <<00003>>  03960500
$EDIT VOID=04288000                                          <<00015>>  03963000
PROCEDURE SENDMSG(DESTPIN, SUBQUEUE, MSGLENGTH, FLAGS);      <<00015>>  03963500
  VALUE           DESTPIN, SUBQUEUE, MSGLENGTH, FLAGS;                  03964000
  INTEGER         DESTPIN, SUBQUEUE, MSGLENGTH;                         03964500
  LOGICAL                                       FLAGS;                  03965000
  OPTION PRIVILEGED,UNCALLABLE;                                         03965500
                                                                        03966000
COMMENT                                                                 03966500
                                                                        03967000
SENDMSG IS CALLED TO DELIVER A SHORT MESSAGE OF MSGLENGTH WORDS         03967500
TO THE SPECIFIED SUBQUEUE OF THE PROCESS SPECIFIED BY DESTPIN.          03968000
                                                                        03968500
THE FLAGS PARAMETER CONTROLS THE PROCEDURE AS FOLLOWS :                 03969000
                                                                        03969500
    FLAGS.MSGWAKEUPFLAG=1 ==> WAKE-UP DESTINATION PROCESS        HM.XX  03970000
    FLAGS.MSGDONT'PREEMPTFLAG=1 ==> DON'T BOTHER PREEMPTING THE CURRENT 03970500
                                    PROCESS TO GET THIS MESSAGE         03971000
                                                                        03971500
SENDMSG EXPECTS THE FIRST WORD OF THE MESSAGE TO BE AT Q-7-MSGLENGTH    03972000
AND THE LAST WORD TO BE AT Q-8.  ON EXIT THE STACKED MESSAGE CONTENTS   03972500
ARE DELETED.                                                            03973000
                                                                        03973500
IF THE FLAGS SPECIFY THAT THE DESTINATION PROCESS BE AWAKENED, THE      03974000
RETURN CC IS SET TO CCG IF THE PROCESS IS ALREADY AWAKE.                03974500
                                                                        03975000
THE MESSAGE CONTENTS STACKED BY THE CALLER ARE DELETED ON THE EXIT      03975500
FROM SENDMSG.                                                           03976000
                                                                        03976500
;                                                                       03977000
                                                                        03977500
BEGIN                                                                   03978000
                                                                        03978500
DEFINE MSGDON'TPREEMPTFLAG = (2:1)#;                                    03982500
DEFINE MSGWAKEUPFLAG = (1:1)#;                                          03983000
                                                                        03983500
EQUATE PARMCNT=4,  <<INCOMING PARAMETER COUNT>>                         03984000
       LASTMSGWORD=3+PARMCNT;                                           03984500
                                                                        03985000
ARRAY MSGARRAY(*)=Q - LASTMSGWORD ; <<STARTS AT Q-7>>                   03985500
                                                                        03986000
COMMENT                                                                 03986500
                                                                        03987000
ALL CALLS TO THIS PROCEDURE SHOULD BE REPLACED WITH                     03987500
CALLS TO THE PORT PROCEDURE PRIMITIVES DIRECTLY.                        03988000
                                                                        03988500
;                                                                       03989000
EQUATE MAXSUBQUEUE = 4,    << SUBQUEUES 0-4 VALID >>                    03989500
       MAXMSGLENGTH = 4;                                                03990000
                                                                        03990500
DOUBLE PORTID;                                                          03991500
                                                                        03992000
INTEGER PIN;                                                            03992500
                                                                        03994000
INTEGER POINTER DESTMSG, MSG;                                           03994500
                                                                        03995000
  std'decl2;                                                            03995500
  std'decl;                                                             03995600
                                                                        03996500
  IF NOT ( 0 <= SUBQUEUE <= MAXSUBQUEUE) THEN                           03997000
    SUDDENDEATH(BADPORTCALL);                                           03997500
                                                                        03998000
  IF NOT (0 <= DESTPIN <= MAX'PIN) THEN                                 03998500
    SUDDENDEATH(BADPORTCALL);                                           03999000
                                                                        03999500
  IF NOT (0 <= MSGLENGTH <= MAXMSGLENGTH) THEN                          04000000
    SUDDENDEATH(BADPORTCALL);                                           04000500
                                                                        04001000
  PORTDST := MsgHarbTabDSTN;                                            04001500
  @PORTCB  := DESTPIN * MsgHarbPortLength + MsgHarbHeaderSize;          04002000
                                                                        04002500
  db'to'PortDST;                                                        04003000
                                                                        04003500
  << allocate'message'frame >>                                          04004000
  PoolCnt := PoolCnt - 1;                                               04004500
  if < then                                                             04005000
     begin  << $1 >>                                                    04005500
     on'ics;   << set tos if on ics, or pdisable > 1 >>                 04006000
     if (not tos) and logical(OldStatus.(1:1)) then                     04006500
       do begin  << $2 >>                                               04007000
         PoolCnt := PoolCnt + 1;                                        04007500
         WaitForMsg;  << does an exchangeDB'to'PortDST >>               04009000
         PoolCnt := PoolCnt - 1;                                        04021000
       end until >=;   << $2 >>                                         04021500
     end;   << $1 >>                                                    04022000
                                                                        04022500
  @msg := @MsgPoolHead;                                                 04023000
  if = then suddendeath(badport);                                       04023500
  @MsgPoolHead :=  MsgPoolHead;  << delink msg >>                       04024000
  if = then @MsgPoolTail := 0;   << pool now empty >>                   04024500
                                                                        04025000
  msg := 0;  << break msg link into free pool >>                        04025500
  msg(msg'length) := MSGLENGTH + 2;                                     04026000
                                                                        04026500
  << move data to message frame a word at a time >>                     04027000
  x := -MSGLENGTH ;                                                     04027500
  @destmsg := @msg - x + 2;                                             04028000
  do begin                                                              04028500
    destmsg(x) := MSGARRAY(x);                                          04029500
    end until IXBZ;                                                     04030000
                                                                        04030500
  << link to subqueue >>                                                04031000
  dbl'ptrs := PortCB'dbl(Subqueue + SubqueuesOffset);                   04031500
  if @qhead <> 0 then                                                   04032000
    begin  << not the first message >>                                  04032500
    @qtail := qtail := @msg;  << queue to tail >>                       04033000
    PortCB'dbl(x) := dbl'ptrs;                                          04033500
    end                                                                 04034000
  else                                                                  04034500
    begin  << first message in the queue >>                             04035000
    tos := tos := @msg;  << queue to the front >>                       04035500
    PortCB'dbl(x) := tos;                                               04036000
    set'message'bit;  << set flags to indicate a msg is present >>      04036500
    end;                                                                04037000
                                                                        04037500
  exchangeDB'back;                                                      04038000
                                                                        04039500
<<WAKE-UP DESTINATION PROCESS IF CALLER SO REQUESTED>>                  04040000
                                                                        04040500
IF FLAGS.MSGWAKEUPFLAG                                                  04041000
THEN AWAKE(DESTPIN*PCBSIZE,MSGWAITCODE,NOWAIT);                         04041500
IF DESTPIN=0 THEN                                                       04042000
   BEGIN  <<SPECIAL FOR SCHEDULER MESSAGES>>                            04042500
   IF ABSOLUTE(SYSDISPAWAKEMSG).DISPRUNNINGFLAG                         04043000
   AND NOT ABSOLUTE(SYSDISPAWAKEMSG).PAUSEDFLAG                         04043500
   THEN ABSOLUTE(SYSAWAKESCHEDMSG):=0 <<PREEMPT CUR ACT>>               04044000
    ELSE IF (NOT FLAGS.MSGDON'TPREEMPTFLAG)                             04044500
    OR (ABSOLUTE(SYSDISPAWAKEMSG).PAUSEDFLAG) THEN ASMB(DISP);          04045000
   END;                                                                 04045500
                                                                        04046000
<<BUILD AND EXECUTE AN EXIT INSTRUCTION TO DELETE STACKED MSG>>         04046500
                                                                        04047000
TOS:=MSGLENGTH+PARMCNT;  <<# OF PARAMETERS TO DELETE>>                  04047500
TOS:=TOS LOR (%31400);  <<BUILD EXIT INSTRUCTION>>                      04048000
ASMB(XEQ 0);                                                            04048500
END  <<PROCEDURE SENDMSG>>;                                             04049000
$PAGE "MESSAGE FACILITY INTRINSICS : PORT STATUS"                       04049500
INTEGER PROCEDURE PORTSTATUS(SUBQUEUE);                      <<00015>>  04050000
  VALUE                      SUBQUEUE;                                  04050500
  INTEGER                    SUBQUEUE;                                  04051000
  OPTION PRIVILEGED,UNCALLABLE;                                         04051500
                                                                        04052000
COMMENT                                                                 04052500
                                                                        04053000
WHEN SUPPLIED A VALID SUBQUEUE, PORTSTATUS RETURNS A TRUE               04053500
VALUE IF THE SUBQUEUE IS NON-EMPTY AND A FALSE VALUE IF THE SUBQUEUE    04054000
IS EMPTY.                                                               04054500
                                                                        04055000
WHEN PASSED A -1 AS PORTNUMBER PARAMETER, PORTSTATUS RETURNS            04055500
THE PORTNUMBER OF THE PROCESS' MOST URGENT NON-EMPTY SUBQUEUE (WHERE    04056000
THE CONVENTION OF LOWER NUMERICAL SUBQUEUE NUMBERS RELATING TO MORE     04056500
URGENT SUBQUEUE IS UNDERSTOOD).                                         04057000
                                                                        04057500
IF ALL SUBQUEUES ARE EMPTY, PORTSTATUS RETURNS CC=CCE.  IF AT LEAST     04058000
ONE SUBQUEUE IS NON-EMPTY, PORTSTATUS RETURNS CC=CCG.                   04058500
                                                                        04059000
;                                                                       04059500
                                                                        04060000
                                                                        04060500
BEGIN                                                                   04061000
                                                                        04061500
COMMENT                                                                 04062000
                                                                        04062500
ALL CALLS TO THIS PROCEDURE SHOULD BE REPLACED WITH                     04063000
CALLS TO THE PORT PROCEDURE PRIMITIVES DIRECTLY.                        04063500
                                                                        04064000
;                                                                       04064500
EQUATE MAXSUBQUEUE = 4,    << SUBQUEUES 0-4 VALID >>                    04065000
       MAXMSGLENGTH = 4;                                                04065500
                                                                        04066000
DOUBLE PORTID;                                                          04066500
                                                                        04067000
                                                                        04068500
  std'decl2;                                                            04069000
  std'decl;                                                             04069100
                                                                        04070000
  PORTDST := MsgHarbTabDSTN;                                            04070500
  @PORTCB  := if abs(CPCB) = 0 then                                     04071000
               MsgHarbHeaderSize                                        04071500
             else                                                       04072000
               curpin * MsgHarbPortLength + MsgHarbHeaderSize;          04072500
                                                                        04073000
  PORTSTATUS := FALSE;  << ASSUME NO MESSAGES PENDING >>                04073500
  CC := CCE;                                                            04074000
                                                                        04074500
  db'to'PortDST;                                                        04075000
                                                                        04078000
  tos := PortCB'flags;                                                  04078500
                                                                        04079000
ASSEMBLE( TEST );                                                       04079500
IF <> THEN                                                              04080000
  BEGIN  << AT LEAST ONE SUBQUEUE NON-EMPTY >>                          04080500
  CC := CCG;                                                            04081000
  IF SUBQUEUE <> -1 THEN                                                04081500
    BEGIN  << CHECK SPECIFIC SUBQUEUE >>                                04082000
    IF NOT (0 <= SUBQUEUE <= MAXSUBQUEUE) THEN                          04082500
      SUDDENDEATH(BADPORTCALL);                                         04083000
    << XREG SET BY COMPARE RANGE ABOVE >>                               04083500
    ASSEMBLE( TBC 0,X );                                                04084000
    IF <> THEN PORTSTATUS := TRUE;                                      04084500
    END                                                                 04085000
  ELSE                                                                  04085500
    BEGIN  << RETURN HIGHEST PRIORITY NON-EMPTY SUBQUEUE >>             04086000
    ASSEMBLE( SCAN );                                                   04086500
    PORTSTATUS := X;                                                    04087000
    IF X > MAXSUBQUEUE THEN SUDDENDEATH(BADPORT);                       04087500
    END;                                                                04088000
  END;                                                                  04088500
                                                                        04089000
  del;                                                                  04089500
                                                                        04090000
exchangeDB'back;                                                        04090500
                                                                        04092000
END  <<PROCEDURE PORTSTATUS>>;                                          04092500
$PAGE "MESSAGE FACILITY INTRINSICS : RECEIVE MESSAGE"                   04093000
PROCEDURE RECEIVEMSG(SUBQUEUE, MSGLENGTH, FLAGS);            <<00015>>  04093500
  VALUE              SUBQUEUE, MSGLENGTH, FLAGS;                        04094000
  INTEGER            SUBQUEUE, MSGLENGTH;                               04094500
  LOGICAL                                 FLAGS;                        04095000
  OPTION PRIVILEGED,UNCALLABLE;                                         04095500
                                                                        04096000
COMMENT                                                                 04096500
                                                                        04097000
RECEIVEMSG IS CALLED TO OBTAIN THE CONTENTS OF THE MESSAGE              04097500
AT THE HEAD OF THE CALLING PROCESS' MSG PORT (SPECIFIED                 04098000
BY SUBQUEUE PARAMETER).                                                 04098500
                                                                        04099000
THE CALLER OF RECEIVEMSG DOES AN ASMB(ADDS MSGLENGTH) TO MAKE           04099500
SPACE FOR THE MSG CONTENTS.  RECEIVEMSG DEPOSITS THE MSG CONTENTS       04100000
INTO Q-6-MSGLENGTH,...,Q-7, WITH THE FIRST WORD OF THE SENT             04100500
MESSAGE DEPOSITED INTO Q-6-MSGLENGTH.                                   04101000
                                                                        04101500
THE CALLER HAS THE OPTION OF A NON-DESTRUCTIVE READ OF THE MESSAGE.     04102000
FLAGS.MSGNONDESTRUCT=1 ==> RETURN CONTENTS OF MESSAGE, BUT LEAVE        04102500
                           MESSAGE AT THE HEAD OF THE SUBQUEUE.         04103000
FLAGS.MSGWAITONEMPTY=1 ==> WAIT THE CALLER ON A MESSAGE WAIT            04103500
                           IF THE QUEUE IS EMPTY. (PROCESS              04104000
                           WILL BE REAWAKENED WHEN SOMEBODY             04104500
                           SENDS A MESSAGE TO THE SPECIFIED             04105000
                           SUBQUEUE).                                   04105500
                                                                        04106000
STATUS IS RETURNED THRU THE CC AS FOLLOWS :                             04106500
                                                                        04107000
   IF ALL SUBQUEUES ARE EMPTY AND WAIT NOT SPECIFIED CC:=CCG.           04107500
   IF A MSG BEING RETURNED, CC:=CCE.                                    04108000
                                                                        04108500
                                                                        04109000
;                                                                       04109500
                                                                        04110000
BEGIN                                                                   04110500
                                                                        04111000
DEFINE MSGNONDESTRUCT = (0:1)#,                                         04111500
       MSGWAITONEMPTY = (1:1)#;                                         04112000
                                                                        04112500
EQUATE PARMCNT=3,                                                       04113000
       LASTMSGWORD=3+PARMCNT;                                           04113500
                                                                        04114000
ARRAY MSGARRAY(*)=Q - LASTMSGWORD ;  <<STARTS AT Q-6>>                  04114500
                                                                        04115000
COMMENT                                                                 04115500
                                                                        04116000
ALL CALLS TO THIS PROCEDURE SHOULD BE REPLACED WITH                     04116500
CALLS TO THE PORT PROCEDURE PRIMITIVES DIRECTLY.                        04117000
                                                                        04117500
;                                                                       04118000
EQUATE MAXSUBQUEUE = 4,    << SUBQUEUES 0-4 VALID >>                    04118500
       MAXMSGLENGTH = 4;                                                04119000
                                                                        04119500
DOUBLE PORTID;                                                          04120500
                                                                        04121000
INTEGER NEXTPIN,                                                        04122500
        PCB'INDEX;                                                      04123000
                                                                        04123500
INTEGER POINTER SOURCEMSG, MSG;                                         04124000
                                                                        04124500
LOGICAL SUBQUEUEMASK;                                                   04125000
                                                                        04125500
  std'decl2;                                                            04126000
  std'decl;                                                             04126100
                                                                        04127000
  PORTDST := MsgHarbTabDSTN;                                            04127500
  @PORTCB  := IF ABS(CPCB) = 0 THEN                                     04128000
               MsgHarbHeaderSize                                        04128500
             ELSE                                                       04129000
               curpin * MsgHarbPortLength + MsgHarbHeaderSize;          04129500
                                                                        04130000
<< SET THE SUBQUEUE MASK CORRESPONDING TO PORTNUM >>                    04130500
                                                                        04131000
TOS := 0;                                                               04131500
X := SUBQUEUE;                                                          04132000
ASSEMBLE( TSBC 0,X );                                                   04132500
SUBQUEUEMASK := TOS;                                                    04133000
                                                                        04133500
IF NOT ( 0 <= X <= MAXSUBQUEUE) THEN                                    04134000
  SUDDENDEATH(BADPORTCALL);                                             04134500
                                                                        04135000
CC := CCE;  << ASSUME EVERY THING WORKED >>                             04135500
                                                                        04136500
TRY'AGAIN:                                                              04136600
db'to'PortDST;                                                          04137000
                                                                        04140000
  << get pointer to first message on given subqueue >>                  04140500
  dbl'ptrs := PortCB'dbl(Subqueue + SubqueuesOffset);                   04141000
  @msg := @qhead;                                                       04141500
                                                                        04142000
  if @msg = 0 then                                                      04142500
    begin  << no message present      >>                                04143000
    IF FLAGS.MSGWAITONEMPTY THEN                                        04143500
      BEGIN                                                             04144000
      EXCHANGEDB'BACK;                                                  04144100
      WAIT(-MSGWAITCODE, NOINFO);                             <<00022>> 04144500
      GO TO TRY'AGAIN;                                                  04145000
      END                                                               04145500
    ELSE CC := CCG  << NOWAIT OPTION >>                                 04146000
    end                                                                 04146500
  else                                                                  04147000
    begin   << $1 return the message to the caller >>                   04147500
    x := msg(msg'length) - 2;                                           04148000
    if x > MSGLENGTH then suddendeath(badportcall);                     04148500
    x := -x ;                                                           04149000
    @sourcemsg := @msg - x + 2;                                         04149500
    do begin                                                            04150000
      MSGARRAY(x) := sourcemsg(x);                                      04150500
      end until IXBZ;                                                   04151000
                                                                        04151500
    if not FLAGS.MSGNONDESTRUCT then                                    04152000
      begin  << $2 >>                                                   04152500
      dequeue'message;                                                  04153000
                                                                        04153500
     << return the msg back to the free pool >>                         04154000
      msg := 0;                                                         04154500
      if @MsgPoolHead <> 0 then                                         04155000
        begin << Pool not empty, queue to tail >>                       04155500
        @MsgPoolTail := MsgPoolTail := @msg;                            04156000
        end                                                             04156500
      else                                                              04157000
        begin << Pool was empty >>                                      04157500
        @MsgPoolHead := @MsgPoolTail := @msg;                           04158000
        end;                                                            04158500
      PoolCnt := PoolCnt + 1;                                           04159000
      if > and ProcHead <> 0 then AwakeForMsg;                          04160000
      end;  << $2 >>                                                    04168000
    end;  << $1 >>                                                      04168500
                                                                        04169000
  exchangeDB'back;                                                      04169500
                                                                        04171500
                                                                        04172000
END  <<PROCEDURE RECEIVEMSG>>;                                          04172500
      while @Dict'element < newsize - 2*Dict'EntrySize do    <<00018>>  04491000
      Dict'element := 0;                                     <<00018>>  04495500
$Page                                                                   04581001
                                                                        04581002
Procedure MTDS (SourceDST,DSToffset,Buffer,Count);                      04581003
Value SourceDST,DSToffset,Count;                                        04581004
Integer SourceDST,DSToffset,Count;                                      04581005
Integer array Buffer;                                                   04581006
OPTION PRIVILEGED,UNCALLABLE <<,UNREADABLE>>;                           04581007
COMMENT:   This routine will move data to a specified data              04581008
           segment.  It is heavily dependent on structures              04581009
           in MPE and should be rewritten for use on VCF.               04581010
                                                                        04581011
           Status return:                                               04581012
           CCE - Successful completion.                                 04581013
           CCL - Invalid segment number or move count.                  04581014
           CCG - Invalid starting address or bounds violation;          04581015
                                                                        04581016
Begin                                                                   04581017
Integer Status = Q-1;                                                   04581018
Integer pointer PXglobal;                                               04581019
Integer DLreg,DSTlength,LowerLimit,Qreg,TargetDST,UpperLimit;           04581020
                                                                        04581021
Status.CCF := CCE;           << Assume successful completion >>         04581022
                                                                        04581023
DSTlength := DST'size (SourceDST);                                      04581024
If <> OR Count < 0 then                                                 04581025
   Begin                                                                04581026
                                                                        04581027
<< Caller specified an invalid segment number or move count. >>         04581028
                                                                        04581029
   Status.CCF := CCL;                                                   04581030
   Return;                                                              04581031
   End;                                                                 04581032
                                                                        04581033
If DSToffset < 0 OR DSToffset+Count > DSTlength then                    04581034
   Begin                                                                04581035
                                                                        04581036
<< Starting address/move count will cause a bounds violation >>         04581037
<< in the specified source data segment, so return an error. >>         04581038
                                                                        04581039
   Status.CCF := CCG;                                                   04581040
   Return;                                                              04581041
   End;                                                                 04581042
                                                                        04581043
TargetDST := Wheres'DB;                                                 04581044
If = then                                                               04581045
   Begin                                        << At stack  >>         04581046
   PUSH (Q,DL);                                                         04581047
   @PXglobal := TOS-PS0(-1);                                            04581048
   LowerLimit := -PXglobal(1);                                          04581049
   UpperLimit := TOS-%10;                                               04581050
   End                                                                  04581051
Else                                                                    04581052
   If > then                                                            04581053
      Begin                                     << At an XDS >>         04581054
      LowerLimit := 0;                                                  04581055
      UpperLimit := DST'size (TargetDST)-1;                             04581056
      If <> then Return;                                                04581057
      End                                                               04581058
   Else                                                                 04581059
      Begin                                     << At ABS DB >>         04581060
      LowerLimit := 0;                                                  04581061
      UpperLimit := %377;                                               04581062
      End;                                                              04581063
                                                                        04581064
If @Buffer < LowerLimit OR @Buffer+Count-1 > UpperLimit then            04581065
   Begin                                                                04581066
                                                                        04581067
<< Starting address/move count will cause a bounds violation >>         04581068
<< at the caller's current DB setting, so return an error.   >>         04581069
                                                                        04581070
   Status.CCF := CCG;                                                   04581071
   Return;                                                              04581072
   End;                                                                 04581073
                                                                        04581074
TOS := SourceDST;                          << Segment number >>         04581075
TOS := DSToffset;                          << Seg-rel offset >>         04581076
TOS := @Buffer;                            << DB-rel source  >>         04581077
TOS := Count;                              << Words to move  >>         04581078
ASMB (MTDS 4);                                                          04581079
End;                                                                    04581080
                                                                        04581081
$Page                                                                   04581082
                                                                        04581083
Procedure MFDS (Buffer,TargetDST,DSToffset,Count);                      04581084
Value TargetDST,DSToffset,Count;                                        04581085
Integer TargetDST,DSToffset,Count;                                      04581086
Integer array Buffer;                                                   04581087
OPTION PRIVILEGED,UNCALLABLE <<,UNREADABLE>>;                           04581088
COMMENT:   This routine will move data from a specified data            04581089
           segment.  It is heavily dependent on structures              04581090
           in MPE and should be rewritten for use on VCF.               04581091
                                                                        04581092
           Status return:                                               04581093
           CCE - Successful completion.                                 04581094
           CCL - Invalid segment number or move count.                  04581095
           CCG - Invalid starting address or bounds violation;          04581096
                                                                        04581097
Begin                                                                   04581098
Integer Status = Q-1;                                                   04581099
Integer pointer PXglobal;                                               04581100
Integer DLreg,DSTlength,LowerLimit,Qreg,SourceDST,UpperLimit;           04581101
                                                                        04581102
Status.CCF := CCE;           << Assume successful completion >>         04581103
                                                                        04581104
DSTlength := DST'size (TargetDST);                                      04581105
If <> OR Count < 0 then                                                 04581106
   Begin                                                                04581107
                                                                        04581108
<< Caller specified an invalid segment number or move count. >>         04581109
                                                                        04581110
   Status.CCF := CCL;                                                   04581111
   Return;                                                              04581112
   End;                                                                 04581113
                                                                        04581114
If DSToffset < 0 OR DSToffset+Count > DSTlength then                    04581115
   Begin                                                                04581116
                                                                        04581117
<< Starting address/move count will cause a bounds violation >>         04581118
<< in the specified target data segment, so return an error. >>         04581119
                                                                        04581120
   Status.CCF := CCG;                                                   04581121
   Return;                                                              04581122
   End;                                                                 04581123
                                                                        04581124
SourceDST := Wheres'DB;                                                 04581125
If = then                                                               04581126
   Begin                                        << At stack  >>         04581127
   PUSH (Q,DL);                                                         04581128
   @PXglobal := TOS-PS0(-1);                                            04581129
   LowerLimit := -PXglobal(1);                                          04581130
   UpperLimit := TOS-%10;                                               04581131
   End                                                                  04581132
Else                                                                    04581133
   If > then                                                            04581134
      Begin                                     << At an XDS >>         04581135
      LowerLimit := 0;                                                  04581136
      UpperLimit := DST'size (SourceDST)-1;                             04581137
      If <> then Return;                                                04581138
      End                                                               04581139
   Else                                                                 04581140
      Begin                                     << At ABS DB >>         04581141
      LowerLimit := 0;                                                  04581142
      UpperLimit := %377;                                               04581143
      End;                                                              04581144
                                                                        04581145
If @Buffer < LowerLimit OR @Buffer+Count-1 > UpperLimit then            04581146
   Begin                                                                04581147
                                                                        04581148
<< Starting address/move count will cause a bounds violation >>         04581149
<< at the caller's current DB setting, so return an error.   >>         04581150
                                                                        04581151
   Status.CCF := CCG;                                                   04581152
   Return;                                                              04581153
   End;                                                                 04581154
                                                                        04581155
TOS := @Buffer;                            << DB-rel target  >>         04581156
TOS := TargetDST;                          << Segment number >>         04581157
TOS := DSToffset;                          << Seg-rel offset >>         04581158
TOS := Count;                              << Words to move  >>         04581159
ASMB (MFDS 4);                                                          04581160
End;                                                                    04581161
                                                                        04581162
$Page                                                                   04581163
                                                                        04581164
Comment                                                                 04581165
                                                                        04581166
                                                                        04581167
         Sorc  Dest  Len                                                04581168
         ====  ====  ===                                                04581169
                                                                        04581170
                                                                        04581171
         Word ------------->  |xx|xx|xx|  |                             04581172
                     Even                                               04581173
               Word ------->  |xx|xx|xx|  |                             04581174
                                                                        04581175
                                                                        04581176
                                                                        04581177
         Word ------------->  |xx|xx|xx|x |                             04581178
                     Odd                                                04581179
               Word ------->  |xx|xx|xx|x |                             04581180
                                                                        04581181
                                                                        04581182
                                                                        04581183
         Word ------------->  |xx|xx|xx|  |                             04581184
                     Even      \        \                               04581185
               Byte ------->  | x|xx|xx|x |                             04581186
                                                                        04581187
                                                                        04581188
                                                                        04581189
         Word ------------->  |xx|xx|xx|x |                             04581190
                     Odd       \         \                              04581191
               Byte ------->  | x|xx|xx|xx|                             04581192
                                                                        04581193
                                                                        04581194
                                                                        04581195
         Byte ------------->  | x|xx|xx|x |                             04581196
                     Even      /        /                               04581197
               Word ------->  |xx|xx|xx|  |                             04581198
                                                                        04581199
                                                                        04581200
                                                                        04581201
         Byte ------------->  | x|xx|xx|xx|                             04581202
                     Odd       /         /                              04581203
               Word ------->  |xx|xx|xx|x |                             04581204
                                                                        04581205
                                                                        04581206
                                                                        04581207
         Byte ------------->  | x|xx|xx|x |                             04581208
                     Even                                               04581209
               Byte ------->  | x|xx|xx|x |                             04581210
                                                                        04581211
                                                                        04581212
                                                                        04581213
         Byte ------------->  | x|xx|xx|xx|                             04581214
                     Odd                                                04581215
               Byte ------->  | x|xx|xx|xx|                             04581216
;                                                                       04581217
$page                                                                   04581218
procedure mbds(dest'dst,dest'addr,sorc'dst,sorc'addr,len);              04581219
   value       dest'dst,dest'addr,sorc'dst,sorc'addr,len;               04581220
   integer     dest'dst,          sorc'dst;                             04581221
   logical     dest'addr,                  sorc'addr,len;               04581222
   option privileged,uncallable;                                        04581223
begin                                                                   04581224
   entry                                                                04581225
      mbds';                                                            04581226
   integer                                                              04581227
      save'dst = dest'dst,                                              04581228
      ilen     = len;                                                   04581229
   double                                                               04581230
      dest'loc = dest'dst,                                              04581231
      sorc'loc = sorc'dst;                                              04581232
   byte pointer                                                         04581233
      dest'bp  = dest'addr;                                             04581234
                                                                        04581235
   logical                                                              04581236
      at'sysdb   = q+1;                                                 04581237
   integer                                                              04581238
      at'sysdbi  = at'sysdb,                                            04581239
      save'firstb= at'sysdb+1,          << re-usable loc >>             04581240
      save'lastb = save'firstb+1,       << unused dest'dst here >>      04581241
      save'byte  = save'lastb;                                          04581242
                                                                        04581243
   tos:=dst'maxp;                       << dst'max >>                   04581244
   if s0  < dest'dst then go bad'dst;   << illegal dst >>               04581245
   if tos < sorc'dst then go bad'dst;   << illegal dst >>               04581246
   tos:=dest'dst;                                                       04581247
   if <= then go bad'dst;               << illegal dst >>               04581248
   tos:=dst(tos&dst'entlen)&dst'seglen;   << dest'dstsz >>              04581249
   if = then go bad'dst;                << unassigned dst >>            04581250
   tos:=sorc'dst;                                                       04581251
   if <= then go bad'dst;               << illegal dst >>               04581252
   tos:=dst(tos&dst'entlen)&dst'seglen;   << sorc'dstsz >>              04581253
   if = then                            << unassigned dst >>            04581254
   begin                                                                04581255
bad'dst:                                                                04581256
      qstat.ccf:=ccl;                                                   04581257
      go exit;                                                          04581258
   end;                                                                 04581259
   lx:=len+1;                           << must use logical arith. >>   04581260
   if = then go out'of'bounds;          << greater than abs. max >>     04581261
   tos:=(sorc'addr+lx)&lsr(1);          << x = len+1 >>                 04581262
   if carry then go out'of'bounds;      << sorc dst overflow >>         04581263
   if tos < tos then go out'of'bounds;  << sorc'dstsz < tos? >>         04581264
   tos:=(dest'addr+lx)&lsr(1);          << x = len+1 >>                 04581265
   if carry then go out'of'bounds;      << dest dst overflow >>         04581266
   if tos < tos then                    << dest'dstsz < tos? >>         04581267
   begin                                                                04581268
out'of'bounds:                                                          04581269
      qstat.ccf:=ccg;                                                   04581270
      go exit;                                                          04581271
   end;                                                                 04581272
mbds':                                                                  04581273
   qstat'cce;                           << qstat.ccf:=cce >>            04581274
   tos:=0d;                             << at'sysdb, save'firstb >>     04581275
   tos:=dest'loc;                       << dst, addr >>                 04581276
   tos:=tos&lsr(1);                     << word address >>              04581277
   tos:=sorc'loc;                       << dst, addr >>                 04581278
   tos:=tos&lsr(1);                     << word address >>              04581279
   x:=ilen;                                                             04581280
   tos:=(x+1)&lsr(1);                   << word count >>                04581281
   if = then go exit;                   << no move >>                   04581282
   if sorc'addr then                                                    04581283
   begin                                                                04581284
      switch'db(dest'dst);                                              04581285
      if dest'addr then                                                 04581286
         if lx then                     << x = len >>                   04581287
         begin      << sorc: byte   dest: byte   len: odd  >>           04581288
            save'byte:=dest'bp(-1);                                     04581289
            asmb(mfds);                                                 04581290
            dest'bp(x):=tos;            << x=-1; tos=save'byte >>       04581291
         end else                                                       04581292
         begin      << sorc: byte   dest: byte   len: even >>           04581293
            @dest'bp:=@dest'bp-1;                                       04581294
            save'firstb:=dest'bp;                                       04581295
            tos:=tos+1;                 << need extra word >>           04581296
            save'lastb:=dest'bp(x:=x+1);<< x:=x+1 = len+1 >>            04581297
            asmb(mfds);                                                 04581298
            dest'bp(x):=tos;            << x=len+1; tos=save'lastb >>   04581299
            dest'bp:=tos;               << tos=save'firstb >>           04581300
         end                                                            04581301
      else                                                              04581302
         if lx then                     << x = len >>                   04581303
         begin      << sorc: byte   dest: word   len: odd  >>           04581304
            save'lastb:=dest'bp(x);     << x = len >>                   04581305
            asmb(mfds);                                                 04581306
            tos:=dest'addr;                                             04581307
            tos:=s0+1;                  << dest'addr(1) >>              04581308
            move *:=*,(x);              << dest:=dest(1),(len) >>       04581309
            dest'bp(x):=tos;            << x=len; tos=save'lastb >>     04581310
         end else                                                       04581311
         begin      << sorc: byte   dest: word   len: even >>           04581312
            asmb(mfds 1);               << leave dst, addr's on stack >>04581313
            save'lastb:=dest'bp(x:=x-1);<< x:=x-1 = len-1 >>            04581314
            tos:=dest'addr;                                             04581315
            tos:=s0+1;                  << dest'addr(1) >>              04581316
            move *:=*,(x:=x-1);         << dest:=dest(1),(len-2) >>     04581317
            s2:=s2-1;                   << back up dest'wp >>           04581318
            tos:=1;                                                     04581319
            asmb(mfds);                 << get last byte >>             04581320
            tos:=dest'bp(x);            << x = len-2 >>                 04581321
            dest'bp(x):=save'lastb;     << next-to-last >>              04581322
            dest'bp(x:=x+1):=tos;       << last byte >>                 04581323
         end;                                                           04581324
      restore'db;                                                       04581325
exit:                                                                   04581326
      return;                                                           04581327
   end;                                                                 04581328
   begin                                                                04581329
      if dest'addr then                                                 04581330
      begin         << sorc: word   dest: byte   len: any  >>           04581331
         switch'db(dest'dst);                                           04581332
         @dest'bp:=@dest'bp-1;                                          04581333
         save'byte:=dest'bp;                                            04581334
         asmb(mfds);                                                    04581335
         move dest'bp(x):=dest'bp(x:=x-1),(not lx);                     04581336
         dest'bp:=tos;                  << tos=save'byte >>             04581337
         restore'db;                                                    04581338
         return;                                                        04581339
      end;                                                              04581340
         if lx then                     << x = len >>                   04581341
         begin      << sorc: word   dest: word   len: odd  >>           04581342
            switch'db(dest'dst);                                        04581343
            save'lastb:=dest'bp(x);     << x = len >>                   04581344
            asmb(mfds);                                                 04581345
            dest'bp(x):=tos;            << x=len; tos=save'lastb >>     04581346
            restore'db;                                                 04581347
            return;                                                     04581348
         end;                                                           04581349
         asmb(mds); << sorc: word   dest: word   len: even >>           04581350
   end;                                                                 04581351
end;                << mbds >>                                          04581352
                                                                        04581353
$page                                                                   04581354
                                                                        04581355
procedure mbfds(dest'addr,sorc'dst,sorc'addr,len);                      04581356
   value        dest'addr,sorc'dst,sorc'addr,len;                       04581357
   integer                sorc'dst;                                     04581358
   logical      dest'addr,         sorc'addr,len;                       04581359
   option privileged,uncallable;                                        04581360
begin                                                                   04581361
   entry                                                                04581362
      mbfds';                                                           04581363
   integer                                                              04581364
      ilen     = len;                                                   04581365
   double                                                               04581366
      sorc'loc = sorc'dst;                                              04581367
   byte pointer                                                         04581368
      dest'bp  = dest'addr;                                             04581369
                                                                        04581370
   logical                                                              04581371
      mpe5       = q+2;                                                 04581372
   integer                                                              04581373
      save'firstb= q+1,                 << re-usable loc's >>           04581374
      save'lastb = save'firstb+1,       << "             " >>           04581375
      save'byte  = save'lastb;                                          04581376
                                                                        04581377
   asmb(dzro,deca);                     << filler; mpe5:=true >>        04581378
   tos:=abs(cpcb)+2;                    << current pcb entry >>         04581379
   if pcb'entlenp = mpe4'entlen then                                    04581380
   begin                                                                04581381
      tos:=abs(pcbb);                   << convert to pcb relative >>   04581382
      asmb(sub,incb);                   << mpe5:=false >>               04581383
   end;                                                                 04581384
   tos:=pcb(tos);                      << get pcb02 entry >>            04581385
   if < then go bad'dst;                << absolute db >>               04581386
   tos:=sorc'dst;                                                       04581387
   if <= then go bad'dst;               << invalid dst >>               04581388
   if s0 > dst'maxp then go bad'dst;    << invalid dst >>               04581389
   tos:=dst(tos&dst'entlen)&dst'seglen;   << sorc'dstsz >>              04581390
   if = then                            << unassigned dst >>            04581391
   begin                                                                04581392
bad'dst:                                                                04581393
      qstat.ccf:=ccl;                                                   04581394
      go exit;                                                          04581395
   end;                                                                 04581396
   lx:=len+1;                           << must use logical arith. >>   04581397
   if = then go out'of'bounds;          << greater than abs. max >>     04581398
   tos:=(sorc'addr+lx)&lsr(1);          << x = len+1 >>                 04581399
   if carry then go out'of'bounds;      << sorc dst overflow >>         04581400
   if tos < tos then go out'of'bounds;  << sorc'dstsz < tos? >>         04581401
   if mpe5 then tos:=tos.(2:14) else tos:=tos.(1:10);                   04581402
   if <> then                                                           04581403
   begin                                << XDS <> 0 => Split stack >>   04581404
      tos:=tos&dst'entlen;              << dest'dst# * dst'entlen >>    04581405
      tos:=(dest'addr+lx)&lsr(1);       << x = len+1 >>                 04581406
      if carry then go out'of'bounds;   << dest dst overflow >>         04581407
      asmb(stbx,delb);                  << x := dst# * dst'entlen >>    04581408
      if tos > dst(x) then go out'of'bounds;                            04581409
      tos:=dest'addr&lsr(1);            << word address >>              04581410
   end else                                                             04581411
   begin                                << at stack >>                  04581412
      tos:=dest'addr&lsr(1);            << word address (dest'wp) >>    04581413
      asmb(delb,dup);                   << del dst#; copy dest'wp >>    04581414
      tos:=dest'addr+lx;                << x = len+1 >>                 04581415
      if carry then go out'of'bounds;   << dest dst overflow >>         04581416
      if tos&asr(1) > @dest'addr then go out'of'bounds;                 04581417
      push(s);                                                          04581418
      if tos > tos then tos.(0:1):=1;   << db-minus >>                  04581419
      push(dl);                                                         04581420
      if tos-ps0(-1) > s1 then          << dest dst underflow >>        04581421
      begin                                                             04581422
out'of'bounds:                                                          04581423
         qstat.ccf:=ccg;                                                04581424
         go exit;                                                       04581425
      end;                                                              04581426
   end;                                                                 04581427
   go do'mbfds;                                                         04581428
mbfds':                                                                 04581429
   tos:=0d;                             << save'firstb, save'lastb >>   04581430
   tos:=dest'addr&lsr(1);               << word address >>              04581431
   push(s,z,dl,db,sbank);                                               04581432
   asmb(delb,cmp);                      << del db; only need dbbank >>  04581433
   if = then                            << sbank = dbbank? >>           04581434
   begin                                                                04581435
      asmb(zrox,xch);                   << xch z,dl >>                  04581436
      if tos <= x <= tos then           << at stack >>                  04581437
      begin                                                             04581438
         if tos < s1 then tos.(0:1):=1; << db-minus >>                  04581439
      end else del;                     << clean up stack >>            04581440
   end else asmb(ddel,del);             << "            " >>            04581441
do'mbfds:                                                               04581442
   qstat'cce;                           << qstat.ccf:=cce >>            04581443
   tos:=sorc'loc;                       << dst, addr >>                 04581444
   tos:=tos&lsr(1);                     << word address >>              04581445
   x:=ilen;                                                             04581446
   tos:=(x+1)&lsr(1);                   << word count >>                04581447
   if = then go exit;                   << no move >>                   04581448
   if sorc'addr then                                                    04581449
   begin                                                                04581450
      if dest'addr then                                                 04581451
      begin                                                             04581452
         @dest'bp:=@dest'bp-1;                                          04581453
         if lx then                     << x = len >>                   04581454
         begin      << sorc: byte   dest: byte   len: odd  >>           04581455
            save'byte:=dest'bp;                                         04581456
            asmb(mfds);                                                 04581457
            dest'bp:=tos;               << tos=save'byte >>             04581458
exit:                                                                   04581459
            return;                                                     04581460
         end;                                                           04581461
         begin      << sorc: byte   dest: byte   len: even >>           04581462
            tos:=tos+1;                 << need extra word >>           04581463
            save'lastb:=dest'bp(x:=x+1);<< x:=x+1 = len+1 >>            04581464
            save'firstb:=dest'bp;                                       04581465
            asmb(mfds);                                                 04581466
            dest'bp(x):=tos;            << x=len+1; tos=save'lastb >>   04581467
            dest'bp:=tos;               << tos=save'firstb >>           04581468
            return;                                                     04581469
         end;                                                           04581470
      end;                                                              04581471
      begin                                                             04581472
         if lx then                     << x = len >>                   04581473
         begin      << sorc: byte   dest: word   len: odd  >>           04581474
            save'lastb:=dest'bp(x);     << x = len >>                   04581475
            asmb(mfds);                                                 04581476
            tos:=dest'addr;                                             04581477
            tos:=s0+1;                  << dest'addr(1) >>              04581478
            move *:=*,(x);              << dest:=dest(1),(len) >>       04581479
            dest'bp(x):=tos;            << x=len+1; tos=save'lastb >>   04581480
            return;                                                     04581481
         end;                                                           04581482
         begin      << sorc: byte   dest: word   len: even >>           04581483
            asmb(mfds 1);               << leave dst, addr's on stack >>04581484
            save'lastb:=dest'bp(x:=x-1);<< x:=x-1 = len-1 >>            04581485
            tos:=dest'addr;                                             04581486
            tos:=s0+1;                  << dest'addr(1) >>              04581487
            move *:=*,(x:=x-1);         << dest:=dest(1),(len-2) >>     04581488
            s2:=s2-1;                   << back up dest'wp >>           04581489
            tos:=1;                                                     04581490
            asmb(mfds);                 << get last byte >>             04581491
            tos:=dest'bp(x);            << x = len-2 >>                 04581492
            dest'bp(x):=save'lastb;     << next-to-last >>              04581493
            dest'bp(x:=x+1):=tos;       << last byte >>                 04581494
            return;                                                     04581495
         end;                                                           04581496
      end;                                                              04581497
   end;                                                                 04581498
      if dest'addr then                                                 04581499
      begin         << sorc: word   dest: byte   len: any  >>           04581500
         @dest'bp:=@dest'bp-1;                                          04581501
         save'byte:=dest'bp;                                            04581502
         asmb(mfds);                                                    04581503
         move dest'bp(x):=dest'bp(x:=x-1),(not lx);                     04581504
         dest'bp:=tos;                  << tos=save'byte >>             04581505
         return;                                                        04581506
      end;                                                              04581507
         if lx then                     << x = len >>                   04581508
         begin      << sorc: word   dest: word   len: odd  >>           04581509
            save'lastb:=dest'bp(x);     << x = len >>                   04581510
            asmb(mfds);                                                 04581511
            dest'bp(x):=tos;            << x=len; tos=save'lastb >>     04581512
            return;                                                     04581513
         end;                                                           04581514
         asmb(mfds);<< sorc: word   dest: word   len: even >>           04581515
end;                                                                    04581516
                                                                        04581517
$page                                                                   04581518
                                                                        04581519
procedure mbtds(dest'dst,dest'addr,sorc'addr,len);                      04581520
   value        dest'dst,dest'addr,sorc'addr,len;                       04581521
   integer      dest'dst;                                               04581522
   logical               dest'addr,sorc'addr,len;                       04581523
   option privileged,uncallable;                                        04581524
begin                                                                   04581525
   entry                                                                04581526
      mbtds';                                                           04581527
   integer                                                              04581528
      save'dst = dest'dst,                                              04581529
      ilen     = len;                                                   04581530
   double                                                               04581531
      dest'loc = dest'dst;                                              04581532
   byte pointer                                                         04581533
      dest'bp  = dest'addr,                                             04581534
      sorc'bp  = sorc'addr;                                             04581535
                                                                        04581536
   logical                                                              04581537
      mpe5       = q+1;                                                 04581538
   integer                                                              04581539
      save'firstw= mpe5,                << re-usable loc's >>           04581540
      save'lastw = save'firstw+1,       << "             " >>           04581541
      save'word  = save'lastw;                                          04581542
   byte                                                                 04581543
      save'firstb= save'firstw,                                         04581544
      save'lastb = save'lastw;                                          04581545
   double                                                               04581546
      dest'locw  = save'lastw+1;                                        04581547
   integer pointer                                                      04581548
      dest'wp    = dest'locw+1,                                         04581549
      sorc'wp    = dest'wp+1;                                           04581550
                                                                        04581551
   asmb(dzro,decb);                     << mpe5:=true; filler >>        04581552
   tos:=dest'dst;                                                       04581553
   if <= then go bad'dst;               << invalid dst >>               04581554
   if s0 > dst'maxp then go bad'dst;    << invalid dst >>               04581555
   x:=s0&dst'entlen;                    << x:=dest'dst*dst'entlen >>    04581556
   tos:=dest'addr&lsr(1);               << dest'wp >>                   04581557
   tos:=sorc'addr&lsr(1);               << sorc'wp >>                   04581558
   tos:=dst(x)&dst'seglen;                << dest'dstsz >>              04581559
   if = then go bad'dst;                << unassigned dst >>            04581560
   tos:=abs(cpcb)+2;                    << current pcb entry >>         04581561
   if pcb'entlenp = mpe4'entlen then                                    04581562
   begin                                                                04581563
      tos:=tos-abs(pcbb);               << convert to pcb relative >>   04581564
      mpe5:=false;                                                      04581565
   end;                                                                 04581566
   tos:=pcb(tos);                      << get pcb02 entry >>            04581567
   if < then                            << absolute db >>               04581568
   begin                                                                04581569
bad'dst:                                                                04581570
      qstat.ccf:=ccl;                                                   04581571
      go exit;                                                          04581572
   end;                                                                 04581573
   lx:=len+1;                           << must use logical arith. >>   04581574
   if = then go out'of'bounds;          << greater than abs. max >>     04581575
   tos:=(dest'addr+lx)&lsr(1);          << x = len+1 >>                 04581576
   if carry then go out'of'bounds;      << dest dst overflow >>         04581577
   asmb(cab,cmp);                       << tos > dest'dstsz? >>         04581578
   if > then go out'of'bounds;          << dest dst overflow >>         04581579
   if mpe5 then tos:=tos.(2:14) else tos:=tos.(1:10);                   04581580
   if <> then                                                           04581581
   begin                                << XDS <> 0 => Split stack >>   04581582
      tos:=tos&dst'entlen;              << sorc'dst# * dst'entlen >>    04581583
      tos:=(sorc'addr+lx)&lsr(1);       << x = len+1 >>                 04581584
      if carry then go out'of'bounds;   << sorc dst overflow >>         04581585
      asmb(stbx,delb);                  << x := dst# * dst'entlen >>    04581586
      if tos > dst(x) then go out'of'bounds;                            04581587
   end else                                                             04581588
   begin                                << at stack >>                  04581589
      asmb(del,dup);                    << del dst#; copy sorc'wp >>    04581590
      tos:=sorc'addr+lx;                << x = len+1 >>                 04581591
      if carry then go out'of'bounds;   << sorc dst overflow >>         04581592
      if tos&asr(1) > @dest'dst then go out'of'bounds;                  04581593
      push(s);                                                          04581594
      if tos > tos then tos.(0:1):=1;   << db-minus >>                  04581595
      push(dl);                                                         04581596
      if tos-ps0(-1) > s1 then          << sorc dst underflow >>        04581597
      begin                                                             04581598
out'of'bounds:                                                          04581599
         qstat.ccf:=ccg;                                                04581600
         go exit;                                                       04581601
      end;                                                              04581602
   end;                                                                 04581603
   go do'mbtds;                                                         04581604
mbtds':                                                                 04581605
   tos:=0d;                             << save'firstw, save'lastw >>   04581606
   tos:=dest'loc;                       << dst, addr >>                 04581607
   tos:=tos&lsr(1);                     << dest'wp >>                   04581608
   tos:=sorc'addr&lsr(1);               << sorc'wp >>                   04581609
   push(s,z,dl,db,sbank);                                               04581610
   asmb(delb,cmp);                      << del db; only need dbbank >>  04581611
   if = then                            << sbank = dbbank? >>           04581612
   begin                                                                04581613
      asmb(zrox,xch);                   << xch z,dl >>                  04581614
      if tos <= x <= tos then           << at stack >>                  04581615
      begin                                                             04581616
         if tos < s1 then tos.(0:1):=1; << db-minus >>                  04581617
      end else del;                     << clean up stack >>            04581618
   end else asmb(ddel,del);             << "            " >>            04581619
do'mbtds:                                                               04581620
   qstat'cce;                           << qstat.ccf:=cce >>            04581621
   x:=ilen;                                                             04581622
   tos:=(x+1)&lsr(1);                   << word count >>                04581623
   if = then go exit;                   << no move >>                   04581624
   if sorc'addr then                                                    04581625
   begin                                                                04581626
      if dest'addr then                                                 04581627
      begin                                                             04581628
         @sorc'bp:=@sorc'bp-1;                                          04581629
         save'firstw:=sorc'wp;                                          04581630
         if lx then                     << x = len >>                   04581631
         begin      << sorc: byte   dest: byte   len: odd  >>           04581632
            asmb(stbx,ldxa);            << tos:=@sorc'wp >>             04581633
            tos:=dest'locw;             << dest'dst, @dest'wp >>        04581634
            tos:=1;                                                     04581635
            asmb(mfds);                 << get 1st  dest word >>        04581636
            sorc'bp(1):=save'firstw;                                    04581637
            asmb(mtds);                                                 04581638
            sorc'bp:=save'firstb;       << restore 1st  sorc >>         04581639
exit:                                                                   04581640
            return;                                                     04581641
         end;                                                           04581642
         begin      << sorc: byte   dest: byte   len: even >>           04581643
            save'lastw:=sorc'wp(s0);    << s0 = (len+1)/2 >>            04581644
            tos:=@sorc'wp;                                              04581645
            tos:=dest'locw;             << dest'dst, @dest'wp >>        04581646
            tos:=1;                                                     04581647
            asmb(mfds);                 << get 1st  dest word >>        04581648
            tos:=@sorc'wp(x);           << x = wlen >>                  04581649
            tos:=dest'dst;                                              04581650
            tos:=@dest'wp(x);           << "      " >>                  04581651
            tos:=1;                                                     04581652
            asmb(mfds);                 << get last dest word >>        04581653
            sorc'bp(1):=save'firstw;                                    04581654
            sorc'bp(len):=save'lastb;                                   04581655
            x:=x+1;                     << len+1 >>                     04581656
            tos:=tos+1;                 << move extra word >>           04581657
            asmb(mtds);                                                 04581658
            sorc'bp:=save'firstb;       << restore 1st  sorc >>         04581659
            sorc'bp(x):=tos;            << x:=len+1; tos=save'lastw >>  04581660
            return;                                                     04581661
         end;                                                           04581662
      end;                                                              04581663
      begin         << sorc: byte   dest: word   len: any  >>           04581664
         if lx then tos:=tos-1;        << move'len-1 (x = len) >>       04581665
         save'word:=sorc'wp;                                            04581666
         asmb(incb,decx);              << @sorc'wp+1; x:=len-1 >>       04581667
         asmb(mtds);                                                    04581668
         save'dst:=exchangedb(dest'dst);                                04581669
         move dest'bp(x):=dest'bp(x:=x-1),(not lx);                     04581670
         dest'bp:=tos;                 << tos=save'word >>              04581671
         tos:=exchangedb(save'dst);                                     04581672
         return;                                                        04581673
      end;                                                              04581674
   end;                                                                 04581675
      if dest'addr then                                                 04581676
      begin                                                             04581677
         @dest'wp:=@dest'wp+1;                                          04581678
         tos:=tos-1;                    << move'len-1 >>                04581679
         if lx then                     << x = len >>                   04581680
         begin      << sorc: word   dest: byte   len: odd  >>           04581681
            save'lastw:=sorc'wp(s0);    << s0 = (len+1)/2 >>            04581682
            asmb(mtds);                                                 04581683
            save'dst:=exchangedb(dest'dst);                             04581684
            tos:=dest'addr;                                             04581685
            tos:=s0+1;                  << dest'addr(1) >>              04581686
            x:=ilen;                                                    04581687
            move *:=*,(x:=x-1);         << dest:=dest(1),(len-1) >>     04581688
            dest'bp(x):=save'lastb;     << x = len-1 >>                 04581689
         end else                                                       04581690
         begin      << sorc: word   dest: byte   len: even >>           04581691
            save'firstw:=sorc'wp;                                       04581692
            asmb(incb,decx);            << @sorc'wp+1; x:=len-1 >>      04581693
            asmb(mtds);                                                 04581694
            save'dst:=exchangedb(dest'dst);                             04581695
            move dest'bp(x):=dest'bp(x:=x-1),(-x);                      04581696
            dest'bp:=save'firstb;                                       04581697
            del;                        << save'lastw >>                04581698
            dest'bp(1):=tos;            << tos=save'firstw >>           04581699
         end;                                                           04581700
         tos:=exchangedb(save'dst);                                     04581701
         return;                                                        04581702
      end;                                                              04581703
         if lx then                     << x = len >>                   04581704
         begin      << sorc: word   dest: word   len: odd  >>           04581705
            save'lastw:=sorc'wp(s0-1);  << s0 = (len+1)/2 >>            04581706
            tos:=@sorc'wp(x);           << x = wlen >>                  04581707
            tos:=dest'dst;                                              04581708
            tos:=@dest'wp(x);           << "      " >>                  04581709
            tos:=1;                                                     04581710
            asmb(mfds);                 << get last dest word >>        04581711
            x:=ilen;                                                    04581712
            sorc'bp(x:=x-1):=save'lastb;<< insert last sorc >>          04581713
            asmb(mtds);                                                 04581714
            sorc'bp(x:=x+1):=tos;       << tos=save'lastw >>            04581715
            return;                                                     04581716
         end;                                                           04581717
         asmb(mtds);<< sorc: word   dest: word   len: even >>           04581718
end;    << mbtds >>                                                     04581719
