From:	MX%"antek@mimuw.edu.pl"  1-MAR-1993 16:29:48.71
To:	SALWICKI
CC:	
Subj:	

Date: Mon, 1 Mar 93 15:01:30 GMT
From: antek@mimuw.edu.pl
To: salwicki@pauvx1.univ-pau.fr

                                                  CAEN, October, 1987

           A SHORT INTRODUCTION TO THE NEW RUNNING SYSTEM
	              WRITTEN IN LOGLAN-82

	  	              by

	                Antoni  Kreczmar

1. Preface

This short introduction  describes the main  differences between the Loglan-82
and Loglan-84  Running Systems (RS) as well as  the user guide for RS program.
This program was entierly written  in Loglan-82, so it gives a good high level
point of view on the chosen algorithms. In future a library of modules written
in programming language C will replace that program. It seems that this way we
shall obtain a strict, abstract  definition of Loglan RS, as well as a perfect
mean to produce a professional portable system.

The present text may be read  only by fellows who know the theory of Loglan RS
virtual addressing and  Loglan RS  Display structure. For the first problem we
refer the reader to the paper  by G.Cioni, A.Kreczmar "Programmed deallocation
without dangling reference" IPL 18(1984) pp.179-187, for the latter one we re-
fer the reader to the paper  by M.Krause, A.Kreczmar, H.Langmaack, A.Salwicki,
M.Warpechowski "Algebraic approach to ...." published in Lecture Notes in Com-
puter Science Springer  serie number 208,  pp. 134-156.  In what follows we do
not explain the  details of these solutions, in  the contrary, all the details
are just put in  our program (we  hope the program is self explanatory for our
fellows who understand the published solutions).

2. Structure of  RS.LOG

Program RS is written  as the sequence  of classes. The most outer one is the
class defining Loglan prototypes (class  PROTOTYPES). Going down  we have the
following classes:     MEMORY (defining the structure  of memory management),
OBJECTS  (defining the  basic operations  on Loglan objects), COROUTINES (de-
fining the operations on coroutines),   HANDLING (defining operations on exc-
eptions), and finally we have a prefixed  block which allows to interpret the
tentative intermediate code designed only for testing aims.

Class PROTOTYPE  defines all prototypes, like in Loglan-82 RS, but it profits
from the possibility of building up hierarchies. So, the outermost  prototype
Prtp has only the common attributes, then we can inherit this class to define
prototypes of simple classes  and arrays, etc.  The full picture of this hie-
rarchy is given at the beginning of class PROTOTYPES. What is interesting and
new  with respect  to  Loglan-82 RS  is  that we define  system attributes as
virtual operations (Sl, Dl, Lsc etc.), so their offsets may be changed later.
Pay attention also  on  attributes  "perm"  and "perminv" which are necessary
to update Display correctly. In the program RS we gave the full algorithm for
computing these permutations  (procedure  Cmptperm)  which is not executed in
our  program. It  is  written  as a comment,  however it was  tested on large
examples. In future  this procedure  must be executed during  a  program com-
pilation. Everything what is  needed to  perform this  procedure is a program
structure with decl and pref  functions.

The last but not least thing which we must stress in  this short introduction
is the structure of offsets  for reference values. In fact, Loglan-84 differs
from Loglan-82 also because of  more complicated  world of  structured types.
In fact, we can define  in  this new version of language a record or array of
elements which contain references. This implies that the structure of offsets
of references ressembles regular expressions. We can have  a list of offsets,
a segment of  offsets, a list of such expressions and finally a repetition of
such an expression. A list of offsets (Listref) is the following stucture:

     head ---> (i1,next1) ---> ...   ---> (in,none)

where i1,...,in are offsets of references inside an object.

A segment of  offsets  (Segment) is only a pair (start,finish), and all ele-
ments between offsets  start and finish are references. A list of structures
defining offsets (List) is the following:

     head ---> (Offset1,next1) ---> ...   ---> (Offsetn,none)

where Offset is the type of  offsets structure. Finally a repetition n times
such a structure is defined by class Repeated. It is a pair (ntimes,Offsets)
where ntimes defines the  number of repetitions  and Offsets defines the re-
peted structure. Recalling Loglan-84 types we  see that Listref is  a normal
list of offsets in an object, like in Loglan-82, Segment appears when a sta-
tic array  of references is declared, List appears when a record with selec-
tors having references is declared, and finally Repeated appears when a sta-
tic array with element having references is declared.

The  structure of Offsets is read by procedure Takeoffsets, the structure of
Prototypes  is read by procedure Takeprototype. For the syntax of input look
inside these procedures.

3. Object structure

The new Running System has a new object structure. In fact, it is not diffi-
cult to observe that an object may be uniquely defined if we have  an access
to its prototype. Moreover during the work on Loglan-82 we realized that the
structure of object growing only in one direction is cumbersome for many re-
asons (formal parameters had to be numbered, auxiliary variables changed the
already computed offsets etc.). Thus it would be nicer if object could  grow
both directions. Such a solution was accepted as an axiom, so objects in new
RS are identified by one value placed not necessarily at one of its ends.

Prototypes  of objects are defined by classes (Prtp). Such  a class  has two
attributes defining object size : lspan , rspan.  For  adjustable arrays  an
object size is settled on run time. Thus the first value  of such  an object
defines array prototype while the next two (lower bound & upper bound) fixed
on  run time define  the object size. Because of adjustable  arrays  virtual
function Size, giving an object length, has formal parameter am. This  para-
meter is not used in the case of normal modules, it is used only in the case
of adjustable  arrays.  Then it  points an object address from  which we can
calculate object size using lower and upper bound.

4. Compactifier

New compactifier is based in the structure of the old one. However we  added
one important feature, namely automatic garbage collection. This garbage co-
llection is based on the known technique which traverses the whole graph  of
objects accessible from the active one and marks them. The traversing proce-
dure starts from marking a visited object. Then using the  information about
the relocation of  references inside the object it goes recursively to visit
other objects.

Garbage  collection (act1)  is  the  first phase  of compactifying procedure.
Then we do the same as in the old compactification process. In act2 we  walk
through the list of  free items on  address table. Act3  again analyzes this
table however by scanning it entierly and marking non-used addresses. In the
act4 the lists of killed objects are traversed and killed objects are marked.
In act5  the whole memory is scanned  and  references to nonexisting objects
are set to none (this phase is necessary; originally it was not executed but
P.Gburzynski found that error). In act6  the table of  indirect addresses is
scanned. It  computes the  future values  of indirect addresses and prepares
the these addresses to the next phase. It is the most important phase, act7.
It scans the whole memory updating all references. Finally the table of ind-
irect addresses  is squeezed (act8).

5. Coroutines

The  system of coroutines differs a little bit from the old one. Dl link  is
fixed at the  moment of coroutine generation as  for all the other  modules.
Every coroutine has additional reference Cl. When return is encountered that
reference points coroutine object itself. Each attach, detach  updates  this
reference on the  last object  belonging to the  coroutine chain  (coroutine
chain is defined as in the old Running System). Termination  of a  coroutine
returns the control via Dl which does not change during a program execution.
In  order to  mark coroutine termination,  Cl is set to none.   This way any
attempt to  activate a terminated  coroutine will  be recognized  by Running
System. To obtain, as previously, the  possibility of  nonsymetric coroutine
sequencing each process contains a system reference pointing the last  atta-
ched coroutine. Thus  detach  makes the control  transfer  from an active to
this  pointed coroutine.

6. Handlers

System of handlers is also a little bit changed. According to  Szczepanska's
observation it is methodologically improper to perform  recursive  call of a
handler. Thus procedure Raise searches a handler going via Dl, but ommitting
handler objects and its Sl fathers. So when a handler is declared in a modu-
le neither a handler object nor its dynamic father are taken into considera-
tion in searching process.

7. Examples

There are  some examples of programs written in an intermediate code to test
new RS. The full description of an intermediate code is given at the end  of
RS program (in the last prefixed block). Each example is prepared so that it
is possible to understand its sense. We give first the full text  of program
written in Loglan (with some comments concerning the  offsets values),  then
the system of offsets, the system of prototypes and finally a code is given.
The syntax of these input data is precisely  described in the  corresponding
modules. In order to have the possibility of testing our product, some  uti-
lities were provided. Each code statement possesses as a final data an  inf-
ormation concerning the output. We can output for each code  statement  just
such a code or a memory dump. If this final value is 1 we print a  statement
(trace).  If this final  value is 2 we  dump memory. If  this final value is
greater than 2 we print trace as well as memory dump.

The list of examples contain program Pawel (recursive generation of permuta-
tions), program Merge (coroutine merging of many BST), program Knapsack (the
use of handlers to obtain the  solution of simple knapsack problem), and fi-
nally  program Mergecor which implements  the merging process of two Bst but
using handlers instead of maximal integer to end a tree.

There is a macro called tr.bat which transforms  commented examples  into  a
form which can be read by RS.LOG. To do it you simply call tr with a parame-
ter denoting an example, for instance:

       tr pawel.log

Then you obtain a file code.txt which is ready to be read by RS. In examples
we  must put sign  #  at the end of Loglan version, and we must avoid to use
later all the signs appearing in numbers ( so digits and -). The given exam-
ples keep to this syntax.

When RS program starts to be executed, it asks you whether you want to print
prototypes, offsets or memory, just at the beginning of a program execution.
You can answer 0 or 1 , corresponding to the needed output. After that phase
your example will be executed. Good luck.

                                 Antek Kreczmar
       program RS;


(*****************************************************************************)
(*                                                                           *)
(*                                                                           *)
(*          THIS IS LOGLAN-84 RUNNING SYSTEM WRITTEN IN LOGLAN-82            *)
(*	                                                                     *)
(*                          by Antoni Kreczmar                               *)
(*	                                                                     *)
(*               Institute of Informatics, Warsaw University	             *)
(*                                                                           *)
(*                              June, 1987                                   *)
(*                                                                           *)
(*			                                                     *)
(*			                                                     *)
(*****************************************************************************)












(*****************************************************************************)
(*                                                                           *)
(*                          GLOBAL CONSTANTS                                 *)
(*                                                                           *)
(*****************************************************************************)

    const    maxint  = 32000,              (* defines maximal integer       *)
             reflength=2,                  (* reference value length        *)
             memorylength = 200,           (* defines the length of M       *)
             syssigl=100;                  (* defines system signals bound  *)










(*****************************************************************************)
(*                                                                           *)
(*                          GLOBAL VARIABLES                                 *)
(*                                                                           *)
(*****************************************************************************)

    var M :    arrayof integer,    (* M[0..memorylength-1] is RS memory  *)
        f:             file;       (* file with datas                    *)










(*****************************************************************************)
(*                                                                           *)
(*                         SIGNALS FOR RS ERRORS                             *)
(*                                                                           *)
(*****************************************************************************)

  signal Error(t:string);












(*****************************************************************************)
(*                                                                           *)
(*                                                                           *)
(*                                                                           *)
(*                           PROTOTYPES                                      *)
(*                                                                           *)
(*               Prototype defines the skeleton of an object                 *)
(*                                                                           *)
(*             In this part the structure of prototypes is read.             *)
(*           Levels and Langmaack's permutations may be computed             *)
(*           (  however this will be done at compilation phase  )            *)
(*****************************************************************************)




(*****************************************************************************)
(*                                                                           *)
(*                           HIERARCHY OF PROTOTYPES                         *)
(*                                                                           *)
(*                                 Prtp    any prototype                     *)
(*                                  |                                        *)
(*                       ------------------------                            *)
(*                       |                      |                            *)
(*                       |                      |                            *)
(*   Simple class    Prtpsimpl               Prtparr     adjustable array    *)
(*   without Dl,Sl       |                      |                            *)
(*                       |                      |                            *)
(*                   Prtpmod                    |                            *)
(*                       |                      |                            *)
(*                 -------------                |                            *)
(*                 |           |                |                            *)
(*  Block       Prtpsub        |          ---------------                    *)
(*  subroutine     | Handler Prtphand     |             |                    *)
(*                 |                  Prtparnst         |                    *)
(*  Class       Prtplass                  |             |                    *)
(*                 |                      |             |                    *)
(*                 |                      |        Prtparstr    structured   *)
(*                 |                --------------               elements    *)
(*  Coroutine   Prtpcor             |            |                           *)
(*                 |                |            |                           *)
(*                 |                |        Prtparrf     reference          *)
(*                 |                |                      elements          *)
(*  Process     Prtpproc         Prtparpr  primitive                         *)
(*                                         elements                          *)
(*****************************************************************************)



 unit PROTOTYPES: class;


      (*****************************************************************)
      (*                                                               *)
      (*            Every object is patterned upon its prototype       *)
      (*                                                               *)
      (*                                                               *)
      (*               object  = M[am-lspan..am+rspan] where           *)
      (*    -----------------                                          *)
      (*    | M[am-lspan]   |        =                                 *)
      (*    |               |        =                                 *)
      (*    |   .           |        =    }   attributes               *)
      (*    |   .           |        =                                 *)
      (*    |   .           |        =                                 *)
      (*    | M[am-1]       |        =                                 *)
      (*    | M[am]         |        =  <-- pt - Prototype number      *)
      (*    | M[am+1]       |        =                                 *)
      (*    |   .           |        =                                 *)
      (*    |   .           |        =    }   attributes               *)
      (*    |   .           |        =                                 *)
      (*    | M[am+rspan]   |        =                                 *)
      (*    -----------------                                          *)
      (*****************************************************************)

      unit  Prtp: class;

        var  num:     integer;  (* prototype number - only for identifiction *)

        (*-------------------------------------------------------------------*)

        unit virtual Size: function(am:integer) : integer;

          (* size of the object of this prototype allocated in M[...am...]  *)
          (* formal parameter am  appears only because of adjustable arrays *)

        end Size;

        (*-------------------------------------------------------------------*)


        unit virtual Ptposition: function: integer;

          (* position of pt in an object with respect to its beginning *)

        end Ptposition;

        (*------------------------------------------------------------------*)

     end Prtp;

     (*---------------------------------------------------------------------*)

      unit Prtpsimpl : Prtp class;

         (* prototype of a simple class, i.e. without Lsc, Dl and Sl  *)

        var lspan,rspan: integer,
            references:  Offsets;  (* structure of references in object *)
                                   (* cf. declaration of Offsets        *)

        (*------------------------------------------------------------------*)

        unit virtual Size: function(am:integer) : integer;

        begin
          result:=lspan+rspan+1;
        end Size;

        (*-------------------------------------------------------------------*)

        unit virtual Ptposition: function: integer;

        begin
          result:=lspan;
        end Ptposition;


      end Prtpsimpl;

      (*-------------------------------------------------------------------*)

          (* Prtpmod  is a prototype of any module. It has static attributes *)
          (* like decl,pref and its objects have Dl, Sl, Statsl and Lsc      *)
          (* Blocks and subroutines belong exactley to this class, while     *)
	  (* classes (coroutines,processes) are elements of Prtpmod subclass *)


      (*****************************************************************)
      (*                                                               *)
      (*    -----------------                                          *)
      (*    | M[am-lspan]   |        =                                 *)
      (*    |               |        =                                 *)
      (*    |   .           |        =    }   attributes               *)
      (*    |   .           |        =                                 *)
      (*    |   .           |        =                                 *)
      (*    | M[am-1]       |        =                                 *)
      (*    | M[am]         |        =  <-- pt - Prototype number      *)
      (*    |   .           |        =                                 *)
      (*    | M[am+1]       |        =    }   attributes               *)
      (*    |   .           |        =                                 *)
      (*    |   .           |        =   Lsc  local sequence control   *)
      (*    |   .           |        =   Statsl number of synt. sons   *)
      (*    |   .           |        =   Dl  dynamic link              *)
      (*    | M[am+rspan]   |        =   Sl  static link               *)
      (*    -----------------                                          *)
      (*****************************************************************)


          (* Offsets of system attributes are defined by virtual functions  *)
          (* they may be changed later on;   here system attributes are     *)
	  (*           allocated at the right end of an object              *)


       const Sloffset=1-reflength,               (* roffset of Sl     *)
             Dloffset=Sloffset-reflength,        (* roffset of Dl     *)
	     Statoffset=Dloffset-1,              (* roffset of Statsl *)
	     Lscoffset=Statoffset-1;             (* roffset of Lsc    *)

      unit  Prtpmod : Prtpsimpl class;



       var declto, prefto:  Prtpmod,           (* decl and pref links        *)
           level:           integer,           (* level of node in decl tree *)
           codeadd:         integer,           (* address of first statement *)
           lstwill:         integer,           (* address of lastwill        *)
           perm:            arrayof integer,   (* Langmaack's permutation    *)
           perminv:         arrayof integer;   (* inverse of perm            *)

         unit virtual Sl : function(am : integer):integer;
	 begin
           result:=am+rspan+Sloffset
         end Sl;

         unit virtual Dl : function(am : integer) : integer;
         begin
           result:=am+rspan+Dloffset
         end Dl;

         unit virtual Statsl : function(am : integer) : integer;
         begin
           result:=am+rspan+Statoffset
         end Statsl;

         unit virtual Lsc: function(am : integer) : integer;
         begin
           result:=am+rspan+Lscoffset
         end Lsc;

      end Prtpmod;

     (*--------------------------------------------------------------------*)

     unit Prtpsub : Prtpmod class;

       (* Prtpsub is a prototype of  block, procedure or function *)

      var  pslength:        integer,           (* prefix sequence length     *)
	   handlist:        hlstelem;          (* list of handlers,see down  *)

     end Prtpsub;

     (*--------------------------------------------------------------------*)
      unit Prtpclass : Prtpsub class;

	 (* Prtpclass is a prototype  of class *)

      end Prtpclass;

     (*--------------------------------------------------------------------*)

     unit Prtpcor : Prtpclass class;

       (* Prtpcor is a prototype of coroutine *)

     end Prtpcor;

     (*--------------------------------------------------------------------*)

     unit Prtphand: Prtpmod class;

         (* Prtphand is a prototype of handler *)
        var oth:    boolean;                   (* for others oth=true *)

     end Prtphand;

     (*--------------------------------------------------------------------*)


     unit Prtpproc: Prtpcor class;

        var displ: integer,              (* offset of DISPLAY[1] in object *)
            curr:  integer,              (* offset of current in object    *)
            lstcr: integer,              (* offset of lastcor in object    *)
            chead: integer;              (* offset of corhead in object    *)

         (* DISPLAY, current,lastcor and corhead    must be in Offsets   *)
         (*     lastcor  and corhead are used in class COROUTINES        *)
     end Prtpproc;

     (*--------------------------------------------------------------------*)

        (*********************************************************)
        (*          adjustable array object has the form         *)
        (*  M[am]=pt                                             *)
        (*  M[am+1]= lower bound                                 *)
        (*  M[am+2]= upper bound                                 *)
        (*  M[am+3]       =                                      *)
        (*  M[am+4]       =  }  elements                         *)
        (*    ...         =                                      *)
        (*  M[am+i]       =                                      *)
	(*********************************************************)

      const   lboffset= 1,             (* offset of lower bound   *)
              uboffset= 2,             (* offset of upper bound   *)
              elmoffset=3;             (* offset of first element *)

     (*--------------------------------------------------------------------*)
     unit Prtparr: Prtp class;


        unit virtual Size: function(am:integer) : integer;
          (* dummy *)
        end Size;

       (*-------------------------------------------------------------------*)

        unit virtual Ptposition: function: integer;

        begin
          result:=0;
        end Ptposition;

     end Prtparr;
     (*---------------------------------------------------------------------*)

     unit Prtparnst: Prtparr class;
        (* adjustable array of non-structured elements *)

        var elsize:integer;                   (* element size *)

        unit virtual Size: function(am:integer): integer;
        begin
          result:=(M(am+uboffset)-M(am+lboffset)+1)*elsize+3;
        end Size;
     end Prtparnst;

     (*---------------------------------------------------------------------*)

     unit Prtparpr: Prtparnst class;
        (* adjustable array of primitive elements, elsize is read *)
     end Prtparpr;

     (*---------------------------------------------------------------------*)

      unit Prtparrf:Prtparnst class;
        (* adjustable array of references  *)

      begin
        elsize:=reflength;                     (* define element size *)
      end Prtparrf;

     (*---------------------------------------------------------------------*)

      unit Prtparstr:Prtparr class;
        (* array of structured elements *)
        var references:Offsets;

        unit virtual Size: function(am:integer): integer;
        begin
          result:=(M(am+uboffset)-M(am+lboffset)+1)*references.size+3;
        end Size;


      end Prtparstr;


     (*---------------------------------------------------------------------*)
      var  maxlevel:    integer;            (* length of Display    *)


      (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
      (*                                                                     *)
      (*                    END OF SPECIFICATION PART                        *)
      (*                                                                     *)
      (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)






      (*------------------------------------------------------------------*)
      (*                                                                  *)
      (*                      STRUCTURES FOR                              *)
      (*                                                                  *)
      (*                         HANDLERS                                 *)
      (*                                                                  *)
      (*------------------------------------------------------------------*)


       (*------------------------------------------------------------------*)
       (*                                                                  *)
       (* Each module can have the list of handlers. This list is the list *)
       (* of lists i.e. for each handler we have the list of joint signal  *)
       (*     numbers. So, the main list has as elements the triples:      *)
       (*        (handler prototype,signal list,next list element)         *)
       (*     The corresponding signal list has as elements the pairs:     *)
       (*             (signal number,next list element)                    *)
       (*  If else part appears, then all visible signals in a module are  *)
       (*    on the list joint with such a handler and its oth=true.       *)
       (*  System signals have signal number <= syssigl. For these signals *)
       (*  return in a handler is not allowed. They not appear on the list *)
       (*                of signals for handler for others.                *)
       (*                                                                  *)
       (*------------------------------------------------------------------*)


       (*------------------------------------------------------------------*)
       (*                                                                  *)
       (*                  System signals numbers                          *)
       (*                                                                  *)
       (*------------------------------------------------------------------*)


          const
	      reftonone = 1,         (* reference to none    *)
	      memover   = 2,         (* memory overflow      *)
	      incorqua  = 3,         (* incorrect qua        *)
              incorassg = 4,         (* incorrect assignment *)
	      ilattach  = 5,         (* illegal attach       *)
	      corterm   = 6,         (* coroutine terminated *)
	      handnfond = 7,         (* handler not found    *)
	      imprterm  = 8,         (* improper terminate   *)
              incorkill = 9,         (* incorrect kill       *)
              arrayind  = 10;        (* array index error    *)



	  unit hlstelem: class;
           var hand:     integer,          (* prototype number of handler *)
	       signlist: sglelem,          (* signal list                 *)
	       next:     hlstelem;         (* next list element           *)
	  end hlstelem;

	  unit sglelem:  class;
	   var signalnum: integer,         (* signal number               *)
	       next:      sglelem;         (* next list element           *)
	  end sglelem;









      (*------------------------------------------------------------------*)
      (*                                                                  *)
      (*                      STRUCTURES FOR                              *)
      (*                                                                  *)
      (*                   OFFSETS OF REFERENCES                          *)
      (*                                                                  *)
      (*------------------------------------------------------------------*)


      (*------------------------------------------------------------------*)


             (* auxiliary classes for defining lists of offsets *)

           unit Elem:class(offset:integer,next:Elem);
           end Elem;

           unit Elemex:Elem class;
             var references :Offsets;
           end Elemex;

       (*----------------------------------------------------------------*)

           unit Offsets: class;
             (* any substructure defining references *)

             var size:   integer,  (* defines the size of considered *)
                                   (*         memory subframe        *)
                 num:    integer;  (* offsets number - only to write *)
          end Offsets;

      (*----------------------------------------------------------------*)



           unit Listref: Offsets class;
             (* each list element is an offset of a reference *)

            var head:              Elem,
                length:            integer;
          end Listref;

      (*-----------------------------------------------------------------*)

           unit Segment: Offsets class;
            (* contiguous segment of memory *)

            var start,finish: integer;
           end Segment;

      (*---------------------------------------------------------------*)

           unit Repeated : Offsets class;
            (* repetition n times *)

            var ntimes:       integer,
                references:   Offsets;
           end Repeated;

      (*-----------------------------------------------------------------*)

           unit List: Offsets class;
             (* each list element is an offset of substructure *)

            var head:              Elemex,
                length:            integer;

          end List;

      (*--------------------------------------------------------------------*)

         var STRUC :arrayof Offsets;    (*  array for offsets structures *)


      (*---------------------------------------------------------------------*)

      signal SS;


      (*---------------------------------------------------------------------*)

      var    PROT:       arrayof Prtp,
             n:          integer;



      (*         PROT[1..n] is defined by the compiler           *)
      (* RS reads it from file  CODE.TXT  by Takeprot procedure  *)


      (*---------------------------------------------------------------------*)

      unit Takeoffsets : procedure;

        (* reads offsets to STRUC from CODE.TXT file  *)

         (*              Input format:               *)
         (* n   - number of offsets                  *)
         (*   {  offsetnumber    size                *)
         (*   kind (1,2,3,4)                         *)
         (*      =(Listref,Segment,Repeated,List)    *)
         (*    if kind=1 then                        *)
         (*       n,offset1,offset2,...,offsetn      *)
         (*    if kind=2 then                        *)
         (*       start finish                       *)
         (*    if kind=3 then                        *)
         (*       ntimes   offsetnumber              *)
         (*    if kind=4 then                        *)
         (*       n,offset1,offset2,...,offsetn      *)
         (*           offsets of substructures }+    *)
         (*                                          *)
         (*                ATTENTION!!!              *)
         (*      must be called before Takeprot      *)


       var  n,m,i,j,k,t,p:   integer,
            L:               List,
            Lr:              Listref,
            S:               Segment,
            R:               Repeated,
            ref:             Offsets;

       begin
        open(f,text,unpack("CODE.TXT"));
      	call RESET(f);
        read(f,n);
        if n<1 then raise SS fi;
        array STRUC dim (1:n);
        for i:=1 to n
        do
          read(f,t);                                   (* offsets number *)
          if i=/=t
          then
            raise Error("Incorrect prototype");
          fi;
          read(f,k);                                   (* read size      *)
          read(f,j);                                   (* read kind      *)
          case j
            when 1:                                    (* Listref        *)
              Lr:=new Listref;
              read(f,m);                               (* m =  length    *)
              for t:=1 to m
              do
                read(f,p);                             (* p=offset       *)
                Lr.head:=new Elem(p,Lr.head);
              od;
              Lr.length:=m;
              ref:=Lr;
            when 2:                                    (* Segment        *)
              S:=new Segment;
              read(f,m);   read(f,p);
              S.start:=m;  S.finish:=p;
              ref:=S;
            when 3:                                    (* Repeated       *)
              R:=new Repeated;
              read(f,m);   read(f,p);
              R.ntimes:=m; R.references:=STRUC(p);
              ref:=R
            when 4:                                    (* List           *)
              L:=new List;
              read(f,m);                               (* m =  length    *)
              for t:=1 to m
              do
                read(f,p);                             (* p=offset       *)
                L.head:=new Elemex(p,L.head);
                read(f,p);
                L.head.references:=STRUC(p);
              od;
              L.length:=m;
              ref:=L;
            otherwise
              raise Error(" Incorrect prototype kind");
          esac;
          ref.num:=i;          ref.size:=k;
          STRUC(i):=ref;
          readln(f);
        od;
      end Takeoffsets;

      (*---------------------------------------------------------------------*)


      unit Takeprot : procedure;

         (* reads PROT structure from CODE.TXT file *)

         (*              Input format:                         *)
         (* n   - number of prototypes                         *)
         (*   {  prototypenumber                               *)
         (*   kind  =  (1,2,3,4,5,6,7,8,9)                     *)
         (*    (for kind = 1 simple class like record)         *)
         (*        lspan rspan offestsnum                      *)
         (*    (for kind = 2,9 class,block,subprogram)         *)
	 (*       (2 is for block, subprogram, 9 for class)    *)
         (*        lspan rspan offsetsnum decl pref  codeadd   *)
         (*        level pslength                              *)
         (*        perm[1..level]  perminv[1..level]           *)
         (*        lstwill                                     *)
         (*        { handlerprot, { signalnumber}+,0 }+,0      *)
         (*    (for kind = 3 process-main block additionally)  *)
         (*        displ curr lstcr chead                      *)
         (*    (for kind = 4 adjustable primitive array )      *)
         (*        elsize                                      *)
         (*    (for kind = 5 adjustable structured array)      *)
         (*        offsetsnum                                  *)
         (*    (for kind = 6 adjustable reference array)       *)
         (*           (no data)                                *)
         (*    (for kind = 7 coroutine, no additional datas)   *)
	 (*    (for kind = 8 handler like in kind 2 but        *)
	 (*         instead of pslength oth =0,1 is given      *)
         (*            }+                                      *)
         (*       maxlevel                                     *)

        var i,j,k,l:    integer,
            a:          Prtp,
            b:          Prtpmod,
            t:          Prtpsimpl,
            c:          Prtpsub,
            d:          Prtparpr,
            e:          Prtparstr,
	    h:          Prtphand,
	    r:          Prtpproc,
            p:          hlstelem,
	    q:          sglelem;


      begin
        read(f,n);
        if n<1 then raise SS fi;
        array PROT dim (1:n);
        for i:=1 to n
        do
          read(f,l);
          if i=/=l
          then
            raise Error("Incorrect prototype");
          fi;
          read(f,j);                                   (* read kind      *)
          case j
            when 1:                                    (* simple class   *)
              a:=new Prtpsimpl;        t:=a;
              read(f,l);               t.lspan:=l;     (* read lspan     *)
              read(f,l);               t.rspan:=l;     (* read rspan     *)
              read(f,l);                               (* read offsetnum *)
              if l=/=0 then t.references:=STRUC(l); fi;
            when 2,3,7,8,9:                            (*  module        *)
              case j
	        when 2:
                  a:=new Prtpsub;    b:=a; c:=a;
                when 3:
                  a:=new Prtpproc;   b:=a; c:=a; r:=a;
                when 7:
                  a:=new Prtpcor;    b:=a; c:=a;
		when 8:
                  a:=new Prtphand;   b:=a; h:=a;
		when 9:
		  a:=new Prtpclass;  b:=a; c:=a;
              esac;
              read(f,l);              b.lspan:=l;
              read(f,l);              b.rspan:=l;
              read(f,l);                               (* read offsetnum *)
              if l=/=0 then b.references:=STRUC(l); fi;
              read(f,l);
              if l=/=0 then  b.declto:=PROT(l); fi;    (* set decl       *)
              read(f,l);
              if l=/=0 then  b.prefto:=PROT(l); fi;    (* set prefto     *)
              read(f,l);              b.codeadd:=l;    (* read codeadd.  *)
              read(f,l);              b.level:=l;      (* read level     *)
              if j=/=8
	      then
	        read(f,l);            c.pslength:=l;   (* read pslength  *)
              fi;
              array b.perm dim(1:b.level);
              array b.perminv dim(1:b.level);
              for k:=1 to b.level do read(f,b.perm(k)) od;
              for k:=1 to b.level do read(f,b.perminv(k)) od;
              read(f,l);              b.lstwill:=l;   (* read lstwill   *)
              if j=/=8
	      then
                c.handlist:=none;
                do
                  read(f,l);
                  if l=0 then exit fi;                 (* end of list      *)
	          p:=new hlstelem;                     (* generate element *)
                  p.hand:=l;
                  p.next:=c.handlist; c.handlist:=p;
                  read(f,k);                           (* read signalnum   *)
                  q:=new sglelem;
	          p.signlist:=q; q.signalnum:=k;
                  do
                    read(f,k);
                    if k=0 then exit fi;               (* end of list      *)
                    q:=new sglelem; q.signalnum:=k;
                    q.next:=p.signlist; p.signlist:=q;
                  od;
                od;
                if j=3
                then
                  read(f,l);   r.displ:=l;
                  read(f,l);   r.curr:=l;
                  read(f,l);   r.lstcr:=l;
                  read(f,l);   r.chead:=l;
                fi;
              else
	        read(f,l);
		if l=0 then h.oth:=false else h.oth:=true fi;
              fi;
            when 4:                                    (* prim.adjus.arr.*)
              a:=new Prtparpr;      d:=a;
              read(f,l);
              d.elsize:=l;                             (* read elem.size *)
            when 5:                                    (* str.adjus.arr. *)
              a:=new Prtparstr;     e:=a;
              read(f,l);
              e.references:=STRUC(l);                  (* set offsets    *)
            when 6:                                    (* ref.adj.array  *)
              a:=new Prtparrf;
            otherwise
              raise Error(" Incorrect prototype kind");
          esac;
          a.num:=i;
          PROT(i):=a;
        od;
        read(f,maxlevel);
      end Takeprot;

      (*---------------------------------------------------------------------*)

           (* Cmptperm computes perm and perminv for all PROT[i] *)
           (* see LNCS 208, pp.134*156                           *)
     (*
      unit Cmptperm: procedure;


       var  i,j,k,l,m,s,t:                   integer,
            a,b,c,d:                         Prtpmod,
            perm,perminv,perm1,perminv1:     arrayof integer;


            unit Cmptcmpl:  function (a:Prtpmod) :Prtpmod;


              var b,c,e:   Prtpmod;

            begin

              result:=a.declto;       b:=a.prefto;       c:=b.declto;
              do
                e:=result;
                do
                  if e=c then return fi;
                  if e=none then exit fi;
                  e:=e.prefto;
                od;
                result:=result.declto;
              od

            end Cmptcmpl;

      begin

        array perm dim (1:1);            perm(1):=1;
        array perminv dim(1:1);          perminv(1):=1;
        PROT(1) qua Prtpmod.perm:=perm;
        PROT(1) qua Prtpmod.perminv:=perminv;

        for m:=2 to n
        do
          if not PROT(m) in Prtpmod
          then
            repeat
          fi;
          a:=PROT(m);
          if a.prefto=none
          then
            b:=a.declto;
            perm1:=b.perm;              perminv1:=b.perminv;
            l:=b.level;                 k:=a.level;
            array perm dim(1:k);        array perminv dim(1:k);
            for i:=1 to l
            do
              perm(i):=perm1(i);        perminv(i):=perminv1(i)
            od;
            perm(k):=k;                 perminv(k):=k;
          else
            b:=a.prefto;                perm1:=b.perm;
            l:=b.level;                 k:=a.level;
            array perm dim(1:k);        array perminv dim(1:k);
            perm(k):=perm1(l);          perminv(perm1(l)):=k;
            d:=b.declto;
            c:= Cmptcmpl(a);
            j:=c.level;                 i:=l-1;
            do
              perm(j):=perm1(i);        perminv(perm1(i)):=j;
              if i=1 then exit fi;
              i:=i-1;                   t:=j;
              j:=c.perminv(d.perm(i));
              d:=d.declto;
              for s:=1 to t-j
              do
                c:=c.declto;
              od;
            od;
            j:=l;
            for  i:=1 to k
            do
              if perm(i) = 0
              then
                j:=j+1;                 perm(i):=j;
                perminv(j):=i
              fi
            od;
          fi;
          a.perm:=perm; a.perminv:=perminv;

        od;

      end Cmptperm;

      *)


      (*---------------------------------------------------------------------*)

      unit Protwrite :procedure;




      var i,j,k:     integer,
          a:         Prtp,
          b,c:       Prtpsimpl,
          d:         Prtpmod,
          g:         Prtpclass,
          e:         Prtparpr,
          f:         Prtparstr,
          L:         List,
          Lr:        Listref,
          S:         Segment,
          R:         Repeated,
          working:   Elem,
	  workinge:  Elemex,
          p:         hlstelem,
          q:         sglelem;

      begin
        writeln;
        writeln("  PROTOTYPE STRUCTURE ");
        writeln;
        write("Nr Offsets  Lspan Rspan  Decl  Pref  Code  Level Pslength");
        writeln(" Lstwill Kind");
        for i:=1 to n
        do
          a:=PROT(i);
          write(i:2); write("  ");
          if a in Prtpsimpl
          then
            b:=a;
            if b.references =/=none
            then
              write(b.references.num:3);
            else
              write(0:3);
            fi;
            write("    ",b.lspan:4,"   ",b.rspan:4,"    ");
            if a in Prtpmod
            then
              d:=a;
              b:=d.declto;
              c:=d.prefto;
              if b=/=none then  write(b.num:2) else write("  ") fi;
              write("    ");
              if c=/=none then  write(c.num:2) else write("  ") fi;
              write("   ");
              write(d.codeadd:4,"  ");
              write(d.level:4);write("   ");
              if a in Prtpsub
              then
                 write(d qua Prtpsub.pslength:4);
                 write(d qua Prtpsub.lstwill:4);
		 if a is Prtpsub then  write(" subroutine");
                 else
		   if a is Prtpclass then write(" class")
		   else
                     if a is Prtpcor then write("  coroutine");
                     else write("  process");
                     fi;
		   fi;
                 fi;
              else
                write("      ",d qua Prtphand.lstwill:4);
	        if a qua Prtphand.oth
		then
		  write("others")
		else
		  write("      ")
		fi;
		write("  handler");
              fi;
            else
	      write("                               simple")
            fi;
          else
            if a is Prtparpr
            then
              e:=a;       write(e.elsize:3);
            else
              if a is Prtparstr
              then
                f:=a;       write(f.references.num:3);
              fi;
            fi;
            write("                                                  array");
          fi;
          writeln;
        od;

        writeln; writeln; writeln("  HANDLERS");
        writeln; writeln; writeln("     handler     signals ");
        for i:=1 to n
        do
          a:=PROT(i);
          write(i);
          if a in Prtpclass
          then
            g:=a;  p:=g.handlist;
            do
              if p=none then exit fi;
              write(p.hand);
              q:=p.signlist;
              do
                if q=none then exit fi;
                write(q.signalnum); q:=q.next;
              od;
              p:=p.next
            od;
          fi;
          writeln;
        od;
        writeln;writeln;
        write("  MAXIMAL LEVEL="); writeln(maxlevel);
        writeln;
        writeln("          OFFSETS");
        for i:=1 to upper(STRUC)
        do
          writeln;
          write(i:2);  write("  size=",STRUC(i).size);
          if STRUC(i)=none then repeat fi;
          if STRUC(i) is Listref
          then
            write("  Listref=");
            Lr:=STRUC(i); working:=Lr.head;
            for j:=1 to Lr.length
            do
              write(working.offset);
              working:=working.next;
            od;
            repeat;
          fi;
          if STRUC(i) is Segment
          then
            write("  Segment=");
            S:=STRUC(i); write(S.start,S.finish);
            repeat;
          fi;
          if STRUC(i) is Repeated
          then
            write("  Repeated=");
            R:=STRUC(i); write(R.ntimes,R.references.num);
            repeat;
          fi;
          if STRUC(i) is List
          then
            write("  List=");
            L:=STRUC(i); workinge:=L.head;
            for j:=1 to L.length
            do
              write(workinge.offset);
              write(workinge.references.num);
              workinge:=workinge.next;
            od;
            repeat;
          fi;
        od;
        if PROT=none then return fi;
        if PROT(1) qua Prtpclass.perm=none then return fi;
        writeln;
        writeln("  PERMUTATIONS ");
        writeln;
        writeln("Prot   Perm    Perminv");
        for i:=1 to n
        do
          a:=PROT(i);  write(i:2);  write("    ");
          if a in Prtpmod
          then
            d:=a;
            for j:=1 to maxlevel
            do
             if j<=d.level
             then
               write(d.perm(j):2); write(' ');
             else
               write("   ");
             fi
            od;
            write("     ");
            for j:=1 to maxlevel
            do
             if j<=d.level
             then
               write(d.perminv(j):2); write(' ');
             else
               write("   ");
             fi
            od;
          fi;

          writeln;
        od;

    end Protwrite;

    (*---------------------------------------------------------------------*)

    unit virtual Raising : procedure (signum,X: integer);
      (* virtual procedure defining raise statement  *)
      (* used in memory management and other systems *)
    end Raising;


    (*---------------------------------------------------------------------*)

    handlers
      when SS: writeln(" Incorrect prototype structure ");
           terminate;
    end handlers;


    (*--------------------------------------------------------------------*)

 (* PROTOTYPES body *)
 begin
   call Takeoffsets;
   call Takeprot;
(* call Cmptperm; *)
 end PROTOTYPES;














(*****************************************************************************)
(*                                                                           *)
(*                      MEMORY AND ADDRESSING                                *)
(*                                                                           *)
(*                       inherits PROTOTYPES                                 *)
(*                                                                           *)
(*       For structure of  addressing see IPL 18(1984) pp.179-187            *)
(*                                                                           *)
(*         Every address in this solution is a pair <ah,counter>             *)
(*          where ah points to M[lastitem..upr] and counter is               *)
(*                  an integer treated as a guard.                           *)
(*                                                                           *)
(*         Operations Member,Physical,Request and Disp are                   *)
(*      virtual, so this solution can be eventually exchanged                *)
(*                                                                           *)
(*****************************************************************************)

 unit MEMORY: PROTOTYPES class;

    var   current : integer;           (* reference to the current object   *)
                                       (* allocated in main  block          *)

    const minsize=2,                   (* defines minimal object size       *)
          upr = memorylength-1,        (* M[lwr+1..upr] is memory  for      *)
                                       (* objects and virtual addresses     *)

      (* Now some auxiliary RS references are allocated *)

          virt1 = reflength,           (* address of  main program          *)
          virt2 = virt1+reflength,     (* address of recently open object   *)
          virt3 = virt2+reflength,     (* address of auxiliary reference    *)
	  virt4 = virt3+reflength,     (* address of auxiliary reference    *)
          virtn = virt4,               (* address of last auxiliary ref.    *)
          lwr = virtn+reflength;       (* M[lwr]=sentinel for killed list   *)
                                       (* lwr+1 first normal memory word    *)
    (*-----------------------------------------------------------------------*)

    unit virtual Physical:function (X:integer): integer;

       (* computes effective address  for a  given reference at M[X] *)

    begin
      if Member(X)
      then
        result:=M(M(X))
      else
        call Raising(reftonone,virt2); (* reference to none *)
      fi;
    end Physical;


    (*----------------------------------------------------------------------*)

    unit virtual Member: function (X: integer):boolean;

      (* test for none , X points a reference  at M[X] *)

    begin
      result := M(X+1)=M(M(X)+1)
    end Member;

    (*----------------------------------------------------------------------*)


    unit virtual Request: procedure (pt,length,X:integer);

      (* takes a new frame for object of type defined by pt *)
      (* parameter length is necessary because of arrays    *)
      (* reference to a frame is returned at address M[X]   *)

      var t1,t2,t3,t4,t5:   integer,
          ah,am:            integer,
          a:                Prtp,
          wascomp, found:   boolean;

    begin
       if length >= maxapp
       then
         raise Error (" memory overflow");
       fi;
       if length <= minsize
       then
         length:=minsize;
       fi;
       wascomp:=false;
                  (* take new dictionary item *)
       if freeitem =/=0
       then
         ah:=freeitem;       freeitem:=M(ah)
       else
         ah:=lastitem-reflength;
         if ah <= lastused
         then
           call Compactify;  wascomp:=true;
           ah:=lastitem-reflength;
           if ah <= lastused
           then
             raise Error (" memory overflow");
           fi;
         fi;
         lastitem:=ah;       M(ah+1):=0
       fi;
                        (* take new frame *)
       t1:=lastused+length;
       if t1<lastused orif t1>=lastitem
       then
         if length=2 and headk2=/=0
         then
           am:=headk2;       headk2:=M(am+shortlink);
         else
           t1:=headk;        found:=false;
           t4:=0;
           while  t1=/=lwr and not found
           do
             t2:=M(t1);
             if t2=length
             then
               found :=true
             else
               if t2-length >=2
               then
                 found:=true
               else
                 t4:=t1;     t1:=M(t1+longlink);
               fi
             fi;
           od;
           if not found
           then
             if wascomp then raise Error (" memory overflow"); fi;
             M(ah):=freeitem;            freeitem:=ah;        (* release ah *)
             call Compactify;            ah:=lastitem-2;
             lastitem:=ah;               M(ah+1):=0;
             t1:=lastused+length;
             if t1<lastused orif t1>=lastitem
             then
               raise Error (" memory overflow");
             fi;
             am:=lastused+1;             lastused:=t1;
           else
             t5:=M(t1+shortlink);        am:=t1;
             if t5=/=0
             then
               M(t5+longlink):=M(t1+longlink)
             else
               t5:=M(t1+longlink);
             fi;
             if t4=0 then headk:=t5 else M(t4+longlink):=t5 fi;
             if t2>length
             then
               t5:=t1+length;   M(t5):=t2-length;
               call Sinsert(t5)
             fi
           fi;
         fi;
       else
         am:=lastused+1;            lastused:=t1
       fi;
                  (* clear object *)
       for t2:=am to am+length-1 do M(t2):=0 od;
                  (* set reference *)
       M(X):=ah;                    M(X+1):=M(ah+1);
       a:=PROT(pt);                 am:=am+a.Ptposition;
       M(am):=pt;                   M(ah):=am;
    end Request;

    (*----------------------------------------------------------------------*)

    unit virtual Disp: procedure (X:integer);

     (* simple kill of object referenced at M[X] *)

      var counter:     integer,
          length:      integer,
          am,ah:       integer,
          a:           Prtp;

     begin

        if not Member(X) then return fi;
        ah:=M(X);                 am:=M(ah);   (* compute ah and am          *)
        counter:=M(ah+1);
        counter:=counter+1;                    (* advance guard counter      *)
        M(ah+1):=counter;
        if counter=/=maxcounter                (* if counter not exhausted   *)
        then
           M(ah):=freeitem;  freeitem:=ah      (* release virtual address    *)
        fi;
        a:=PROT(M(am));                        (* a is a prototype of object *)
        if am+a.Size(am)-a.Ptposition-1 = lastused
        then                                   (* bordering free space       *)
          lastused:=lastused-a.Size(am)        (* am because of arrays       *)
        else
           length:=a.Size(am);                 (* length is object size      *)
           am:=am-a.Ptposition;                (* change am to the beginning *)
           M(am):=length;
           call Sinsert(am);
        fi

    end Disp;


    (*----------------------------------------------------------------------*)

     unit virtual Refmove : procedure(X,Y:integer);

           (* this procedure is used for moving references *)
     begin
       M(X):=M(Y);         M(X+1):=M(Y+1);
     end Refmove;

    (*---------------------------------------------------------------------*)

     unit virtual Setnone : procedure(X:integer);

           (* this procedure is used for setting to none *)
     begin
       M(X):=0;            M(X+1):=0;
     end Setnone;

    (*--------------------------------------------------------------------*)

      unit virtual Notequal: function(X,Y:integer): boolean;

           (* this procedure tests whether references are not equal *)

      begin
        if Member(X)
        then
          if Member(Y)
          then
            result:=Physical(X)=/=Physical(Y)
          else
            result:=true
          fi
        else
          result:=Member(Y)
        fi
      end Notequal;

    (*--------------------------------------------------------------------*)

      unit virtual Equal: function(X,Y:integer): boolean;

           (* this procedure tests whether references are equal *)

      begin
        result:=not Notequal(X,Y)
      end Equal;


    (*######################################################################*)
    (*                                                                      *)
    (*                    END OF SPECIFICATION PART                         *)
    (*                                                                      *)
    (*######################################################################*)



   const  maxapp = maxint,         (* maximal appetite                       *)
          shortlink = 1,           (* pointer to next killed of equal size   *)
          longlink = 2,            (* pointer to next killed of greater size *)
          maxcounter = maxint;	   (* maximal counter value                  *)

   var
        freeitem:       integer,   (* address of first free ah               *)
        headk:          integer,   (* address of first killed                *)
        headk2:         integer,   (* address of first killed length 2       *)
        lastused:       integer,   (* M[lastused..maxint] for objects        *)
        lastitem:       integer;   (* M[1..lastitem] for virtual addresses   *)



    (*-----------------------------------------------------------------------*)
    unit Sinsert :procedure (am:integer);

       (* dispose of a memory piece from M[am] to M[am+app-1]  *)
       (*                  where app = M[am]                   *)

     var t1,t2,t3,t4:   integer;

    begin
      t1:=M(am);
      if t1=2
      then
        M(am+shortlink):=headk2;   headk2:=am
      else
        t2:=headk;                 t4:=0;
        do
          t3:=M(t2);
          if t1=t3
          then
            M(am+shortlink):=M(t2+shortlink);
            M(t2+shortlink):=am
          else
            if t1<t3
            then
              M(am+longlink):=t2;   t1:=t3;
              M(am+shortlink):=0;
              if t4=0 then headk:=am else M(t4+longlink):=am fi;
            else
              t4:=t2;               t2:=M(t2+longlink)
            fi
          fi;
          if t1=t3 then exit fi;
        od;
      fi;
    end Sinsert;



    (*----------------------------------------------------------------------*)

     unit Compactify : procedure ;

      (*-----------------------------------------------------------------*)
      (* Compactify squeezes the memory of objects and virtual addresses *)
      (*                   collecting first garbage                      *)
      (*                                                                 *)
      (*                   - a play in nine  acts  -                     *)
      (*                                                                 *)
      (*-----------------------------------------------------------------*)


      const skilled = -1;      (* dummy prototype for killed objects     *)
      var   nlength:  integer; (* variable for keeping free space length *)

       (*----------------------------------------------------------------*)
       unit nonefy :procedure (am:integer);
         (* one of the actions for Traverse, converts none to <0,0> *)
       begin
           if M(am+1) =/= M(M(am)+1)
           then
             M(am):=0;  M(am+1):=0
           fi;
       end nonefy;

       (*----------------------------------------------------------------*)

       unit relocate: procedure(am:integer);

         (* one of the actions for Traverse, updates virtual address *)
         (*     for none=<0,0> a proper updating requires M[1]=0     *)
       begin
         M(am):=M(M(am)+1); M(am+1):=0;
       end relocate;



     (*---------------------------------------------------------------------*)

      unit Traverse :procedure(am:integer; procedure action(i:integer));

         (* this procedure is used  for compactification of memory and it  *)
         (*    traverses all references in an object pointed by am and     *)
         (*             performs action(i) on each of them                 *)


          (*---------------------------------------------------------------*)

           unit Pointed : procedure (acron:integer,references:Offsets);

            (* this recursive procedure performs action(i) on references    *)
            (* defined by the compiler and encoded in the structure Offsets *)
            (*              in a subframe starting from acron               *)

             var i,k:        integer,
                 b:          boolean,
                 L:          List,
                 Lr:         Listref,
                 S:          Segment,
                 R:          Repeated,
                 working:    Elem,
		 workinge:   Elemex,
                 ref:        Offsets;
           begin
             if references=none then return fi;     (* no references *)
             if references is Listref
             then
               Lr:=references;
               working:=Lr.head;                    (* initialize list scan *)
               for i:=1 to Lr.length
               do
                 k:=working.offset;
                 call action(acron+k);
		 working:=working.next;
               od;
               return;
             fi;
             if references is Segment
             then
               S:=references;
               for i:=S.start step reflength to S.finish
               do                                  (* for a reference value *)
                 call action(acron+i)
               od;
               return;
             fi;
             if references is Repeated
             then
               R:=references;
               k:=acron;
               for i:=1 to R.ntimes
               do
                 call Pointed(k,R.references);
                 k:=k+R.size;
               od;
               return;
             fi;
             if references is List
             then
               L:=references;
               workinge:=L.head;                    (* initialize list scan *)
               for i:=1 to L.length
               do
                 k:=workinge.offset;
		 ref:=workinge.references;
                 call Pointed(acron+k,ref);
		 workinge:=workinge.next;
               od;
               return;
             fi;

           end Pointed;

           (*---------------------------------------------------------------*)

         var a:           Prtp,
             references:  Offsets,
             pt:          integer,
             kind,i:      integer;

      (* body of Traverse *)
      begin
           pt:=M(am);
           if pt<0 then pt:=-pt fi;                (* if object marked pt<0 *)
           a:=PROT(pt);                            (* a is object prototype *)
           if a in Prtpsimpl
           then
             references:=a qua Prtpsimpl.references;
             call Pointed(am,references);
             if a in Prtpmod
             then
               call action(a qua Prtpmod.Dl(am));
               call action(a qua Prtpmod.Sl(am));
             fi;
           else                                     (*  adjustable array  *)
             if a is Prtparpr                       (* primitive elements *)
             then
               return;                              (* do nothing         *)
             fi;
             if a is Prtparrf                       (* reference elements *)
             then                                   (* for array elements *)
               for i:=am+elmoffset step reflength to am+a.Size(am)-1
               do
                 call action(i);                    (* do action          *)
               od;
             else                                   (* for structured     *)
               references:=a qua Prtparstr.references;
               call Pointed(am+elmoffset,references);
             fi;
           fi;
      end Traverse;


      (*-------------------------------------------------------------------*)
      unit act1: procedure;

       (*   garbage collection is performed in the following way :    *)
       (* all objects reachable from the current one are visited  and *)
       (* marked; the way of marking uses M[am]=pt and changes it to  *)
       (* the negative value M[am]=-pt;   when dictionary of virtual  *)
       (* addresses is scaned in act4, then  non-marked objects are   *)
       (* killed and marked objects are corrected, i.e. M[am]:=pt     *)

      (*---------------------------------------------------------------*)
         unit mark: procedure (i:integer);

         (* procedure analyzes  reference <M[i],M[i+1]>; if it denotes *)
         (* an alive object, then  for such an object marking is done  *)
         (*           and for all which are pointed from it            *)
         var am:integer;
        begin
          if Member(i)
          then
            am:=Physical(i);
            if M(am)>0                       (* object not yet marked  *)
            then
              M(am):=-M(am);                 (* mark this object       *)
              call Traverse(am,mark);        (* mark reachable from am *)
            fi;
          fi;
        end mark;

      (*---------------------------------------------------------------*)
      var am:     integer;

      begin
        am:=Physical(current);
        M(am):=-M(am);                          (* mark current object   *)
        call Traverse(am,mark);                 (* visit all reachable   *)
      end act1;

      (*-----------------------------------------------------------------*)
       unit act2: procedure;

          (* scans freeitem list  and puts counter = maxcounter so that  *)
          (* each unusable entry M[ah],M[ah+1] has the form x,maxcounter *)

        var t1:    integer;

       begin

          t1:=freeitem;
          while t1=/=0
          do
             M(t1+1):=maxcounter; t1:=M(t1)
          od;

       end act2;

       (*-----------------------------------------------------------------*)

       unit act3: procedure;

        (*  scans thru dictionary  table  and for alive  addresses       *)
        (* a corrects the value of Statsl in Sl fathers                  *)

        var t1,t2,t3:       integer,
            b:              Prtpmod,
            a:              Prtp;
       begin
          for t1:=lastitem step reflength to upr
          do
            if M(t1+1)=/=maxcounter               (* alive object        *)
            then
              t2:=M(t1);                          (* t2 = am of object   *)
              if M(t2)>0                          (* object to be killed *)
              then
	        a:=PROT(M(t2));
		if a in Prtpmod
		then
                  b:=a;              t2:=b.Sl(t2);
		  t2:=Physical(t2);
		  b:=PROT(abs(M(t2)));
		  t3:=b.Statsl(t2);  M(t3):=M(t3)-1;
		fi;
	      fi;
	    fi;
          od;
       end act3;
       (*-----------------------------------------------------------------*)

       unit act4: procedure;

        (*  scans thru dictionary  table  and for alive  addresses       *)
        (*  exchanges M[am-lspan],M[am],M[ah] with M[am],ah,M[am-lspan]; *)
        (*  objects marked by procedure prologue are put to killed list  *)
        (*                         ATTENTION!!!                          *)
        (*  when lspan=0 we have a special case, cf. act4,act5 and act7  *)


        var t1,t2,t3:       integer,
            a:              Prtp;
       begin
          for t1:=lastitem step reflength to upr
          do
            if M(t1+1)=/=maxcounter               (* alive object        *)
            then
              t2:=M(t1);                          (* t2 = am of object   *)
              if M(t2)<0                          (* marked object       *)
              then
                M(t2):=-M(t2)                     (* reconstruct pt      *)
              else
                M(t1+1):=maxcounter;              (* kill address        *)
                a:=PROT(M(t2));                   (* a is object prot.   *)
                t3:=a.Size(t2);                   (* t3 is object size   *)
                t2:=t2-a.Ptposition;              (* move t2 to begin.   *)
                M(t2):=t3;
                call Sinsert(t2);                 (* kill this object    *)
                repeat;                           (* skip the rest       *)
              fi;
              a:=PROT(M(t2));
              if a.Ptposition=/=0                 (* prot.numb.not first *)
              then
                t3:=t2-a.Ptposition;  M(t1):=M(t3);
                M(t3):=M(t2);         M(t2):=t1;
              else                                (* prot. num. first *)
                M(t1):=M(t2+1);       M(t2+1):=t1
              fi;
            fi;
          od;
       end act4;

       (*----------------------------------------------------------------*)

       unit act5: procedure;

         (* marks the killed objects substituting prototype number to    *)
         (* a special value, so that during scanning memory we will be   *)
         (* able to tell apart the killed objects just by such a number; *)
         (* the length of a killed object is put on the M[i+shortlink]   *)

        var t1,t2,t3:   integer;

       begin
         t1:=headk2;
         while t1 =/= 0
         do
           t2:=M(t1+shortlink);    M(t1+shortlink):=2;
           M(t1):=skilled;         t1:=t2;
         od;
         t1:=headk;
         while t1 =/= lwr
         do
           t2:=t1;
           while t2 =/=0
           do
             t3:=M(t2+shortlink);  M(t2+shortlink):=M(t2);
             M(t2):=skilled;       t2:=t3
           od;
           t1:=M(t1+longlink);
         od;

       end act5;

       (*-------------------------------------------------------------------*)

         (* Now we can scan the memory without looking at  dictionary *)

       (*-------------------------------------------------------------------*)

       unit act6: procedure;

         (* scans thru the memory and for alive objects call traverse       *)
         (* in order to set virtual addresses equal none identical to <0,0> *)
         (*           RS auxiliary references are also corrected            *)

        var t1,t2,t3,t4,t5:   integer,
            a:                Prtp;

       begin
         t1:=lwr+1;
         while t1 <= lastused
         do
           if  M(t1)=/=skilled                       (* alive object        *)
           then
             t3:=M(t1);          a:=PROT(t3);        (* a - prototype       *)
             if a.Ptposition =/=0
             then
               t2:=t1+a.Ptposition;   t4:=M(t2);
               M(t1):=M(t4);                         (* reconstruct M[t1]   *)
               M(t2):=t3;                            (* reconstruct M[t2]   *)
             else
               t4:=M(t1+1);      M(t1+1):=M(t4);     (* reconstruct M[t1+1] *)
               t2:=t1;
             fi;
             t5:=a.Size(t2);                         (* object size         *)
             call Traverse(t2,nonefy);               (* set none to <0,0>   *)
             if a.Ptposition =/=0
             then
               M(t2):=t4;  M(t1):=t3;
             else
               M(t1+1):=t4
             fi;
             t1:=t1+t5
           else
             t1:=t1+M(t1+shortlink)                  (* M[t1+shortlink]=size *)
           fi
         od;
         for t1:=virt1 step reflength to virtn
         do
           call nonefy(t1);
         od;
       end act6;

       (*-----------------------------------------------------------------*)

       unit act7: procedure;

        (* squeezes  dictionary  putting on counters new values of ah  *)

        var t1,t2,t3: integer;

       begin

         t1:=upr-1;             t2:=t1;
         while t1>= lastitem
         do
           if M(t1+1)=maxcounter              (* entry killed *)
           then
             M(t1+1):=0
           else
             M(t1+1):=t2;       t2:=t2-reflength;
           fi;
           t1:=t1-reflength;
         od;
       end act7;

       (*-------------------------------------------------------------------*)

       unit act8: procedure;

        (* squeezes the memory, killed objects are removed, remaining pushed *)
        (* for alive objects references are relocated .i.e. new ah and new   *)
        (* counters are computed;M[am-lspan], M[am], M[ah] are reconstructed *)
        (*      finally all auxiliary RS references are also relocated       *)

        var t1,t2,t3,t4,t5,t6:   integer,
            a:                   Prtp;

       begin
         M(1):=0;                               (* M[1]=0  for relocate *)
         t1:=lwr+1;           t2:=t1;
         while t1 <= lastused
         do
           if M(t1)=skilled                     (* ignore this object   *)
           then
              t1:=t1+M(t1+shortlink)            (* M[t1+shortlink]=size *)
           else
              t6:=M(t1);                        (* prototype number     *)
              a:=PROT(t6);                      (* object prototype     *)
              t4:=t1+a.Ptposition;              (* t4 is amold          *)
              if a.Ptposition=/=0
              then
                t5:=M(t4);                      (* t5 is old ah         *)
                M(t4):=t6;                      (* reconstruct M[t4]    *)
                M(t1):=M(t5);                   (* reconstruct M[t1]    *)
              else
                t5:=M(t1+1);                    (* t5 is old ah         *)
                M(t1+1):=M(t5);                 (* reconstruct M[t1+1]  *)
              fi;
              t3:=a.Size(t4);
              for t6:=0 to t3-1                 (* copy object          *)
              do
                M(t2+t6):=M(t1+t6);
              od;
              t6:=t2+a.Ptposition;              (* t6 is amnew          *)
              M(t5):=t6;                        (* set proper  M[ah]    *)
              call Traverse(t6,relocate);
              t1:=t1+t3;
              t2:=t2+t3;
           fi;
         od;
                   (* relocate RS auxiliary references *)
         for t1:=virt1 step reflength to virtn
         do
           call relocate(t1);
         od;
                   (* initialize  working variables  *)
         M(1):=1;                               (* reconstruct  M[1]    *)
         lastused:=t2-1;     headk2:=0;
         headk:=lwr;
       end act8;

       (*------------------------------------------------------------------*)

       unit act9: procedure;

          (*    squeezes dictionary  *)

        var t1,t2,t3: integer;

       begin
         t1:=upr+1;      t2:=t1-reflength;
         while t2 >=lastitem
         do
           t3:=M(t2+1);
           if t3 =/=0
           then
             M(t3):=M(t2);       M(t3+1):=0;
             t1:=t3;
           fi;
           t2:=t2-reflength;
         od;
         lastitem:=t1;           freeitem:=0;

       end act9;


       (*----------------------------------------------------------------*)
     var i: integer;
    (* Compactify body *)
    begin
      nlength:=lastitem-lastused;
      call act1; call Memorydump;
      call act2; call Memorydump;
      call act3; call Memorydump;
      call act4; call Memorydump;
      call act5; call Memorydump;
      call act6; call Memorydump;
      call act7; call Memorydump;
      call act8; call Memorydump;
      call act9; call Memorydump;
      writeln(" compactifier used;released space=", lastitem-lastused-nlength);
    end Compactify;


    (*----------------------------------------------------------------------*)

     unit Memorydump : procedure;


       var i,j,k,l,u:      integer;


     begin
       writeln;
       writeln("                  SYSTEM VARIABLES");
       writeln("freeitem  lastused  lastitem  headk  headk2  lwr  upr");
       write(freeitem:8); write(lastused:8); write(lastitem:8);
       write(headk:6);write("    "); write(headk2:6);write("  ");
       write(lwr:4);write("    "); writeln(upr:4);
       writeln("                VIRTUAL ADDRESSES");
       l:=upr-1;
       do
         if l-18 > lastitem then u:=l-18 else u:=lastitem fi;
         write(" ah     ");
         for i:=l step reflength downto u do write(' ',i:5) od;
         writeln;
         write(" M[ah]  ");
         for i:=l step reflength downto u do write(' ',M(i):5) od;
         writeln;
         write(" M[ah+1]");
         for i:=l step reflength downto u do write(' ',M(i+1):5) od;
         writeln;
         if u=lastitem then exit else l:=u-reflength fi;
       od;
       writeln("                    OBJECTS");
       j:=0;
       for i:=0 to lastused
       do
         write(' ',M(i):5);  j:=j+1;
         if j=10
         then
           writeln; j:=0;
         fi;
       od;
       writeln;
     end Memorydump;

     (*--------------------------------------------------------------------*)


 (* MEMORY body *)
 begin
   array M dim (0:upr);                           (* main memory          *)
   M(0):=0;                      M(1):=1;         (* <0,0> = none         *)
   freeitem:=0;                  lastused:=lwr;
   headk:=lwr;                   headk2:=0;
   lastitem:=upr+1;              M(lwr):=maxapp;  (* sentinel of killed   *)
 end MEMORY;









(****************************************************************************)
(*                                                                          *)
(*                               OBJECTS                                    *)
(*                          inherits  MEMORY                                *)
(*                                                                          *)
(*                                                                          *)
(*                     used to open a new object and pass                   *)
(*                        the control to and back                           *)
(*                                                                          *)
(*     Sl links are used to keep the syntactic environment of an object.    *)
(*       Dl links inform where to pass the control back from an object.     *)
(*                                                                          *)
(*     Sl links create a tree structure on the set of objects; this tree    *)
(*              is embedable into the decl syntactic tree.                  *)
(*        Dl links create a structure formed from the active  chain and     *)
(*        and a number of cycles corresponding to suspended coroutines      *)
(*                       or terminated objects.                             *)
(*       New statement adds a new object with Sl,Dl defined as usually.     *)
(*            Return statement in any object sets Dl to itself.             *)
(*               End statement in coroutines sets LSC to zero.              *)
(*        End statement in the other objects is equivalent to return.       *)
(*                                                                          *)
(****************************************************************************)

unit OBJECTS: MEMORY class;


   var IC:          integer,        (* global control indicator            *)
       DISPLAY:     integer;        (* pointer to Display array allocated  *)
                                    (* in main block                       *)


   (*----------------------------------------------------------------------*)

   unit Openrc: procedure (pt,X:integer);

      (* opens a new frame for a simple class whose prototype     *)
      (* defined by pt;reference to an object is returned at M[X] *)

     var a:       Prtpsimpl,
         length:  integer;

   begin
     a:=PROT(pt);                  length:=a.Size(0);   (* dummy parameter *)
     call Request(pt,length,X);
   end Openrc;

   (*----------------------------------------------------------------------*)

   unit Slopen :procedure(pt,X,Y:integer);

     (* opens a new frame for an object with given Sl at M[Y] *)
     (*               returns reference at M[X]               *)

    var am:            integer,
        length:        integer,
        a,b:           Prtpmod,
        Stat:          integer,
        Sl,Dl:         integer;

   begin
     a:=PROT(pt);                length:=a.Size(0);     (* dummy parameter *)
     call Request(pt,length,X);
     am:=Physical(X);
     Sl:=a.Sl(am);
     call Refmove(Sl,Y);                                (* define  Sl link *)
     Dl:=a.Dl(am);
     call Refmove(Dl,current);                          (* define Dl link  *)
     am:=Physical(Y);
     a:=PROT(M(am));
     Stat:=a.Statsl(am);
     M(Stat):=M(Stat)+1;                                (* advance Statusl *)
   end Slopen;

   (*------------------------------------------------------------------------*)

   unit Dopen :procedure (pt1,pt2,X: integer);

    (* opens a new frame for a visible object, so Sl is taken from Display *)
    (* it corresponds to a statement "new C" executed in a module  "B"     *)
    (*               where C is defined by pt1 and B by pt2                *)


    var  a,b:           Prtpmod;

   begin
     a:=PROT(pt1) qua Prtpmod.declto;      (* prototype of father C  *)
     b:=PROT(pt2);                           (* prototype of B         *)
     call Slopen(pt1,X,DISPL(b.perm(a.level)));
   end Dopen;

   (*----------------------------------------------------------------------*)

   unit Openarray: procedure (pt,l,u,X:integer);

      (* performs generation newarray[l..u]  of type defined by pt *)

     var length:     integer,
         am:         integer,
         a:          Prtparr,
         references: Offsets;
   begin
     length:=u-l+1;               a:=PROT(pt);
     if a in Prtparnst
     then
       length:=length*a qua Prtparnst.elsize;
     else
       length:=length*a qua Prtparstr.references.size
     fi;
     length:=length+elmoffset;                     (* add system attributes *)
     call Request(pt,length,X);   am:=Physical(X);
     M(am+lboffset):=l;           M(am+uboffset):=u;
   end Openarray;


   (*-----------------------------------------------------------------------*)

   unit Go : procedure(X:integer);

     (* transfers control to the newly created object defined by X *)

    var a,b:      Prtpmod,
        am:       integer;

   begin
     am:=Physical(current);
     a:=PROT(M(am));
     M(a.Lsc(am)):=IC;                         (* save local control     *)
     call Update(X);
     call Refmove(current,X);                  (* new current            *)
     am:=Physical(X);
     a:=PROT(M(am));
     b:=a;
     while a=/=none                            (* search in prefix seq.  *)
     do                                        (* first non-simple class *)
       if not a is Prtpsimpl
       then
         b:=a;
       fi;
       a:=a.prefto;
     od;
     IC:=b.codeadd;
   end Go;

   (*------------------------------------------------------------------------*)

   unit Back: procedure;

      (*            return from a module is Back                    *)
      (*       end in non-coroutine is equivalent to  Back          *)
      (*  end in coroutine is equivalent to Endcor, cf. COROUTINES  *)

    var Dl:                integer,
        am:                integer,
        a:                 Prtpmod;

   begin
     am:=Physical(current);
     a:=PROT(M(am));
     Dl:=a.Dl(am);
     if not Member(Dl)                           (* return in main  or in   *)
     then                                        (* attached coroutine is   *)
      return                                     (* equivalent to empty     *)
     fi;
     call Refmove(virt2,current);                (* set proper output       *)
     M(a.Lsc(am)):=IC;                           (* update local seq. cont. *)
     call Refmove(current,Dl);                   (* current becomes Dl      *)
     call Refmove(Dl,virt2);                     (* set Dl in old to itself *)
     call Update(current);
     am:=Physical(current);
     a:=PROT(M(am));                             (* prototype of new object *)
     IC:=M(a.Lsc(am));                           (* IC is local seq. contr. *)
   end Back;

   (*------------------------------------------------------------------------*)


    unit Inn: procedure (k:integer);

      (* simulates the execution of inner in a class, k is pslength *)
      (*            of a class where inner is executed               *)


     var t:         integer,
         am:        integer,
         a:         Prtpsub;

    begin
      am:=Physical(current);
      a:=PROT(M(am));                           (* prototype of current *)
      if a.pslength=/=k                         (* if inner=/= empty    *)
      then
        for t:=2 to a.pslength-k                (* search for a layer   *)
        do
          a:=a.prefto;
        od;
        IC:=a.codeadd;
      fi;
    end Inn;

  (*------------------------------------------------------------------------*)


   unit Endrun: procedure;
    var i: integer;
    (* end  or return in main block *)
    begin
      writeln(" Print memory? (0,1)");
      read(i);
      if i=1
      then
         call Compactify;
	 call Memorydump
      fi;
      raise Error("End of a program execution");
    end Endrun;



   (*-----------------------------------------------------------------------*)

    unit prf: function (X:integer, a: Prtpmod): boolean;

     (* determines whether prototype a belongs to a prefix sequence of X *)
    var b:         Prtpmod,
        am:        integer;
    begin
      result:=false;
      am:=Physical(X);
      b:=PROT(M(am));
      while b =/= none
      do
        if a=b then result:=true; return; fi;
        b:=b.prefto;
      od;
    end prf;

   (*-----------------------------------------------------------------------*)

    unit qual : procedure (X: integer , a: Prtpmod);

      (* validate qualification of object X by class type a *)
    begin
      if not prf(X,a)
      then
        call Raising(incorqua,virt2);
      fi;
    end qual;

   (*---------------------------------------------------------------------*)

   unit inl: function (X:integer, a:Prtp): boolean;

    (* validate  X in a *)
   begin
     if not Member(X)
     then                          (* none is in everything *)
       result:=true;
     else
       result:=prf(X,a);
     fi;
   end inl;

  (*------------------------------------------------------------------------*)

  unit isl : function (X:integer, a:Prtp): boolean;
    (* validate X is a *)
  var am:     integer;
  begin
    if not Member(X)
    then                                           (* none is not something *)
      result:=false;
    else
      am:=Physical(X);
      result:=PROT(M(am))=a;
    fi
  end isl;

  (*-------------------------------------------------------------------------*)

  unit typeref: procedure  (X:integer, a: Prtp);

   (* check correctness of assignment  Y:=X where type of Y is a *)
  begin
    if Member(X)                               (* none allowed everywhere *)
    then
      if not prf(X,a)
      then
         call Raising(incorassg,virt2);        (* incorrect assignment *)
      fi;
    fi;
  end typeref;

  (*-----------------------------------------------------------------------*)

  unit typed :procedure (ldim,rdim,X:integer;a,b:Prtp);

   (* check correctness of Y:=X where X and Y are adjustable arrays *)
   (* type of Y is array ldim of a, type of X is array rdim of b    *)
  begin
    if ldim=/=rdim
    then
      call Raising(incorassg,virt2);        (* incorrect assignment *)
    fi;
    if ldim=0
    then
      call typeref(X,a)
    else
      if a=/=b
      then
        call Raising(incorassg,virt2);      (* incorrect assignment *)
      fi;
    fi;
  end typed;

  (*--------------------------------------------------------------------*)

  unit gkill : procedure (X:integer);


       (*            general killer of pointed objects                *)
       (* It can kill an object of array or simple class, as well as  *)
       (* a cycle of coroutine. In the latter case because of calls   *)
       (* to procedure killer which kills SL chain (if possible) one  *)
       (* must change the order of this cycle. Taking this cycle in   *)
       (* reverse order we can call killer with security that the     *)
       (* whole cycle will be properly deallocated. This method bases *)
       (* strongly on the fact that if  X Dl Y, then not Y Sl* X.     *)

  var   a:    Prtp,
        b:    Prtpmod,
	Dl:   integer,
	am:   integer;
  begin
      if not Member(X) then return fi;        (* kill only alive object  *)
      am:=Physical(X);
      a:=PROT(M(am));
      if  a  in Prtparr orif a is Prtpsimpl   (* no problems with arrays *)
      then                                    (* or with records         *)
        call Disp(X);  return;
      fi;
      if a is Prtpclass                       (* kill class if possible  *)
      then
        b:=a;
	if M(b.Statsl(am))=/=0
	then
	   call Raising(incorkill,virt2)
	fi;
        call Refmove(virt3,b.Sl(am));
        call Disp(X);
        call killer;
        return;
      fi;
      if a is Prtpproc  then  call Raising(incorkill,virt2) fi;

            (*  kill coroutine - methods in three phases  *)
      b:=a;
      Dl:=X;
      do                               (* first loop, examine all Statussl *)
	call Refmove(virt4,Dl);
	if M(b.Statsl(am))=/=0
	then
	   call Raising(incorkill,virt2)
	fi;
        Dl:=b.Dl(am);
	if Equal(X,Dl) then exit fi;
	am:=Physical(Dl);        b:=PROT(M(am));
      od;
      call Refmove(virt2,X);
      do                               (* second loop, change  the order  *)
        am:=Physical(virt2);
	b:=PROT(M(am));
        Dl:=b.Dl(am);
	call Refmove(virt3,Dl);
	call Refmove(Dl,virt4);
	call Refmove(virt4,virt2);
	call Refmove(virt2,virt3);
	if Equal(virt2,X) then exit fi;
      od;
      do                              (* third loop, kill all objects   *)
        am:=Physical(X); b:=PROT(M(am));
        call Refmove(virt3,b.Sl(am));
        call Refmove(virt4,b.Dl(am));
        call Disp(X);
        call killer;
        call Refmove(X,virt4);
        if not Member(X) then exit fi;
      od;
  end gkill;


    (*######################################################################*)
    (*                                                                      *)
    (*                    END OF SPECIFICATION PART                         *)
    (*                                                                      *)
    (*######################################################################*)


   (*-----------------------------------------------------------------------*)

   unit DISPL: function(d:integer): integer;
      (* auxiliary function returning an address of DISPLAY[d] in M *)
   begin
     result:=DISPLAY+(d-1)*reflength;
   end DISPL;


   (*-----------------------------------------------------------------------*)

   unit Update: procedure (X:integer);


     (* Update DISPLAY procedure, see LNCS 208, pp.134-156 *)

     var a,c,d,e:    Prtpmod,
         am:         integer,
         j,k:        integer;


   begin
    am:=Physical(X);
    a:=PROT(M(am));               k:=a.level;
    d:=a;                         e:=a;
    do
      call Refmove(DISPL(e.perm(k)),X);
      if k=1 then return fi;
      k:=k-1;
      j:=a.perminv(d.perm(k));
      d:=d.declto;
      do
        c:=a.declto;              X:=a.Sl(am);   (* compute address of Sl *)
        am:=Physical(X);                         (* take next object *)
        a:=PROT(M(am));
        j:= a.perminv(c.perm(j));
        if a.level=j then exit fi
      od
    od
   end Update;



  (*-----------------------------------------------------------------------*)

  unit killer: procedure;

    (* this procedure kills Sl chain of virt3 , if Statussl allows it *)

  var am:   integer,
      Stat: integer,
      a:    Prtpmod;

  begin
    do
      am:=Physical(virt3);      a:=PROT(M(am));
      Stat:=a.Statsl(am);       M(Stat):=M(Stat)-1;
      if M(Stat)=0                                  (* StatusSl = 0       *)
      andif (not a in Prtpclass)                    (* it is not class    *)
      andif Equal(virt3,a.Dl(am))                   (* object terminated  *)
      then
        call Refmove(virt2,a.Sl(am));
	call Disp(virt3);
        call Refmove(virt3,virt2);
      else
        exit
      fi;
    od;
   end killer;

  (*-----------------------------------------------------------------------*)

  unit killafter: procedure;

    (* this procedure kills an object of non-class after return *)
    (* the reference to returned object is kept on virt2 always *)

  var am:   integer,
      Stat: integer,
      a:    Prtpmod;

  begin
     am:=Physical(virt2);
     a:=PROT(M(am));
     Stat:=a.Statsl(am);
     if M(Stat)=0
     then
	call Refmove(virt3,a.Sl(am));
        call Disp(virt2);
	call killer;
     fi;
  end killafter;


  (*-----------------------------------------------------------------------*)

   var i:           integer,
       am:          integer,
       a:           Prtpmod;


   (* OBJECTS body *)
   begin
     a:=PROT(1);                            (* a is prototype of main       *)
     i:=a.Size(0);                          (* i = length of main  object   *)
     call Request(1,i,virt1);
     am:=Physical(virt1);                   (* am is physical of main       *)
     DISPLAY:=am+a qua Prtpproc.displ;      (* define address of DISPLAY[1] *)
     current:=am+a qua Prtpproc.curr;       (* define current               *)
     call Refmove(current,virt1);
     call Refmove(DISPL(1),current);        (* define Display for main      *)
   end OBJECTS;















  (************************************************************************)
  (*                                                                      *)
  (*                             COROUTINES                               *)
  (*                                                                      *)
  (*                          inherits OBJECTS                            *)
  (*                                                                      *)
  (*                      performs coroutine sequencing                   *)
  (*                                                                      *)
  (************************************************************************)







  unit COROUTINES : OBJECTS class;

   var lastcor:  integer, (* reference to the last attaching coroutine     *)
       corhead:  integer; (* reference to the active coroutine             *)


    (*--------------------------------------------------------------------*)

    unit Endcor: procedure ;

      (*  - in Loglan 82 coroutine end  was equivalent to detach -        *)
      (* here, if lastcor=/=none  attach(lastcor) else attach(main)       *)
     var
        am:                integer,
        a:                 Prtpmod;

    begin
        am:=Physical(current);
        a:=PROT(M(am));
        IC:=0;                              (*  prepare M(a.Lsc(am))=0    *)
        if Member(lastcor)
	then
          call Attch(lastcor)
	else
	  call Attch(virt1)
	fi;
    end Endcor;

   (*----------------------------------------------------------------------*)

    unit Attchaux:  class(X: integer);

      (* auxiliary for Attach and Attach with *)


    var   amnew:   integer,
          amold:   integer,
          Dl:      integer,
          a:       Prtpmod,
          b:       Prtpcor;
    begin
        if not Member(X)
        then
          call Raising(ilattach,virt2);
        fi;
        amnew:=Physical(X);                      (* take physical of X    *)
        a:=PROT(M(amnew));                       (* a is prototype of X   *)
        if not (a in Prtpcor)
        then
          call Raising(ilattach,virt2);
        fi;
        if M(a.Lsc(amnew))=0
        then
          call Raising(corterm,virt2);
        fi;
        if Equal(corhead,X) then return fi;      (* equivalent to empty   *)
        call Refmove(virt2,corhead);             (* save lastcoroutine    *)
        amold:=Physical(corhead);                (* physical of head      *)
        b:=PROT(M(amold));                       (* b is prototype of old *)
        Dl:=b.Dl(amold);                         (* compute Dl of old     *)
        call Refmove(corhead,X);                 (* set coroutinehead     *)
        call Refmove(Dl,current);                (* set Dl in old corout. *)
	call Refmove(lastcor,virt2);             (* set lastcor           *)
        b:=a;                                    (* b is prototype of new *)
        Dl:=b.Dl(amnew);                         (* compute Dl of new     *)
        amold:=Physical(current);                (* compute current       *)
	a:=PROT(M(amold));                       (* a prototype of curr.  *)
	M(a.Lsc(amold)):=IC;                     (* remember IC           *)
      end Attchaux;


    (*--------------------------------------------------------------------*)

     unit Attch : Attchaux procedure;

       (* performs Attach(X)  *)

     begin
        call Update(Dl);                         (* update  DISPLAY       *)
        call Refmove(current,Dl);                (* set new current       *)
        call Setnone(Dl);                        (* Dl of corhead is none *)
        amnew:=Physical(current);                (* compute physical add. *)
        a:=PROT(M(amnew));                       (* a is prototype of cur.*)
        IC:=M(a.Lsc(amnew));                     (* define new IC         *)
     end Attch;

    (*--------------------------------------------------------------------*)

    (* body of COROUTINES *)
    begin
      lastcor:=am+ a qua Prtpproc . lstcr;
      corhead:=am+ a qua Prtpproc . chead;
      call Setnone(lastcor);                  (* lastcor=none *)
      call Refmove(corhead,current);          (* corhead=main *)
    end COROUTINES;




















  (************************************************************************)
  (*                                                                      *)
  (*                              HANDLING                                *)
  (*                                                                      *)
  (*                          inherits COROUTINES                         *)
  (*                                                                      *)
  (*                      performs exception handling                     *)
  (*                                                                      *)
  (************************************************************************)



  unit HANDLING : COROUTINES class;

   unit virtual Raising : procedure (signalnum,X:integer);

     (* Procedure Raising implements raise statement. Parameter signalnum *)
     (* defines signal number, M[X] returns the address of opened handler *)

     var a:    Prtpmod,
         b:    Prtpsub,
         h:    hlstelem,
         am:   integer,
         Y:    integer,
         s:    sglelem;

   begin
     Y:=current;                                (* start of searching  *)
     do                                         (* main loop           *)
       am:=Physical(Y);
       a:=PROT(M(am));                          (* take prototype      *)
       if a is Prtphand                         (* for handlers skip   *)
       then                                     (* to avoid recursiv.  *)
         Y:=a.Sl(am);                           (* handling;go via Sl  *)
	 repeat;                                (* continue searching  *)
       fi;
       b:=a;
       do                                       (* search prefix seq.  *)
         h:=b.handlist;
         do                                     (* search in module    *)
           if h=none then exit fi;              (* end of handlist     *)
           if PROT(h.hand) qua Prtphand.oth     (* for handler others  *)
	     andif signalnum <= syssigl         (* and system signals  *)
	   then
             call Slopen(h.hand,X,Y);           (* open handler object *)
	     return;
	   fi;
           s:=h.signlist;
           do                                   (* search signal list  *)
             if s = none then exit fi;          (* end of signal list  *)
             if s.signalnum=signalnum           (* handler found       *)
             then
               call Slopen(h.hand,X,Y);         (* open handler object *)
	       return;
	     fi;
	     s:=s.next;
	   od;
	   h:=h.next;
         od;
         b:=b.prefto;
         if b=none then exit fi;                (* end of prefix seq. *)
       od;
       Y:=a.Dl(am);                             (* go via Dl          *)
       if not Member(Y) then exit fi;
     od;
     raise Error(" Handler not found");
   end Raising;

   (*-----------------------------------------------------------------*)

   unit Attchwith: Attchaux procedure (signalnum,Y:integer);

     (* this procedure performs attach(X) with signalnum  *)
     (* Y points an object of a found handler             *)
   begin
     call Refmove(virt4,current);             (* save current          *)
     call Refmove(current,Dl);                (* set new current       *)
     call Setnone(Dl);                        (* Dl of corhead is none *)
     call Raising(signalnum,Y);
     call Refmove(current,virt4);             (* restore current       *)
   end Attchwith;

   (*-----------------------------------------------------------------*)

   unit Termination : procedure;

       (* Procedure Termination winds up the dynamic chain moving Lsc *)
       (* of each object on its lastwill part. For prefixed modules   *)
       (* lastwill is performed from the innermost to the outermost;  *)
       (* so, it is sufficient to move Lsc for the innermost module   *)
       (* and  for end statement in prefixed modules a jump to the    *)
       (* prefix father lastwill statement is statically executed.    *)
       (* Dummy lastwill part in this solution is always required.    *)
       (* The last statement before lastwill  in such modules passes  *)
       (* control to the corresponding post inner part, as usually.   *)

    var X:     integer,
        Y:     integer,
        a:     Prtphand,
        b:     Prtpmod,
        am:    integer;
   begin
     am:=Physical(current);                   (* take address of handler *)
     a:=PROT(M(am));                          (* prototype of handler    *)
     X:=a.Sl(am);                             (* find handler Sl father  *)
     Y:=a.Dl(am);                             (* find handler Dl father  *)
     am:=Physical(X);                         (* set am the last address *)
     do
       Y:=Physical(Y);
       b:=PROT(M(Y));                         (* prototype of module     *)
       M(b.Lsc(Y)):=b.lstwill;                (* move Lsc on lastwill    *)
       if Y=am then exit fi;                  (* end of chain            *)
       Y:=b.Dl(Y);                            (* next chain element      *)
     od;
   end Termination;


  end HANDLING;



(*****************************************************************************)
(*                                                                           *)
(*                     BODY  PART  OF PROGRAM                                *)
(*                                                                           *)
(*****************************************************************************)

 begin

   pref HANDLING block

    (************************************************************************)
    (*                                                                      *)
    (*                             EXECUTOR                                 *)
    (*                                                                      *)
    (*                        inherits COROUTINES                           *)
    (*                                                                      *)
    (*                     written only for testing RS                      *)
    (************************************************************************)


      var CODES : arrayof integer;      (*  program code  *)

        (*----------------------------------------------------------------*)
        (*   opcode:                                                      *)
        (*  1 pt   dn   off    0      0           = Openrc(pt,X)          *)
        (*  2 pt   dn1  off1   dn2   off2         = Slopen(pt,X,Y)        *)
        (*  3 pt1  pt2  dn     off    0           = Dopen(pt1,pt2,X)      *)
        (*  4 pt   dn1  off1   dn2   off2         = Openarr(pt,1,u,X)     *)
        (*  5 dn   off   0     0      0           = Go(X)                 *)
        (*  6 0    0     0     0      0           = Back address on virt2 *)
        (*  7 k    0     0     0      0           = Inn(k)                *)
        (*  8 dn1  off1 dn2    off2   0           = a:=a+b                *)
        (*  9             "                       = a:=a-b                *)
        (* 10             "                       = a:=a*b                *)
        (* 11             "                       = a:=a/b                *)
        (* 12 dn1  off1 dn2    off2   s           = a:=A[i]  for s=0      *)
        (* 13 dn1  off1  0     0      0           = A[i]:=a  for s=1      *)
        (* 14 dn   off   0     0      0           = write(a)              *)
        (* 15 dn   off   0     0      0           = read(a)               *)
        (* 16 0     0    0     0      0           = writeln               *)
        (* 17 C     0    0     0      0           = goto C                *)
        (* 18 C    dn   off    0      0           = if a=0 goto C         *)
        (* 19 C    dn   off    0      0           = if a>0 goto C         *)
        (* 20 dn   off   0     0      0           = kill(X)               *)
        (* 21 dn1  off1 dn2   off2    0           = X:=Y                  *)
        (* 22 dn   off   0     0      0           = a:=0                  *)
        (* 23 dn   off   s     0      0           = a:=a+s                *)
        (* 24 dn1  off1 dn2   off2   off          = a:=X.b                *)
        (* 25 dn1  off1 off   dn2    off2         = X.a:=b                *)
        (* 26 dn1  off1 dn2   off2   off          = Y:=X.Z                *)
        (* 27 dn1  off1 off   dn2    off2         = Y.Z:=X                *)
        (* 28 0     0    0     0      0           = endrun                *)
        (* 29 dn   off   0     0      0           = attach(X)             *)
        (* 30 0     0    0     0      0           = attach(lastcor)       *)
        (* 31 C     dn   off   0      0           = if X=none goto C      *)
        (* 32 0     0    0     0      0           = Endcor                *)
        (* 33 dn   off   pt    0      0           = qual X by a           *)
        (* 34 dn   off   0     0      0           = gkill(X)              *)
        (* 35 dn   off   pt    C      0           = if X in a goto C      *)
	(* 36 dn   off   pt    C      0           = if X is a goto C      *)
        (* 37 dn   off   pt    0      0           = typeref(X,a)          *)
        (* 38 dn   off   pt   pt1     0           = typed(k,s,            *)
        (* 39 k     s    0     0      0           =    X,pt,pt1)          *)
        (* 40 s     dn   off   0      0           = raise(s,X)            *)
        (* 41 0     0    0     0      0           = terminate             *)
	(* 42 0     0    0     0      0           = kill procedure on Dl  *)
        (* 43 dn1   off1 s     dn2    off2        = attach(X) with s      *)
        (* 44 s     dn1  off1  0      0           = attach(lastcor) with  *)
        (* 45 0     0    0     0      0           = attach(main)          *)
	(* 46 s     dn1  off1  0      0           = attach(main) with s   *)
        (*----------------------------------------------------------------*)


      unit Address: function(dnum,offset:integer):integer;
        (* gives physical address of a variable pointed by dnum,offset *)
      begin
        result:=Physical(DISPL(dnum))+offset
      end Address;

      unit Arrelem: procedure(X,i:integer; output am,length:integer);
        (* X - reference to array  and i - index value            *)
        (* am -physical address element , length - element length *)

       var   a:      Prtp,
             pt:     integer;
      begin
        am:=Physical(X);  pt:=M(am);   a:=PROT(pt);
        if i<M(am+lboffset) orif i>M(am+uboffset)
        then
          call Raising(arrayind,virt2);
        fi;
        i:=i-M(am+lboffset);
        if a in Prtparnst
        then
          length:=a qua Prtparnst. elsize;
	  am:=am+elmoffset+length * i;
        else
	  length:=a qua Prtparstr.references.size;
          am:=am+elmoffset+length * i;
        fi;
      end Arrelem;

      var n:             integer,
          dn,off:        integer,
          dn1,off1:      integer,
          dn2,off2:      integer,
          pt,pt1,pt2:    integer,
          l,u,k,i,C,s:   integer;

      handlers
         when Error: writeln; writeln(t); terminate;
      end handlers;


    (* EXECUTOR body *)

    begin
      read(f,n);  n:=n*8;
             (* each code requires 8 words, the first is the code number  *)
             (* 6 define an operation and arguments, see the table above  *)
             (* last=0,1,2 and defines trace and dump, last=1 gives trace *)
             (*     last=2 gives dump and trace simultaneously            *)
      writeln(" Print prototypes? (0,1)");
      read(i);
      if i=1 then call Protwrite fi;
      writeln(" Print memory? (0,1)");
      read(i);
      if i=1 then call Memorydump fi;
      array CODES dim (1:n);
      for i:=1 to n do read(f,CODES(i)) od;
      writeln(" Print codes? (0,1)");
      read(i);
      if i=1
      then
        writeln("  OPCODES ");
        k:=0;
        for i:=1 to n
        do
          write(CODES(i)); k:=k+1;
          if k=8 then k:=0 ; writeln; fi;
        od;
      fi;
      IC:=1;
      do
        C:=(IC-1)*8+1;
        if CODES(C+7) >= 1
        then
	  writeln(" code ");
          write(CODES(C),CODES(C+1),CODES(C+2),CODES(C+3),CODES(C+4));
	  writeln(CODES(C+5),CODES(C+6));
        fi;
        if CODES(C+7) >= 2
        then
          writeln("memory dump"); call Memorydump;
        fi;
        case CODES(C+1)
          when 1:
           pt:=CODES(C+2);dn:=CODES(C+3); off:=CODES(C+4);
           IC:=IC+1;
           call Openrc(pt,Address(dn,off));
          when 2:
           pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);
           dn2:=CODES(C+5);off2:=CODES(C+6);
           IC:=IC+1;
           call Slopen(pt,Address(dn1,off1),Address(dn2,off2));
          when 3:
           pt1:=CODES(C+2);pt2:=CODES(C+3);dn:=CODES(C+4);off:=CODES(C+5);
           IC:=IC+1;
           call Dopen(pt1,pt2,Address(dn,off));
          when 4:
           pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);
           dn2:=CODES(C+5);off2:=CODES(C+6);
           k:=M(Address(dn1,off1));
           IC:=IC+1;
           call Openarray(pt,1,k,Address(dn2,off2));
          when 5:
           dn:=CODES(C+2);off:=CODES(C+3);
           IC:=IC+1;
           call Go(Address(dn,off));
          when 6:
           dn:=CODES(C+2);off:=CODES(C+3);
           IC:=IC+1;
           call Back;
          when 7:
           k:=CODES(C+2);
           IC:=IC+1;
           call Inn(k);
          when 8:
           dn1:=CODES(C+2);off1:=CODES(C+3);
           dn2:=CODES(C+4);off2:=CODES(C+5);
           i:=Address(dn1,off1); k:=Address(dn2,off2);
           M(i):=M(i)+M(k);
           IC:=IC+1;
          when 9:
           dn1:=CODES(C+2);off1:=CODES(C+3);
           dn2:=CODES(C+4);off2:=CODES(C+5);
           i:=Address(dn1,off1); k:=Address(dn2,off2);
           M(i):=M(i)-M(k);
           IC:=IC+1;
          when 10:
           dn1:=CODES(C+2);off1:=CODES(C+3);
           dn2:=CODES(C+4);off2:=CODES(C+5);
           i:=Address(dn1,off1); k:=Address(dn2,off2);
           M(i):=M(i)*M(k);
           IC:=IC+1;
          when 11:
           dn1:=CODES(C+2);off1:=CODES(C+3);
           dn2:=CODES(C+4);off2:=CODES(C+5);
           i:=Address(dn1,off1); k:=Address(dn2,off2);
           M(i):=M(i)/M(k);
           IC:=IC+1;
          when 12:
           dn1:=CODES(C+2);off1:=CODES(C+3);
           dn2:=CODES(C+4);off2:=CODES(C+5);
           s:=CODES(C+6);
           call Arrelem(Address(dn1,off1),M(Address(dn2,off2)),k,l);
           dn1:=CODES(C+10);off1:=CODES(C+11);
           u:= Address(dn1,off1);
           if s=0
           then
             for i:= 0 to l-1 do M(u+i):=M(k+i) od;
           else
             for i:= 0 to l-1 do M(k+i):=M(u+i) od;
           fi;
           IC:=IC+2;
          when 14:
           dn:=CODES(C+2);off:=CODES(C+3);
           write(M(Address(dn,off)));
           IC:=IC+1;
          when 15:
           dn:=CODES(C+2);off:=CODES(C+3);
           read(M(Address(dn,off)));
           IC:=IC+1;
          when 16:
           writeln;
           IC:=IC+1;
          when 17:
           IC:=CODES(C+2);
          when 18:
           dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);
           if M(Address(dn,off))=0
           then
             IC:=C
           else
             IC:=IC+1;
           fi;
          when 19:
           dn:=CODES(C+3); off:=CODES(C+4);   C:=CODES(C+2);
           if M(Address(dn,off))>0
           then
             IC:=C
           else
             IC:=IC+1;
           fi;
          when 20:
           dn:=CODES(C+2); off:=CODES(C+3);
           IC:=IC+1;
           call Disp(Address(dn,off));
          when 21:
           dn1:=CODES(C+2); off1:=CODES(C+3);
           dn2:=CODES(C+4); off2:=CODES(C+5);
           IC:=IC+1;
           call Refmove(Address(dn1,off1),Address(dn2,off2));
          when 22:
           dn:=CODES(C+2);  off:=CODES(C+3);
           M(Address(dn,off)):=0;
           IC:=IC+1;
          when 23:
           dn:=CODES(C+2);  off:=CODES(C+3);
           s:=CODES(C+4);
           k:=Address(dn,off);  M(k):=M(k)+s;
           IC:=IC+1;
          when 24:
           dn1:=CODES(C+2);  off1:=CODES(C+3);
           dn2:=CODES(C+4);  off2:=CODES(C+5);  off:=CODES(C+6);
           k:=Address(dn2,off2);
           k:=Physical(k);  k:=k+off;
           M(Address(dn1,off1)):=M(k);
           IC:=IC+1;
          when 25:
           dn1:=CODES(C+2);  off1:=CODES(C+3);  off:=CODES(C+4);
           dn2:=CODES(C+5);  off2:=CODES(C+6);
           k:=Address(dn1,off1);
           k:=Physical(k);  k:=k+off;
           M(k):= M(Address(dn2,off2));
           IC:=IC+1;
          when 26:
           dn1:=CODES(C+2);  off1:=CODES(C+3);
           dn2:=CODES(C+4);  off2:=CODES(C+5);  off:=CODES(C+6);
           k:=Address(dn2,off2);
           k:=Physical(k);  k:=k+off;
           call Refmove(Address(dn1,off1),k);
           IC:=IC+1;
          when 27:
           dn1:=CODES(C+2);  off1:=CODES(C+3);  off:=CODES(C+4);
           dn2:=CODES(C+5);  off2:=CODES(C+6);
           k:=Address(dn1,off1);
           k:=Physical(k);  k:=k+off;
           call Refmove(k,Address(dn2,off2));
           IC:=IC+1;
          when 28:
           call Endrun;
          when 29:
           dn:=CODES(C+2);  off:=CODES(C+3);
           IC:=IC+1;
           call Attch(Address(dn,off));
          when 30:
           IC:=IC+1;
           call Attch(lastcor);
          when 31:
           dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);
           if not Member(Address(dn,off))
           then
             IC:=C
           else
             IC:=IC+1;
           fi;
          when 32:
           IC:=IC+1;
	   call Endcor;
          when 33:
           dn:=CODES(C+2);  off:=CODES(C+3);  pt:=CODES(C+4);
           call qual(Address(dn,off),PROT(pt));
           IC:=IC+1;
          when 34:
           dn:=CODES(C+2);  off:=CODES(C+3);
           call gkill(Address(dn,off));
	   IC:=IC+1;
          when 35:
           dn:=CODES(C+2);  off:=CODES(C+3);  pt:=CODES(C+4);
           C:=CODES(C+5);
	   if inl(Address(dn,off),PROT(pt))
           then
             IC:=C
           else
             IC:=IC+1;
           fi;
          when 36:
           dn:=CODES(C+2);  off:=CODES(C+3);  pt:=CODES(C+4);
           C:=CODES(C+5);
	   if isl(Address(dn,off),PROT(pt))
           then
             IC:=C
           else
             IC:=IC+1;
           fi;
          when 37:
           dn:=CODES(C+2);  off:=CODES(C+3);  pt:=CODES(C+4);
	   IC:=IC+1;
           call typeref(Address(dn,off),PROT(pt));
          when 38:
           dn:=CODES(C+2);  off:=CODES(C+3);  pt:=CODES(C+4);
	   pt1:=CODES(C+5);
	   k:=CODES(C+10); s:=CODES(C+11);
	   IC:=IC+2;
	   call typed(k,s,Address(dn,off),PROT(pt),PROT(pt1));
          when 40:
	   s:=CODES(C+2);  dn:=CODES(C+3);  off:=CODES(C+4);
           IC:=IC+1;
	   call Raising(s,Address(dn,off));
          when 41:
	   IC:=IC+1;
	   call Termination;
          when 42:
	   IC:=IC+1;
	   call killafter;
          when 43:
	   dn1:=CODES(C+2);  off1:=CODES(C+3);  s:=CODES(C+4);
           dn2:=CODES(C+5);  off2:=CODES(C+6);
           IC:=IC+1;
           call Attchwith(Address(dn1,off1),s,Address(dn2,off2));
          when 44:
	   s:=CODES(C+2);
	   dn1:=CODES(C+3);  off1:=CODES(C+4);
           IC:=IC+1;
           call Attchwith(lastcor,s,Address(dn1,off1));
          when 45:
	   IC:=IC+1;
	   call Attch(virt1);
	  when 46:
	   s:=CODES(C+2);
	   dn1:=CODES(C+3);  off1:=CODES(C+4);
	   IC:=IC+1;
	   call Attchwith(virt1,s,Address(dn1,off1));
        esac;
      od;
  end
end