1 From: MX%"antek@mimuw.edu.pl" 1-MAR-1993 16:29:48.71
\r
6 Date: Mon, 1 Mar 93 15:01:30 GMT
\r
7 From: antek@mimuw.edu.pl
\r
8 To: salwicki@pauvx1.univ-pau.fr
\r
12 A SHORT INTRODUCTION TO THE NEW RUNNING SYSTEM
\r
13 WRITTEN IN LOGLAN-82
\r
21 This short introduction describes the main differences between the Loglan-82
\r
22 and Loglan-84 Running Systems (RS) as well as the user guide for RS program.
\r
23 This program was entierly written in Loglan-82, so it gives a good high level
\r
24 point of view on the chosen algorithms. In future a library of modules written
\r
25 in programming language C will replace that program. It seems that this way we
\r
26 shall obtain a strict, abstract definition of Loglan RS, as well as a perfect
\r
27 mean to produce a professional portable system.
\r
29 The present text may be read only by fellows who know the theory of Loglan RS
\r
30 virtual addressing and Loglan RS Display structure. For the first problem we
\r
31 refer the reader to the paper by G.Cioni, A.Kreczmar "Programmed deallocation
\r
32 without dangling reference" IPL 18(1984) pp.179-187, for the latter one we re-
\r
33 fer the reader to the paper by M.Krause, A.Kreczmar, H.Langmaack, A.Salwicki,
\r
34 M.Warpechowski "Algebraic approach to ...." published in Lecture Notes in Com-
\r
35 puter Science Springer serie number 208, pp. 134-156. In what follows we do
\r
36 not explain the details of these solutions, in the contrary, all the details
\r
37 are just put in our program (we hope the program is self explanatory for our
\r
38 fellows who understand the published solutions).
\r
40 2. Structure of RS.LOG
\r
42 Program RS is written as the sequence of classes. The most outer one is the
\r
43 class defining Loglan prototypes (class PROTOTYPES). Going down we have the
\r
44 following classes: MEMORY (defining the structure of memory management),
\r
45 OBJECTS (defining the basic operations on Loglan objects), COROUTINES (de-
\r
46 fining the operations on coroutines), HANDLING (defining operations on exc-
\r
47 eptions), and finally we have a prefixed block which allows to interpret the
\r
48 tentative intermediate code designed only for testing aims.
\r
50 Class PROTOTYPE defines all prototypes, like in Loglan-82 RS, but it profits
\r
51 from the possibility of building up hierarchies. So, the outermost prototype
\r
52 Prtp has only the common attributes, then we can inherit this class to define
\r
53 prototypes of simple classes and arrays, etc. The full picture of this hie-
\r
54 rarchy is given at the beginning of class PROTOTYPES. What is interesting and
\r
55 new with respect to Loglan-82 RS is that we define system attributes as
\r
56 virtual operations (Sl, Dl, Lsc etc.), so their offsets may be changed later.
\r
57 Pay attention also on attributes "perm" and "perminv" which are necessary
\r
58 to update Display correctly. In the program RS we gave the full algorithm for
\r
59 computing these permutations (procedure Cmptperm) which is not executed in
\r
60 our program. It is written as a comment, however it was tested on large
\r
61 examples. In future this procedure must be executed during a program com-
\r
62 pilation. Everything what is needed to perform this procedure is a program
\r
63 structure with decl and pref functions.
\r
65 The last but not least thing which we must stress in this short introduction
\r
66 is the structure of offsets for reference values. In fact, Loglan-84 differs
\r
67 from Loglan-82 also because of more complicated world of structured types.
\r
68 In fact, we can define in this new version of language a record or array of
\r
69 elements which contain references. This implies that the structure of offsets
\r
70 of references ressembles regular expressions. We can have a list of offsets,
\r
71 a segment of offsets, a list of such expressions and finally a repetition of
\r
72 such an expression. A list of offsets (Listref) is the following stucture:
\r
74 head ---> (i1,next1) ---> ... ---> (in,none)
\r
76 where i1,...,in are offsets of references inside an object.
\r
78 A segment of offsets (Segment) is only a pair (start,finish), and all ele-
\r
79 ments between offsets start and finish are references. A list of structures
\r
80 defining offsets (List) is the following:
\r
82 head ---> (Offset1,next1) ---> ... ---> (Offsetn,none)
\r
84 where Offset is the type of offsets structure. Finally a repetition n times
\r
85 such a structure is defined by class Repeated. It is a pair (ntimes,Offsets)
\r
86 where ntimes defines the number of repetitions and Offsets defines the re-
\r
87 peted structure. Recalling Loglan-84 types we see that Listref is a normal
\r
88 list of offsets in an object, like in Loglan-82, Segment appears when a sta-
\r
89 tic array of references is declared, List appears when a record with selec-
\r
90 tors having references is declared, and finally Repeated appears when a sta-
\r
91 tic array with element having references is declared.
\r
93 The structure of Offsets is read by procedure Takeoffsets, the structure of
\r
94 Prototypes is read by procedure Takeprototype. For the syntax of input look
\r
95 inside these procedures.
\r
99 The new Running System has a new object structure. In fact, it is not diffi-
\r
100 cult to observe that an object may be uniquely defined if we have an access
\r
101 to its prototype. Moreover during the work on Loglan-82 we realized that the
\r
102 structure of object growing only in one direction is cumbersome for many re-
\r
103 asons (formal parameters had to be numbered, auxiliary variables changed the
\r
104 already computed offsets etc.). Thus it would be nicer if object could grow
\r
105 both directions. Such a solution was accepted as an axiom, so objects in new
\r
106 RS are identified by one value placed not necessarily at one of its ends.
\r
108 Prototypes of objects are defined by classes (Prtp). Such a class has two
\r
109 attributes defining object size : lspan , rspan. For adjustable arrays an
\r
110 object size is settled on run time. Thus the first value of such an object
\r
111 defines array prototype while the next two (lower bound & upper bound) fixed
\r
112 on run time define the object size. Because of adjustable arrays virtual
\r
113 function Size, giving an object length, has formal parameter am. This para-
\r
114 meter is not used in the case of normal modules, it is used only in the case
\r
115 of adjustable arrays. Then it points an object address from which we can
\r
116 calculate object size using lower and upper bound.
\r
120 New compactifier is based in the structure of the old one. However we added
\r
121 one important feature, namely automatic garbage collection. This garbage co-
\r
122 llection is based on the known technique which traverses the whole graph of
\r
123 objects accessible from the active one and marks them. The traversing proce-
\r
124 dure starts from marking a visited object. Then using the information about
\r
125 the relocation of references inside the object it goes recursively to visit
\r
128 Garbage collection (act1) is the first phase of compactifying procedure.
\r
129 Then we do the same as in the old compactification process. In act2 we walk
\r
130 through the list of free items on address table. Act3 again analyzes this
\r
131 table however by scanning it entierly and marking non-used addresses. In the
\r
132 act4 the lists of killed objects are traversed and killed objects are marked.
\r
133 In act5 the whole memory is scanned and references to nonexisting objects
\r
134 are set to none (this phase is necessary; originally it was not executed but
\r
135 P.Gburzynski found that error). In act6 the table of indirect addresses is
\r
136 scanned. It computes the future values of indirect addresses and prepares
\r
137 the these addresses to the next phase. It is the most important phase, act7.
\r
138 It scans the whole memory updating all references. Finally the table of ind-
\r
139 irect addresses is squeezed (act8).
\r
143 The system of coroutines differs a little bit from the old one. Dl link is
\r
144 fixed at the moment of coroutine generation as for all the other modules.
\r
145 Every coroutine has additional reference Cl. When return is encountered that
\r
146 reference points coroutine object itself. Each attach, detach updates this
\r
147 reference on the last object belonging to the coroutine chain (coroutine
\r
148 chain is defined as in the old Running System). Termination of a coroutine
\r
149 returns the control via Dl which does not change during a program execution.
\r
150 In order to mark coroutine termination, Cl is set to none. This way any
\r
151 attempt to activate a terminated coroutine will be recognized by Running
\r
152 System. To obtain, as previously, the possibility of nonsymetric coroutine
\r
153 sequencing each process contains a system reference pointing the last atta-
\r
154 ched coroutine. Thus detach makes the control transfer from an active to
\r
155 this pointed coroutine.
\r
159 System of handlers is also a little bit changed. According to Szczepanska's
\r
160 observation it is methodologically improper to perform recursive call of a
\r
161 handler. Thus procedure Raise searches a handler going via Dl, but ommitting
\r
162 handler objects and its Sl fathers. So when a handler is declared in a modu-
\r
163 le neither a handler object nor its dynamic father are taken into considera-
\r
164 tion in searching process.
\r
168 There are some examples of programs written in an intermediate code to test
\r
169 new RS. The full description of an intermediate code is given at the end of
\r
170 RS program (in the last prefixed block). Each example is prepared so that it
\r
171 is possible to understand its sense. We give first the full text of program
\r
172 written in Loglan (with some comments concerning the offsets values), then
\r
173 the system of offsets, the system of prototypes and finally a code is given.
\r
174 The syntax of these input data is precisely described in the corresponding
\r
175 modules. In order to have the possibility of testing our product, some uti-
\r
176 lities were provided. Each code statement possesses as a final data an inf-
\r
177 ormation concerning the output. We can output for each code statement just
\r
178 such a code or a memory dump. If this final value is 1 we print a statement
\r
179 (trace). If this final value is 2 we dump memory. If this final value is
\r
180 greater than 2 we print trace as well as memory dump.
\r
182 The list of examples contain program Pawel (recursive generation of permuta-
\r
183 tions), program Merge (coroutine merging of many BST), program Knapsack (the
\r
184 use of handlers to obtain the solution of simple knapsack problem), and fi-
\r
185 nally program Mergecor which implements the merging process of two Bst but
\r
186 using handlers instead of maximal integer to end a tree.
\r
188 There is a macro called tr.bat which transforms commented examples into a
\r
189 form which can be read by RS.LOG. To do it you simply call tr with a parame-
\r
190 ter denoting an example, for instance:
\r
194 Then you obtain a file code.txt which is ready to be read by RS. In examples
\r
195 we must put sign # at the end of Loglan version, and we must avoid to use
\r
196 later all the signs appearing in numbers ( so digits and -). The given exam-
\r
197 ples keep to this syntax.
\r
199 When RS program starts to be executed, it asks you whether you want to print
\r
200 prototypes, offsets or memory, just at the beginning of a program execution.
\r
201 You can answer 0 or 1 , corresponding to the needed output. After that phase
\r
202 your example will be executed. Good luck.
\r
208 (*****************************************************************************)
\r
211 (* THIS IS LOGLAN-84 RUNNING SYSTEM WRITTEN IN LOGLAN-82 *)
\r
213 (* by Antoni Kreczmar *)
\r
215 (* Institute of Informatics, Warsaw University *)
\r
221 (*****************************************************************************)
\r
234 (*****************************************************************************)
\r
236 (* GLOBAL CONSTANTS *)
\r
238 (*****************************************************************************)
\r
240 const maxint = 32000, (* defines maximal integer *)
\r
241 reflength=2, (* reference value length *)
\r
242 memorylength = 200, (* defines the length of M *)
\r
243 syssigl=100; (* defines system signals bound *)
\r
254 (*****************************************************************************)
\r
256 (* GLOBAL VARIABLES *)
\r
258 (*****************************************************************************)
\r
260 var M : arrayof integer, (* M[0..memorylength-1] is RS memory *)
\r
261 f: file; (* file with datas *)
\r
272 (*****************************************************************************)
\r
274 (* SIGNALS FOR RS ERRORS *)
\r
276 (*****************************************************************************)
\r
278 signal Error(t:string);
\r
291 (*****************************************************************************)
\r
297 (* Prototype defines the skeleton of an object *)
\r
299 (* In this part the structure of prototypes is read. *)
\r
300 (* Levels and Langmaack's permutations may be computed *)
\r
301 (* ( however this will be done at compilation phase ) *)
\r
302 (*****************************************************************************)
\r
307 (*****************************************************************************)
\r
309 (* HIERARCHY OF PROTOTYPES *)
\r
311 (* Prtp any prototype *)
\r
313 (* ------------------------ *)
\r
316 (* Simple class Prtpsimpl Prtparr adjustable array *)
\r
317 (* without Dl,Sl | | *)
\r
321 (* ------------- | *)
\r
323 (* Block Prtpsub | --------------- *)
\r
324 (* subroutine | Handler Prtphand | | *)
\r
325 (* | Prtparnst | *)
\r
326 (* Class Prtplass | | *)
\r
328 (* | | Prtparstr structured *)
\r
329 (* | -------------- elements *)
\r
330 (* Coroutine Prtpcor | | *)
\r
332 (* | | Prtparrf reference *)
\r
334 (* Process Prtpproc Prtparpr primitive *)
\r
336 (*****************************************************************************)
\r
340 unit PROTOTYPES: class;
\r
343 (*****************************************************************)
\r
345 (* Every object is patterned upon its prototype *)
\r
348 (* object = M[am-lspan..am+rspan] where *)
\r
349 (* ----------------- *)
\r
350 (* | M[am-lspan] | = *)
\r
352 (* | . | = } attributes *)
\r
355 (* | M[am-1] | = *)
\r
356 (* | M[am] | = <-- pt - Prototype number *)
\r
357 (* | M[am+1] | = *)
\r
359 (* | . | = } attributes *)
\r
361 (* | M[am+rspan] | = *)
\r
362 (* ----------------- *)
\r
363 (*****************************************************************)
\r
367 var num: integer; (* prototype number - only for identifiction *)
\r
369 (*-------------------------------------------------------------------*)
\r
371 unit virtual Size: function(am:integer) : integer;
\r
373 (* size of the object of this prototype allocated in M[...am...] *)
\r
374 (* formal parameter am appears only because of adjustable arrays *)
\r
378 (*-------------------------------------------------------------------*)
\r
381 unit virtual Ptposition: function: integer;
\r
383 (* position of pt in an object with respect to its beginning *)
\r
387 (*------------------------------------------------------------------*)
\r
391 (*---------------------------------------------------------------------*)
\r
393 unit Prtpsimpl : Prtp class;
\r
395 (* prototype of a simple class, i.e. without Lsc, Dl and Sl *)
\r
397 var lspan,rspan: integer,
\r
398 references: Offsets; (* structure of references in object *)
\r
399 (* cf. declaration of Offsets *)
\r
401 (*------------------------------------------------------------------*)
\r
403 unit virtual Size: function(am:integer) : integer;
\r
406 result:=lspan+rspan+1;
\r
409 (*-------------------------------------------------------------------*)
\r
411 unit virtual Ptposition: function: integer;
\r
420 (*-------------------------------------------------------------------*)
\r
422 (* Prtpmod is a prototype of any module. It has static attributes *)
\r
423 (* like decl,pref and its objects have Dl, Sl, Statsl and Lsc *)
\r
424 (* Blocks and subroutines belong exactley to this class, while *)
\r
425 (* classes (coroutines,processes) are elements of Prtpmod subclass *)
\r
428 (*****************************************************************)
\r
430 (* ----------------- *)
\r
431 (* | M[am-lspan] | = *)
\r
433 (* | . | = } attributes *)
\r
436 (* | M[am-1] | = *)
\r
437 (* | M[am] | = <-- pt - Prototype number *)
\r
439 (* | M[am+1] | = } attributes *)
\r
441 (* | . | = Lsc local sequence control *)
\r
442 (* | . | = Statsl number of synt. sons *)
\r
443 (* | . | = Dl dynamic link *)
\r
444 (* | M[am+rspan] | = Sl static link *)
\r
445 (* ----------------- *)
\r
446 (*****************************************************************)
\r
449 (* Offsets of system attributes are defined by virtual functions *)
\r
450 (* they may be changed later on; here system attributes are *)
\r
451 (* allocated at the right end of an object *)
\r
454 const Sloffset=1-reflength, (* roffset of Sl *)
\r
455 Dloffset=Sloffset-reflength, (* roffset of Dl *)
\r
456 Statoffset=Dloffset-1, (* roffset of Statsl *)
\r
457 Lscoffset=Statoffset-1; (* roffset of Lsc *)
\r
459 unit Prtpmod : Prtpsimpl class;
\r
463 var declto, prefto: Prtpmod, (* decl and pref links *)
\r
464 level: integer, (* level of node in decl tree *)
\r
465 codeadd: integer, (* address of first statement *)
\r
466 lstwill: integer, (* address of lastwill *)
\r
467 perm: arrayof integer, (* Langmaack's permutation *)
\r
468 perminv: arrayof integer; (* inverse of perm *)
\r
470 unit virtual Sl : function(am : integer):integer;
\r
472 result:=am+rspan+Sloffset
\r
475 unit virtual Dl : function(am : integer) : integer;
\r
477 result:=am+rspan+Dloffset
\r
480 unit virtual Statsl : function(am : integer) : integer;
\r
482 result:=am+rspan+Statoffset
\r
485 unit virtual Lsc: function(am : integer) : integer;
\r
487 result:=am+rspan+Lscoffset
\r
492 (*--------------------------------------------------------------------*)
\r
494 unit Prtpsub : Prtpmod class;
\r
496 (* Prtpsub is a prototype of block, procedure or function *)
\r
498 var pslength: integer, (* prefix sequence length *)
\r
499 handlist: hlstelem; (* list of handlers,see down *)
\r
503 (*--------------------------------------------------------------------*)
\r
504 unit Prtpclass : Prtpsub class;
\r
506 (* Prtpclass is a prototype of class *)
\r
510 (*--------------------------------------------------------------------*)
\r
512 unit Prtpcor : Prtpclass class;
\r
514 (* Prtpcor is a prototype of coroutine *)
\r
518 (*--------------------------------------------------------------------*)
\r
520 unit Prtphand: Prtpmod class;
\r
522 (* Prtphand is a prototype of handler *)
\r
523 var oth: boolean; (* for others oth=true *)
\r
527 (*--------------------------------------------------------------------*)
\r
530 unit Prtpproc: Prtpcor class;
\r
532 var displ: integer, (* offset of DISPLAY[1] in object *)
\r
533 curr: integer, (* offset of current in object *)
\r
534 lstcr: integer, (* offset of lastcor in object *)
\r
535 chead: integer; (* offset of corhead in object *)
\r
537 (* DISPLAY, current,lastcor and corhead must be in Offsets *)
\r
538 (* lastcor and corhead are used in class COROUTINES *)
\r
541 (*--------------------------------------------------------------------*)
\r
543 (*********************************************************)
\r
544 (* adjustable array object has the form *)
\r
546 (* M[am+1]= lower bound *)
\r
547 (* M[am+2]= upper bound *)
\r
549 (* M[am+4] = } elements *)
\r
552 (*********************************************************)
\r
554 const lboffset= 1, (* offset of lower bound *)
\r
555 uboffset= 2, (* offset of upper bound *)
\r
556 elmoffset=3; (* offset of first element *)
\r
558 (*--------------------------------------------------------------------*)
\r
559 unit Prtparr: Prtp class;
\r
562 unit virtual Size: function(am:integer) : integer;
\r
566 (*-------------------------------------------------------------------*)
\r
568 unit virtual Ptposition: function: integer;
\r
575 (*---------------------------------------------------------------------*)
\r
577 unit Prtparnst: Prtparr class;
\r
578 (* adjustable array of non-structured elements *)
\r
580 var elsize:integer; (* element size *)
\r
582 unit virtual Size: function(am:integer): integer;
\r
584 result:=(M(am+uboffset)-M(am+lboffset)+1)*elsize+3;
\r
588 (*---------------------------------------------------------------------*)
\r
590 unit Prtparpr: Prtparnst class;
\r
591 (* adjustable array of primitive elements, elsize is read *)
\r
594 (*---------------------------------------------------------------------*)
\r
596 unit Prtparrf:Prtparnst class;
\r
597 (* adjustable array of references *)
\r
600 elsize:=reflength; (* define element size *)
\r
603 (*---------------------------------------------------------------------*)
\r
605 unit Prtparstr:Prtparr class;
\r
606 (* array of structured elements *)
\r
607 var references:Offsets;
\r
609 unit virtual Size: function(am:integer): integer;
\r
611 result:=(M(am+uboffset)-M(am+lboffset)+1)*references.size+3;
\r
618 (*---------------------------------------------------------------------*)
\r
619 var maxlevel: integer; (* length of Display *)
\r
622 (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
\r
624 (* END OF SPECIFICATION PART *)
\r
626 (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*)
\r
633 (*------------------------------------------------------------------*)
\r
635 (* STRUCTURES FOR *)
\r
639 (*------------------------------------------------------------------*)
\r
642 (*------------------------------------------------------------------*)
\r
644 (* Each module can have the list of handlers. This list is the list *)
\r
645 (* of lists i.e. for each handler we have the list of joint signal *)
\r
646 (* numbers. So, the main list has as elements the triples: *)
\r
647 (* (handler prototype,signal list,next list element) *)
\r
648 (* The corresponding signal list has as elements the pairs: *)
\r
649 (* (signal number,next list element) *)
\r
650 (* If else part appears, then all visible signals in a module are *)
\r
651 (* on the list joint with such a handler and its oth=true. *)
\r
652 (* System signals have signal number <= syssigl. For these signals *)
\r
653 (* return in a handler is not allowed. They not appear on the list *)
\r
654 (* of signals for handler for others. *)
\r
656 (*------------------------------------------------------------------*)
\r
659 (*------------------------------------------------------------------*)
\r
661 (* System signals numbers *)
\r
663 (*------------------------------------------------------------------*)
\r
667 reftonone = 1, (* reference to none *)
\r
668 memover = 2, (* memory overflow *)
\r
669 incorqua = 3, (* incorrect qua *)
\r
670 incorassg = 4, (* incorrect assignment *)
\r
671 ilattach = 5, (* illegal attach *)
\r
672 corterm = 6, (* coroutine terminated *)
\r
673 handnfond = 7, (* handler not found *)
\r
674 imprterm = 8, (* improper terminate *)
\r
675 incorkill = 9, (* incorrect kill *)
\r
676 arrayind = 10; (* array index error *)
\r
680 unit hlstelem: class;
\r
681 var hand: integer, (* prototype number of handler *)
\r
682 signlist: sglelem, (* signal list *)
\r
683 next: hlstelem; (* next list element *)
\r
686 unit sglelem: class;
\r
687 var signalnum: integer, (* signal number *)
\r
688 next: sglelem; (* next list element *)
\r
699 (*------------------------------------------------------------------*)
\r
701 (* STRUCTURES FOR *)
\r
703 (* OFFSETS OF REFERENCES *)
\r
705 (*------------------------------------------------------------------*)
\r
708 (*------------------------------------------------------------------*)
\r
711 (* auxiliary classes for defining lists of offsets *)
\r
713 unit Elem:class(offset:integer,next:Elem);
\r
716 unit Elemex:Elem class;
\r
717 var references :Offsets;
\r
720 (*----------------------------------------------------------------*)
\r
722 unit Offsets: class;
\r
723 (* any substructure defining references *)
\r
725 var size: integer, (* defines the size of considered *)
\r
726 (* memory subframe *)
\r
727 num: integer; (* offsets number - only to write *)
\r
730 (*----------------------------------------------------------------*)
\r
734 unit Listref: Offsets class;
\r
735 (* each list element is an offset of a reference *)
\r
741 (*-----------------------------------------------------------------*)
\r
743 unit Segment: Offsets class;
\r
744 (* contiguous segment of memory *)
\r
746 var start,finish: integer;
\r
749 (*---------------------------------------------------------------*)
\r
751 unit Repeated : Offsets class;
\r
752 (* repetition n times *)
\r
754 var ntimes: integer,
\r
755 references: Offsets;
\r
758 (*-----------------------------------------------------------------*)
\r
760 unit List: Offsets class;
\r
761 (* each list element is an offset of substructure *)
\r
768 (*--------------------------------------------------------------------*)
\r
770 var STRUC :arrayof Offsets; (* array for offsets structures *)
\r
773 (*---------------------------------------------------------------------*)
\r
778 (*---------------------------------------------------------------------*)
\r
780 var PROT: arrayof Prtp,
\r
785 (* PROT[1..n] is defined by the compiler *)
\r
786 (* RS reads it from file CODE.TXT by Takeprot procedure *)
\r
789 (*---------------------------------------------------------------------*)
\r
791 unit Takeoffsets : procedure;
\r
793 (* reads offsets to STRUC from CODE.TXT file *)
\r
795 (* Input format: *)
\r
796 (* n - number of offsets *)
\r
797 (* { offsetnumber size *)
\r
798 (* kind (1,2,3,4) *)
\r
799 (* =(Listref,Segment,Repeated,List) *)
\r
800 (* if kind=1 then *)
\r
801 (* n,offset1,offset2,...,offsetn *)
\r
802 (* if kind=2 then *)
\r
804 (* if kind=3 then *)
\r
805 (* ntimes offsetnumber *)
\r
806 (* if kind=4 then *)
\r
807 (* n,offset1,offset2,...,offsetn *)
\r
808 (* offsets of substructures }+ *)
\r
811 (* must be called before Takeprot *)
\r
814 var n,m,i,j,k,t,p: integer,
\r
822 open(f,text,unpack("CODE.TXT"));
\r
825 if n<1 then raise SS fi;
\r
826 array STRUC dim (1:n);
\r
829 read(f,t); (* offsets number *)
\r
832 raise Error("Incorrect prototype");
\r
834 read(f,k); (* read size *)
\r
835 read(f,j); (* read kind *)
\r
837 when 1: (* Listref *)
\r
839 read(f,m); (* m = length *)
\r
842 read(f,p); (* p=offset *)
\r
843 Lr.head:=new Elem(p,Lr.head);
\r
847 when 2: (* Segment *)
\r
849 read(f,m); read(f,p);
\r
850 S.start:=m; S.finish:=p;
\r
852 when 3: (* Repeated *)
\r
854 read(f,m); read(f,p);
\r
855 R.ntimes:=m; R.references:=STRUC(p);
\r
859 read(f,m); (* m = length *)
\r
862 read(f,p); (* p=offset *)
\r
863 L.head:=new Elemex(p,L.head);
\r
865 L.head.references:=STRUC(p);
\r
870 raise Error(" Incorrect prototype kind");
\r
872 ref.num:=i; ref.size:=k;
\r
878 (*---------------------------------------------------------------------*)
\r
881 unit Takeprot : procedure;
\r
883 (* reads PROT structure from CODE.TXT file *)
\r
885 (* Input format: *)
\r
886 (* n - number of prototypes *)
\r
887 (* { prototypenumber *)
\r
888 (* kind = (1,2,3,4,5,6,7,8,9) *)
\r
889 (* (for kind = 1 simple class like record) *)
\r
890 (* lspan rspan offestsnum *)
\r
891 (* (for kind = 2,9 class,block,subprogram) *)
\r
892 (* (2 is for block, subprogram, 9 for class) *)
\r
893 (* lspan rspan offsetsnum decl pref codeadd *)
\r
894 (* level pslength *)
\r
895 (* perm[1..level] perminv[1..level] *)
\r
897 (* { handlerprot, { signalnumber}+,0 }+,0 *)
\r
898 (* (for kind = 3 process-main block additionally) *)
\r
899 (* displ curr lstcr chead *)
\r
900 (* (for kind = 4 adjustable primitive array ) *)
\r
902 (* (for kind = 5 adjustable structured array) *)
\r
904 (* (for kind = 6 adjustable reference array) *)
\r
906 (* (for kind = 7 coroutine, no additional datas) *)
\r
907 (* (for kind = 8 handler like in kind 2 but *)
\r
908 (* instead of pslength oth =0,1 is given *)
\r
912 var i,j,k,l: integer,
\r
927 if n<1 then raise SS fi;
\r
928 array PROT dim (1:n);
\r
934 raise Error("Incorrect prototype");
\r
936 read(f,j); (* read kind *)
\r
938 when 1: (* simple class *)
\r
939 a:=new Prtpsimpl; t:=a;
\r
940 read(f,l); t.lspan:=l; (* read lspan *)
\r
941 read(f,l); t.rspan:=l; (* read rspan *)
\r
942 read(f,l); (* read offsetnum *)
\r
943 if l=/=0 then t.references:=STRUC(l); fi;
\r
944 when 2,3,7,8,9: (* module *)
\r
947 a:=new Prtpsub; b:=a; c:=a;
\r
949 a:=new Prtpproc; b:=a; c:=a; r:=a;
\r
951 a:=new Prtpcor; b:=a; c:=a;
\r
953 a:=new Prtphand; b:=a; h:=a;
\r
955 a:=new Prtpclass; b:=a; c:=a;
\r
957 read(f,l); b.lspan:=l;
\r
958 read(f,l); b.rspan:=l;
\r
959 read(f,l); (* read offsetnum *)
\r
960 if l=/=0 then b.references:=STRUC(l); fi;
\r
962 if l=/=0 then b.declto:=PROT(l); fi; (* set decl *)
\r
964 if l=/=0 then b.prefto:=PROT(l); fi; (* set prefto *)
\r
965 read(f,l); b.codeadd:=l; (* read codeadd. *)
\r
966 read(f,l); b.level:=l; (* read level *)
\r
969 read(f,l); c.pslength:=l; (* read pslength *)
\r
971 array b.perm dim(1:b.level);
\r
972 array b.perminv dim(1:b.level);
\r
973 for k:=1 to b.level do read(f,b.perm(k)) od;
\r
974 for k:=1 to b.level do read(f,b.perminv(k)) od;
\r
975 read(f,l); b.lstwill:=l; (* read lstwill *)
\r
981 if l=0 then exit fi; (* end of list *)
\r
982 p:=new hlstelem; (* generate element *)
\r
984 p.next:=c.handlist; c.handlist:=p;
\r
985 read(f,k); (* read signalnum *)
\r
987 p.signlist:=q; q.signalnum:=k;
\r
990 if k=0 then exit fi; (* end of list *)
\r
991 q:=new sglelem; q.signalnum:=k;
\r
992 q.next:=p.signlist; p.signlist:=q;
\r
997 read(f,l); r.displ:=l;
\r
998 read(f,l); r.curr:=l;
\r
999 read(f,l); r.lstcr:=l;
\r
1000 read(f,l); r.chead:=l;
\r
1004 if l=0 then h.oth:=false else h.oth:=true fi;
\r
1006 when 4: (* prim.adjus.arr.*)
\r
1007 a:=new Prtparpr; d:=a;
\r
1009 d.elsize:=l; (* read elem.size *)
\r
1010 when 5: (* str.adjus.arr. *)
\r
1011 a:=new Prtparstr; e:=a;
\r
1013 e.references:=STRUC(l); (* set offsets *)
\r
1014 when 6: (* ref.adj.array *)
\r
1017 raise Error(" Incorrect prototype kind");
\r
1025 (*---------------------------------------------------------------------*)
\r
1027 (* Cmptperm computes perm and perminv for all PROT[i] *)
\r
1028 (* see LNCS 208, pp.134*156 *)
\r
1030 unit Cmptperm: procedure;
\r
1033 var i,j,k,l,m,s,t: integer,
\r
1035 perm,perminv,perm1,perminv1: arrayof integer;
\r
1038 unit Cmptcmpl: function (a:Prtpmod) :Prtpmod;
\r
1041 var b,c,e: Prtpmod;
\r
1045 result:=a.declto; b:=a.prefto; c:=b.declto;
\r
1049 if e=c then return fi;
\r
1050 if e=none then exit fi;
\r
1053 result:=result.declto;
\r
1060 array perm dim (1:1); perm(1):=1;
\r
1061 array perminv dim(1:1); perminv(1):=1;
\r
1062 PROT(1) qua Prtpmod.perm:=perm;
\r
1063 PROT(1) qua Prtpmod.perminv:=perminv;
\r
1067 if not PROT(m) in Prtpmod
\r
1075 perm1:=b.perm; perminv1:=b.perminv;
\r
1076 l:=b.level; k:=a.level;
\r
1077 array perm dim(1:k); array perminv dim(1:k);
\r
1080 perm(i):=perm1(i); perminv(i):=perminv1(i)
\r
1082 perm(k):=k; perminv(k):=k;
\r
1084 b:=a.prefto; perm1:=b.perm;
\r
1085 l:=b.level; k:=a.level;
\r
1086 array perm dim(1:k); array perminv dim(1:k);
\r
1087 perm(k):=perm1(l); perminv(perm1(l)):=k;
\r
1090 j:=c.level; i:=l-1;
\r
1092 perm(j):=perm1(i); perminv(perm1(i)):=j;
\r
1093 if i=1 then exit fi;
\r
1095 j:=c.perminv(d.perm(i));
\r
1107 j:=j+1; perm(i):=j;
\r
1112 a.perm:=perm; a.perminv:=perminv;
\r
1121 (*---------------------------------------------------------------------*)
\r
1123 unit Protwrite :procedure;
\r
1128 var i,j,k: integer,
\r
1146 writeln(" PROTOTYPE STRUCTURE ");
\r
1148 write("Nr Offsets Lspan Rspan Decl Pref Code Level Pslength");
\r
1149 writeln(" Lstwill Kind");
\r
1153 write(i:2); write(" ");
\r
1157 if b.references =/=none
\r
1159 write(b.references.num:3);
\r
1163 write(" ",b.lspan:4," ",b.rspan:4," ");
\r
1169 if b=/=none then write(b.num:2) else write(" ") fi;
\r
1171 if c=/=none then write(c.num:2) else write(" ") fi;
\r
1173 write(d.codeadd:4," ");
\r
1174 write(d.level:4);write(" ");
\r
1177 write(d qua Prtpsub.pslength:4);
\r
1178 write(d qua Prtpsub.lstwill:4);
\r
1179 if a is Prtpsub then write(" subroutine");
\r
1181 if a is Prtpclass then write(" class")
\r
1183 if a is Prtpcor then write(" coroutine");
\r
1184 else write(" process");
\r
1189 write(" ",d qua Prtphand.lstwill:4);
\r
1190 if a qua Prtphand.oth
\r
1196 write(" handler");
\r
1204 e:=a; write(e.elsize:3);
\r
1208 f:=a; write(f.references.num:3);
\r
1216 writeln; writeln; writeln(" HANDLERS");
\r
1217 writeln; writeln; writeln(" handler signals ");
\r
1224 g:=a; p:=g.handlist;
\r
1226 if p=none then exit fi;
\r
1230 if q=none then exit fi;
\r
1231 write(q.signalnum); q:=q.next;
\r
1239 write(" MAXIMAL LEVEL="); writeln(maxlevel);
\r
1241 writeln(" OFFSETS");
\r
1242 for i:=1 to upper(STRUC)
\r
1245 write(i:2); write(" size=",STRUC(i).size);
\r
1246 if STRUC(i)=none then repeat fi;
\r
1247 if STRUC(i) is Listref
\r
1249 write(" Listref=");
\r
1250 Lr:=STRUC(i); working:=Lr.head;
\r
1251 for j:=1 to Lr.length
\r
1253 write(working.offset);
\r
1254 working:=working.next;
\r
1258 if STRUC(i) is Segment
\r
1260 write(" Segment=");
\r
1261 S:=STRUC(i); write(S.start,S.finish);
\r
1264 if STRUC(i) is Repeated
\r
1266 write(" Repeated=");
\r
1267 R:=STRUC(i); write(R.ntimes,R.references.num);
\r
1270 if STRUC(i) is List
\r
1273 L:=STRUC(i); workinge:=L.head;
\r
1274 for j:=1 to L.length
\r
1276 write(workinge.offset);
\r
1277 write(workinge.references.num);
\r
1278 workinge:=workinge.next;
\r
1283 if PROT=none then return fi;
\r
1284 if PROT(1) qua Prtpclass.perm=none then return fi;
\r
1286 writeln(" PERMUTATIONS ");
\r
1288 writeln("Prot Perm Perminv");
\r
1291 a:=PROT(i); write(i:2); write(" ");
\r
1295 for j:=1 to maxlevel
\r
1299 write(d.perm(j):2); write(' ');
\r
1305 for j:=1 to maxlevel
\r
1309 write(d.perminv(j):2); write(' ');
\r
1321 (*---------------------------------------------------------------------*)
\r
1323 unit virtual Raising : procedure (signum,X: integer);
\r
1324 (* virtual procedure defining raise statement *)
\r
1325 (* used in memory management and other systems *)
\r
1329 (*---------------------------------------------------------------------*)
\r
1332 when SS: writeln(" Incorrect prototype structure ");
\r
1337 (*--------------------------------------------------------------------*)
\r
1339 (* PROTOTYPES body *)
\r
1343 (* call Cmptperm; *)
\r
1359 (*****************************************************************************)
\r
1361 (* MEMORY AND ADDRESSING *)
\r
1363 (* inherits PROTOTYPES *)
\r
1365 (* For structure of addressing see IPL 18(1984) pp.179-187 *)
\r
1367 (* Every address in this solution is a pair <ah,counter> *)
\r
1368 (* where ah points to M[lastitem..upr] and counter is *)
\r
1369 (* an integer treated as a guard. *)
\r
1371 (* Operations Member,Physical,Request and Disp are *)
\r
1372 (* virtual, so this solution can be eventually exchanged *)
\r
1374 (*****************************************************************************)
\r
1376 unit MEMORY: PROTOTYPES class;
\r
1378 var current : integer; (* reference to the current object *)
\r
1379 (* allocated in main block *)
\r
1381 const minsize=2, (* defines minimal object size *)
\r
1382 upr = memorylength-1, (* M[lwr+1..upr] is memory for *)
\r
1383 (* objects and virtual addresses *)
\r
1385 (* Now some auxiliary RS references are allocated *)
\r
1387 virt1 = reflength, (* address of main program *)
\r
1388 virt2 = virt1+reflength, (* address of recently open object *)
\r
1389 virt3 = virt2+reflength, (* address of auxiliary reference *)
\r
1390 virt4 = virt3+reflength, (* address of auxiliary reference *)
\r
1391 virtn = virt4, (* address of last auxiliary ref. *)
\r
1392 lwr = virtn+reflength; (* M[lwr]=sentinel for killed list *)
\r
1393 (* lwr+1 first normal memory word *)
\r
1394 (*-----------------------------------------------------------------------*)
\r
1396 unit virtual Physical:function (X:integer): integer;
\r
1398 (* computes effective address for a given reference at M[X] *)
\r
1405 call Raising(reftonone,virt2); (* reference to none *)
\r
1410 (*----------------------------------------------------------------------*)
\r
1412 unit virtual Member: function (X: integer):boolean;
\r
1414 (* test for none , X points a reference at M[X] *)
\r
1417 result := M(X+1)=M(M(X)+1)
\r
1420 (*----------------------------------------------------------------------*)
\r
1423 unit virtual Request: procedure (pt,length,X:integer);
\r
1425 (* takes a new frame for object of type defined by pt *)
\r
1426 (* parameter length is necessary because of arrays *)
\r
1427 (* reference to a frame is returned at address M[X] *)
\r
1429 var t1,t2,t3,t4,t5: integer,
\r
1432 wascomp, found: boolean;
\r
1435 if length >= maxapp
\r
1437 raise Error (" memory overflow");
\r
1439 if length <= minsize
\r
1444 (* take new dictionary item *)
\r
1447 ah:=freeitem; freeitem:=M(ah)
\r
1449 ah:=lastitem-reflength;
\r
1452 call Compactify; wascomp:=true;
\r
1453 ah:=lastitem-reflength;
\r
1456 raise Error (" memory overflow");
\r
1459 lastitem:=ah; M(ah+1):=0
\r
1461 (* take new frame *)
\r
1462 t1:=lastused+length;
\r
1463 if t1<lastused orif t1>=lastitem
\r
1465 if length=2 and headk2=/=0
\r
1467 am:=headk2; headk2:=M(am+shortlink);
\r
1469 t1:=headk; found:=false;
\r
1471 while t1=/=lwr and not found
\r
1482 t4:=t1; t1:=M(t1+longlink);
\r
1488 if wascomp then raise Error (" memory overflow"); fi;
\r
1489 M(ah):=freeitem; freeitem:=ah; (* release ah *)
\r
1490 call Compactify; ah:=lastitem-2;
\r
1491 lastitem:=ah; M(ah+1):=0;
\r
1492 t1:=lastused+length;
\r
1493 if t1<lastused orif t1>=lastitem
\r
1495 raise Error (" memory overflow");
\r
1497 am:=lastused+1; lastused:=t1;
\r
1499 t5:=M(t1+shortlink); am:=t1;
\r
1502 M(t5+longlink):=M(t1+longlink)
\r
1504 t5:=M(t1+longlink);
\r
1506 if t4=0 then headk:=t5 else M(t4+longlink):=t5 fi;
\r
1509 t5:=t1+length; M(t5):=t2-length;
\r
1515 am:=lastused+1; lastused:=t1
\r
1517 (* clear object *)
\r
1518 for t2:=am to am+length-1 do M(t2):=0 od;
\r
1519 (* set reference *)
\r
1520 M(X):=ah; M(X+1):=M(ah+1);
\r
1521 a:=PROT(pt); am:=am+a.Ptposition;
\r
1522 M(am):=pt; M(ah):=am;
\r
1525 (*----------------------------------------------------------------------*)
\r
1527 unit virtual Disp: procedure (X:integer);
\r
1529 (* simple kill of object referenced at M[X] *)
\r
1531 var counter: integer,
\r
1538 if not Member(X) then return fi;
\r
1539 ah:=M(X); am:=M(ah); (* compute ah and am *)
\r
1541 counter:=counter+1; (* advance guard counter *)
\r
1543 if counter=/=maxcounter (* if counter not exhausted *)
\r
1545 M(ah):=freeitem; freeitem:=ah (* release virtual address *)
\r
1547 a:=PROT(M(am)); (* a is a prototype of object *)
\r
1548 if am+a.Size(am)-a.Ptposition-1 = lastused
\r
1549 then (* bordering free space *)
\r
1550 lastused:=lastused-a.Size(am) (* am because of arrays *)
\r
1552 length:=a.Size(am); (* length is object size *)
\r
1553 am:=am-a.Ptposition; (* change am to the beginning *)
\r
1561 (*----------------------------------------------------------------------*)
\r
1563 unit virtual Refmove : procedure(X,Y:integer);
\r
1565 (* this procedure is used for moving references *)
\r
1567 M(X):=M(Y); M(X+1):=M(Y+1);
\r
1570 (*---------------------------------------------------------------------*)
\r
1572 unit virtual Setnone : procedure(X:integer);
\r
1574 (* this procedure is used for setting to none *)
\r
1576 M(X):=0; M(X+1):=0;
\r
1579 (*--------------------------------------------------------------------*)
\r
1581 unit virtual Notequal: function(X,Y:integer): boolean;
\r
1583 (* this procedure tests whether references are not equal *)
\r
1590 result:=Physical(X)=/=Physical(Y)
\r
1599 (*--------------------------------------------------------------------*)
\r
1601 unit virtual Equal: function(X,Y:integer): boolean;
\r
1603 (* this procedure tests whether references are equal *)
\r
1606 result:=not Notequal(X,Y)
\r
1610 (*######################################################################*)
\r
1612 (* END OF SPECIFICATION PART *)
\r
1614 (*######################################################################*)
\r
1618 const maxapp = maxint, (* maximal appetite *)
\r
1619 shortlink = 1, (* pointer to next killed of equal size *)
\r
1620 longlink = 2, (* pointer to next killed of greater size *)
\r
1621 maxcounter = maxint; (* maximal counter value *)
\r
1624 freeitem: integer, (* address of first free ah *)
\r
1625 headk: integer, (* address of first killed *)
\r
1626 headk2: integer, (* address of first killed length 2 *)
\r
1627 lastused: integer, (* M[lastused..maxint] for objects *)
\r
1628 lastitem: integer; (* M[1..lastitem] for virtual addresses *)
\r
1632 (*-----------------------------------------------------------------------*)
\r
1633 unit Sinsert :procedure (am:integer);
\r
1635 (* dispose of a memory piece from M[am] to M[am+app-1] *)
\r
1636 (* where app = M[am] *)
\r
1638 var t1,t2,t3,t4: integer;
\r
1644 M(am+shortlink):=headk2; headk2:=am
\r
1651 M(am+shortlink):=M(t2+shortlink);
\r
1652 M(t2+shortlink):=am
\r
1656 M(am+longlink):=t2; t1:=t3;
\r
1657 M(am+shortlink):=0;
\r
1658 if t4=0 then headk:=am else M(t4+longlink):=am fi;
\r
1660 t4:=t2; t2:=M(t2+longlink)
\r
1663 if t1=t3 then exit fi;
\r
1670 (*----------------------------------------------------------------------*)
\r
1672 unit Compactify : procedure ;
\r
1674 (*-----------------------------------------------------------------*)
\r
1675 (* Compactify squeezes the memory of objects and virtual addresses *)
\r
1676 (* collecting first garbage *)
\r
1678 (* - a play in nine acts - *)
\r
1680 (*-----------------------------------------------------------------*)
\r
1683 const skilled = -1; (* dummy prototype for killed objects *)
\r
1684 var nlength: integer; (* variable for keeping free space length *)
\r
1686 (*----------------------------------------------------------------*)
\r
1687 unit nonefy :procedure (am:integer);
\r
1688 (* one of the actions for Traverse, converts none to <0,0> *)
\r
1690 if M(am+1) =/= M(M(am)+1)
\r
1692 M(am):=0; M(am+1):=0
\r
1696 (*----------------------------------------------------------------*)
\r
1698 unit relocate: procedure(am:integer);
\r
1700 (* one of the actions for Traverse, updates virtual address *)
\r
1701 (* for none=<0,0> a proper updating requires M[1]=0 *)
\r
1703 M(am):=M(M(am)+1); M(am+1):=0;
\r
1708 (*---------------------------------------------------------------------*)
\r
1710 unit Traverse :procedure(am:integer; procedure action(i:integer));
\r
1712 (* this procedure is used for compactification of memory and it *)
\r
1713 (* traverses all references in an object pointed by am and *)
\r
1714 (* performs action(i) on each of them *)
\r
1717 (*---------------------------------------------------------------*)
\r
1719 unit Pointed : procedure (acron:integer,references:Offsets);
\r
1721 (* this recursive procedure performs action(i) on references *)
\r
1722 (* defined by the compiler and encoded in the structure Offsets *)
\r
1723 (* in a subframe starting from acron *)
\r
1735 if references=none then return fi; (* no references *)
\r
1736 if references is Listref
\r
1739 working:=Lr.head; (* initialize list scan *)
\r
1740 for i:=1 to Lr.length
\r
1742 k:=working.offset;
\r
1743 call action(acron+k);
\r
1744 working:=working.next;
\r
1748 if references is Segment
\r
1751 for i:=S.start step reflength to S.finish
\r
1752 do (* for a reference value *)
\r
1753 call action(acron+i)
\r
1757 if references is Repeated
\r
1761 for i:=1 to R.ntimes
\r
1763 call Pointed(k,R.references);
\r
1768 if references is List
\r
1771 workinge:=L.head; (* initialize list scan *)
\r
1772 for i:=1 to L.length
\r
1774 k:=workinge.offset;
\r
1775 ref:=workinge.references;
\r
1776 call Pointed(acron+k,ref);
\r
1777 workinge:=workinge.next;
\r
1784 (*---------------------------------------------------------------*)
\r
1787 references: Offsets,
\r
1791 (* body of Traverse *)
\r
1794 if pt<0 then pt:=-pt fi; (* if object marked pt<0 *)
\r
1795 a:=PROT(pt); (* a is object prototype *)
\r
1798 references:=a qua Prtpsimpl.references;
\r
1799 call Pointed(am,references);
\r
1802 call action(a qua Prtpmod.Dl(am));
\r
1803 call action(a qua Prtpmod.Sl(am));
\r
1805 else (* adjustable array *)
\r
1806 if a is Prtparpr (* primitive elements *)
\r
1808 return; (* do nothing *)
\r
1810 if a is Prtparrf (* reference elements *)
\r
1811 then (* for array elements *)
\r
1812 for i:=am+elmoffset step reflength to am+a.Size(am)-1
\r
1814 call action(i); (* do action *)
\r
1816 else (* for structured *)
\r
1817 references:=a qua Prtparstr.references;
\r
1818 call Pointed(am+elmoffset,references);
\r
1824 (*-------------------------------------------------------------------*)
\r
1825 unit act1: procedure;
\r
1827 (* garbage collection is performed in the following way : *)
\r
1828 (* all objects reachable from the current one are visited and *)
\r
1829 (* marked; the way of marking uses M[am]=pt and changes it to *)
\r
1830 (* the negative value M[am]=-pt; when dictionary of virtual *)
\r
1831 (* addresses is scaned in act4, then non-marked objects are *)
\r
1832 (* killed and marked objects are corrected, i.e. M[am]:=pt *)
\r
1834 (*---------------------------------------------------------------*)
\r
1835 unit mark: procedure (i:integer);
\r
1837 (* procedure analyzes reference <M[i],M[i+1]>; if it denotes *)
\r
1838 (* an alive object, then for such an object marking is done *)
\r
1839 (* and for all which are pointed from it *)
\r
1845 if M(am)>0 (* object not yet marked *)
\r
1847 M(am):=-M(am); (* mark this object *)
\r
1848 call Traverse(am,mark); (* mark reachable from am *)
\r
1853 (*---------------------------------------------------------------*)
\r
1857 am:=Physical(current);
\r
1858 M(am):=-M(am); (* mark current object *)
\r
1859 call Traverse(am,mark); (* visit all reachable *)
\r
1862 (*-----------------------------------------------------------------*)
\r
1863 unit act2: procedure;
\r
1865 (* scans freeitem list and puts counter = maxcounter so that *)
\r
1866 (* each unusable entry M[ah],M[ah+1] has the form x,maxcounter *)
\r
1875 M(t1+1):=maxcounter; t1:=M(t1)
\r
1880 (*-----------------------------------------------------------------*)
\r
1882 unit act3: procedure;
\r
1884 (* scans thru dictionary table and for alive addresses *)
\r
1885 (* a corrects the value of Statsl in Sl fathers *)
\r
1887 var t1,t2,t3: integer,
\r
1891 for t1:=lastitem step reflength to upr
\r
1893 if M(t1+1)=/=maxcounter (* alive object *)
\r
1895 t2:=M(t1); (* t2 = am of object *)
\r
1896 if M(t2)>0 (* object to be killed *)
\r
1901 b:=a; t2:=b.Sl(t2);
\r
1903 b:=PROT(abs(M(t2)));
\r
1904 t3:=b.Statsl(t2); M(t3):=M(t3)-1;
\r
1910 (*-----------------------------------------------------------------*)
\r
1912 unit act4: procedure;
\r
1914 (* scans thru dictionary table and for alive addresses *)
\r
1915 (* exchanges M[am-lspan],M[am],M[ah] with M[am],ah,M[am-lspan]; *)
\r
1916 (* objects marked by procedure prologue are put to killed list *)
\r
1917 (* ATTENTION!!! *)
\r
1918 (* when lspan=0 we have a special case, cf. act4,act5 and act7 *)
\r
1921 var t1,t2,t3: integer,
\r
1924 for t1:=lastitem step reflength to upr
\r
1926 if M(t1+1)=/=maxcounter (* alive object *)
\r
1928 t2:=M(t1); (* t2 = am of object *)
\r
1929 if M(t2)<0 (* marked object *)
\r
1931 M(t2):=-M(t2) (* reconstruct pt *)
\r
1933 M(t1+1):=maxcounter; (* kill address *)
\r
1934 a:=PROT(M(t2)); (* a is object prot. *)
\r
1935 t3:=a.Size(t2); (* t3 is object size *)
\r
1936 t2:=t2-a.Ptposition; (* move t2 to begin. *)
\r
1938 call Sinsert(t2); (* kill this object *)
\r
1939 repeat; (* skip the rest *)
\r
1942 if a.Ptposition=/=0 (* prot.numb.not first *)
\r
1944 t3:=t2-a.Ptposition; M(t1):=M(t3);
\r
1945 M(t3):=M(t2); M(t2):=t1;
\r
1946 else (* prot. num. first *)
\r
1947 M(t1):=M(t2+1); M(t2+1):=t1
\r
1953 (*----------------------------------------------------------------*)
\r
1955 unit act5: procedure;
\r
1957 (* marks the killed objects substituting prototype number to *)
\r
1958 (* a special value, so that during scanning memory we will be *)
\r
1959 (* able to tell apart the killed objects just by such a number; *)
\r
1960 (* the length of a killed object is put on the M[i+shortlink] *)
\r
1962 var t1,t2,t3: integer;
\r
1968 t2:=M(t1+shortlink); M(t1+shortlink):=2;
\r
1969 M(t1):=skilled; t1:=t2;
\r
1977 t3:=M(t2+shortlink); M(t2+shortlink):=M(t2);
\r
1978 M(t2):=skilled; t2:=t3
\r
1980 t1:=M(t1+longlink);
\r
1985 (*-------------------------------------------------------------------*)
\r
1987 (* Now we can scan the memory without looking at dictionary *)
\r
1989 (*-------------------------------------------------------------------*)
\r
1991 unit act6: procedure;
\r
1993 (* scans thru the memory and for alive objects call traverse *)
\r
1994 (* in order to set virtual addresses equal none identical to <0,0> *)
\r
1995 (* RS auxiliary references are also corrected *)
\r
1997 var t1,t2,t3,t4,t5: integer,
\r
2002 while t1 <= lastused
\r
2004 if M(t1)=/=skilled (* alive object *)
\r
2006 t3:=M(t1); a:=PROT(t3); (* a - prototype *)
\r
2007 if a.Ptposition =/=0
\r
2009 t2:=t1+a.Ptposition; t4:=M(t2);
\r
2010 M(t1):=M(t4); (* reconstruct M[t1] *)
\r
2011 M(t2):=t3; (* reconstruct M[t2] *)
\r
2013 t4:=M(t1+1); M(t1+1):=M(t4); (* reconstruct M[t1+1] *)
\r
2016 t5:=a.Size(t2); (* object size *)
\r
2017 call Traverse(t2,nonefy); (* set none to <0,0> *)
\r
2018 if a.Ptposition =/=0
\r
2020 M(t2):=t4; M(t1):=t3;
\r
2026 t1:=t1+M(t1+shortlink) (* M[t1+shortlink]=size *)
\r
2029 for t1:=virt1 step reflength to virtn
\r
2035 (*-----------------------------------------------------------------*)
\r
2037 unit act7: procedure;
\r
2039 (* squeezes dictionary putting on counters new values of ah *)
\r
2041 var t1,t2,t3: integer;
\r
2045 t1:=upr-1; t2:=t1;
\r
2046 while t1>= lastitem
\r
2048 if M(t1+1)=maxcounter (* entry killed *)
\r
2052 M(t1+1):=t2; t2:=t2-reflength;
\r
2058 (*-------------------------------------------------------------------*)
\r
2060 unit act8: procedure;
\r
2062 (* squeezes the memory, killed objects are removed, remaining pushed *)
\r
2063 (* for alive objects references are relocated .i.e. new ah and new *)
\r
2064 (* counters are computed;M[am-lspan], M[am], M[ah] are reconstructed *)
\r
2065 (* finally all auxiliary RS references are also relocated *)
\r
2067 var t1,t2,t3,t4,t5,t6: integer,
\r
2071 M(1):=0; (* M[1]=0 for relocate *)
\r
2072 t1:=lwr+1; t2:=t1;
\r
2073 while t1 <= lastused
\r
2075 if M(t1)=skilled (* ignore this object *)
\r
2077 t1:=t1+M(t1+shortlink) (* M[t1+shortlink]=size *)
\r
2079 t6:=M(t1); (* prototype number *)
\r
2080 a:=PROT(t6); (* object prototype *)
\r
2081 t4:=t1+a.Ptposition; (* t4 is amold *)
\r
2082 if a.Ptposition=/=0
\r
2084 t5:=M(t4); (* t5 is old ah *)
\r
2085 M(t4):=t6; (* reconstruct M[t4] *)
\r
2086 M(t1):=M(t5); (* reconstruct M[t1] *)
\r
2088 t5:=M(t1+1); (* t5 is old ah *)
\r
2089 M(t1+1):=M(t5); (* reconstruct M[t1+1] *)
\r
2092 for t6:=0 to t3-1 (* copy object *)
\r
2094 M(t2+t6):=M(t1+t6);
\r
2096 t6:=t2+a.Ptposition; (* t6 is amnew *)
\r
2097 M(t5):=t6; (* set proper M[ah] *)
\r
2098 call Traverse(t6,relocate);
\r
2103 (* relocate RS auxiliary references *)
\r
2104 for t1:=virt1 step reflength to virtn
\r
2106 call relocate(t1);
\r
2108 (* initialize working variables *)
\r
2109 M(1):=1; (* reconstruct M[1] *)
\r
2110 lastused:=t2-1; headk2:=0;
\r
2114 (*------------------------------------------------------------------*)
\r
2116 unit act9: procedure;
\r
2118 (* squeezes dictionary *)
\r
2120 var t1,t2,t3: integer;
\r
2123 t1:=upr+1; t2:=t1-reflength;
\r
2124 while t2 >=lastitem
\r
2129 M(t3):=M(t2); M(t3+1):=0;
\r
2134 lastitem:=t1; freeitem:=0;
\r
2139 (*----------------------------------------------------------------*)
\r
2141 (* Compactify body *)
\r
2143 nlength:=lastitem-lastused;
\r
2144 call act1; call Memorydump;
\r
2145 call act2; call Memorydump;
\r
2146 call act3; call Memorydump;
\r
2147 call act4; call Memorydump;
\r
2148 call act5; call Memorydump;
\r
2149 call act6; call Memorydump;
\r
2150 call act7; call Memorydump;
\r
2151 call act8; call Memorydump;
\r
2152 call act9; call Memorydump;
\r
2153 writeln(" compactifier used;released space=", lastitem-lastused-nlength);
\r
2157 (*----------------------------------------------------------------------*)
\r
2159 unit Memorydump : procedure;
\r
2162 var i,j,k,l,u: integer;
\r
2167 writeln(" SYSTEM VARIABLES");
\r
2168 writeln("freeitem lastused lastitem headk headk2 lwr upr");
\r
2169 write(freeitem:8); write(lastused:8); write(lastitem:8);
\r
2170 write(headk:6);write(" "); write(headk2:6);write(" ");
\r
2171 write(lwr:4);write(" "); writeln(upr:4);
\r
2172 writeln(" VIRTUAL ADDRESSES");
\r
2175 if l-18 > lastitem then u:=l-18 else u:=lastitem fi;
\r
2177 for i:=l step reflength downto u do write(' ',i:5) od;
\r
2180 for i:=l step reflength downto u do write(' ',M(i):5) od;
\r
2182 write(" M[ah+1]");
\r
2183 for i:=l step reflength downto u do write(' ',M(i+1):5) od;
\r
2185 if u=lastitem then exit else l:=u-reflength fi;
\r
2187 writeln(" OBJECTS");
\r
2189 for i:=0 to lastused
\r
2191 write(' ',M(i):5); j:=j+1;
\r
2200 (*--------------------------------------------------------------------*)
\r
2205 array M dim (0:upr); (* main memory *)
\r
2206 M(0):=0; M(1):=1; (* <0,0> = none *)
\r
2207 freeitem:=0; lastused:=lwr;
\r
2208 headk:=lwr; headk2:=0;
\r
2209 lastitem:=upr+1; M(lwr):=maxapp; (* sentinel of killed *)
\r
2220 (****************************************************************************)
\r
2223 (* inherits MEMORY *)
\r
2226 (* used to open a new object and pass *)
\r
2227 (* the control to and back *)
\r
2229 (* Sl links are used to keep the syntactic environment of an object. *)
\r
2230 (* Dl links inform where to pass the control back from an object. *)
\r
2232 (* Sl links create a tree structure on the set of objects; this tree *)
\r
2233 (* is embedable into the decl syntactic tree. *)
\r
2234 (* Dl links create a structure formed from the active chain and *)
\r
2235 (* and a number of cycles corresponding to suspended coroutines *)
\r
2236 (* or terminated objects. *)
\r
2237 (* New statement adds a new object with Sl,Dl defined as usually. *)
\r
2238 (* Return statement in any object sets Dl to itself. *)
\r
2239 (* End statement in coroutines sets LSC to zero. *)
\r
2240 (* End statement in the other objects is equivalent to return. *)
\r
2242 (****************************************************************************)
\r
2244 unit OBJECTS: MEMORY class;
\r
2247 var IC: integer, (* global control indicator *)
\r
2248 DISPLAY: integer; (* pointer to Display array allocated *)
\r
2249 (* in main block *)
\r
2252 (*----------------------------------------------------------------------*)
\r
2254 unit Openrc: procedure (pt,X:integer);
\r
2256 (* opens a new frame for a simple class whose prototype *)
\r
2257 (* defined by pt;reference to an object is returned at M[X] *)
\r
2263 a:=PROT(pt); length:=a.Size(0); (* dummy parameter *)
\r
2264 call Request(pt,length,X);
\r
2267 (*----------------------------------------------------------------------*)
\r
2269 unit Slopen :procedure(pt,X,Y:integer);
\r
2271 (* opens a new frame for an object with given Sl at M[Y] *)
\r
2272 (* returns reference at M[X] *)
\r
2281 a:=PROT(pt); length:=a.Size(0); (* dummy parameter *)
\r
2282 call Request(pt,length,X);
\r
2285 call Refmove(Sl,Y); (* define Sl link *)
\r
2287 call Refmove(Dl,current); (* define Dl link *)
\r
2290 Stat:=a.Statsl(am);
\r
2291 M(Stat):=M(Stat)+1; (* advance Statusl *)
\r
2294 (*------------------------------------------------------------------------*)
\r
2296 unit Dopen :procedure (pt1,pt2,X: integer);
\r
2298 (* opens a new frame for a visible object, so Sl is taken from Display *)
\r
2299 (* it corresponds to a statement "new C" executed in a module "B" *)
\r
2300 (* where C is defined by pt1 and B by pt2 *)
\r
2306 a:=PROT(pt1) qua Prtpmod.declto; (* prototype of father C *)
\r
2307 b:=PROT(pt2); (* prototype of B *)
\r
2308 call Slopen(pt1,X,DISPL(b.perm(a.level)));
\r
2311 (*----------------------------------------------------------------------*)
\r
2313 unit Openarray: procedure (pt,l,u,X:integer);
\r
2315 (* performs generation newarray[l..u] of type defined by pt *)
\r
2317 var length: integer,
\r
2320 references: Offsets;
\r
2322 length:=u-l+1; a:=PROT(pt);
\r
2325 length:=length*a qua Prtparnst.elsize;
\r
2327 length:=length*a qua Prtparstr.references.size
\r
2329 length:=length+elmoffset; (* add system attributes *)
\r
2330 call Request(pt,length,X); am:=Physical(X);
\r
2331 M(am+lboffset):=l; M(am+uboffset):=u;
\r
2335 (*-----------------------------------------------------------------------*)
\r
2337 unit Go : procedure(X:integer);
\r
2339 (* transfers control to the newly created object defined by X *)
\r
2345 am:=Physical(current);
\r
2347 M(a.Lsc(am)):=IC; (* save local control *)
\r
2349 call Refmove(current,X); (* new current *)
\r
2353 while a=/=none (* search in prefix seq. *)
\r
2354 do (* first non-simple class *)
\r
2355 if not a is Prtpsimpl
\r
2364 (*------------------------------------------------------------------------*)
\r
2366 unit Back: procedure;
\r
2368 (* return from a module is Back *)
\r
2369 (* end in non-coroutine is equivalent to Back *)
\r
2370 (* end in coroutine is equivalent to Endcor, cf. COROUTINES *)
\r
2377 am:=Physical(current);
\r
2380 if not Member(Dl) (* return in main or in *)
\r
2381 then (* attached coroutine is *)
\r
2382 return (* equivalent to empty *)
\r
2384 call Refmove(virt2,current); (* set proper output *)
\r
2385 M(a.Lsc(am)):=IC; (* update local seq. cont. *)
\r
2386 call Refmove(current,Dl); (* current becomes Dl *)
\r
2387 call Refmove(Dl,virt2); (* set Dl in old to itself *)
\r
2388 call Update(current);
\r
2389 am:=Physical(current);
\r
2390 a:=PROT(M(am)); (* prototype of new object *)
\r
2391 IC:=M(a.Lsc(am)); (* IC is local seq. contr. *)
\r
2394 (*------------------------------------------------------------------------*)
\r
2397 unit Inn: procedure (k:integer);
\r
2399 (* simulates the execution of inner in a class, k is pslength *)
\r
2400 (* of a class where inner is executed *)
\r
2408 am:=Physical(current);
\r
2409 a:=PROT(M(am)); (* prototype of current *)
\r
2410 if a.pslength=/=k (* if inner=/= empty *)
\r
2412 for t:=2 to a.pslength-k (* search for a layer *)
\r
2420 (*------------------------------------------------------------------------*)
\r
2423 unit Endrun: procedure;
\r
2425 (* end or return in main block *)
\r
2427 writeln(" Print memory? (0,1)");
\r
2434 raise Error("End of a program execution");
\r
2439 (*-----------------------------------------------------------------------*)
\r
2441 unit prf: function (X:integer, a: Prtpmod): boolean;
\r
2443 (* determines whether prototype a belongs to a prefix sequence of X *)
\r
2452 if a=b then result:=true; return; fi;
\r
2457 (*-----------------------------------------------------------------------*)
\r
2459 unit qual : procedure (X: integer , a: Prtpmod);
\r
2461 (* validate qualification of object X by class type a *)
\r
2465 call Raising(incorqua,virt2);
\r
2469 (*---------------------------------------------------------------------*)
\r
2471 unit inl: function (X:integer, a:Prtp): boolean;
\r
2473 (* validate X in a *)
\r
2476 then (* none is in everything *)
\r
2483 (*------------------------------------------------------------------------*)
\r
2485 unit isl : function (X:integer, a:Prtp): boolean;
\r
2486 (* validate X is a *)
\r
2490 then (* none is not something *)
\r
2494 result:=PROT(M(am))=a;
\r
2498 (*-------------------------------------------------------------------------*)
\r
2500 unit typeref: procedure (X:integer, a: Prtp);
\r
2502 (* check correctness of assignment Y:=X where type of Y is a *)
\r
2504 if Member(X) (* none allowed everywhere *)
\r
2508 call Raising(incorassg,virt2); (* incorrect assignment *)
\r
2513 (*-----------------------------------------------------------------------*)
\r
2515 unit typed :procedure (ldim,rdim,X:integer;a,b:Prtp);
\r
2517 (* check correctness of Y:=X where X and Y are adjustable arrays *)
\r
2518 (* type of Y is array ldim of a, type of X is array rdim of b *)
\r
2522 call Raising(incorassg,virt2); (* incorrect assignment *)
\r
2530 call Raising(incorassg,virt2); (* incorrect assignment *)
\r
2535 (*--------------------------------------------------------------------*)
\r
2537 unit gkill : procedure (X:integer);
\r
2540 (* general killer of pointed objects *)
\r
2541 (* It can kill an object of array or simple class, as well as *)
\r
2542 (* a cycle of coroutine. In the latter case because of calls *)
\r
2543 (* to procedure killer which kills SL chain (if possible) one *)
\r
2544 (* must change the order of this cycle. Taking this cycle in *)
\r
2545 (* reverse order we can call killer with security that the *)
\r
2546 (* whole cycle will be properly deallocated. This method bases *)
\r
2547 (* strongly on the fact that if X Dl Y, then not Y Sl* X. *)
\r
2554 if not Member(X) then return fi; (* kill only alive object *)
\r
2557 if a in Prtparr orif a is Prtpsimpl (* no problems with arrays *)
\r
2558 then (* or with records *)
\r
2559 call Disp(X); return;
\r
2561 if a is Prtpclass (* kill class if possible *)
\r
2564 if M(b.Statsl(am))=/=0
\r
2566 call Raising(incorkill,virt2)
\r
2568 call Refmove(virt3,b.Sl(am));
\r
2573 if a is Prtpproc then call Raising(incorkill,virt2) fi;
\r
2575 (* kill coroutine - methods in three phases *)
\r
2578 do (* first loop, examine all Statussl *)
\r
2579 call Refmove(virt4,Dl);
\r
2580 if M(b.Statsl(am))=/=0
\r
2582 call Raising(incorkill,virt2)
\r
2585 if Equal(X,Dl) then exit fi;
\r
2586 am:=Physical(Dl); b:=PROT(M(am));
\r
2588 call Refmove(virt2,X);
\r
2589 do (* second loop, change the order *)
\r
2590 am:=Physical(virt2);
\r
2593 call Refmove(virt3,Dl);
\r
2594 call Refmove(Dl,virt4);
\r
2595 call Refmove(virt4,virt2);
\r
2596 call Refmove(virt2,virt3);
\r
2597 if Equal(virt2,X) then exit fi;
\r
2599 do (* third loop, kill all objects *)
\r
2600 am:=Physical(X); b:=PROT(M(am));
\r
2601 call Refmove(virt3,b.Sl(am));
\r
2602 call Refmove(virt4,b.Dl(am));
\r
2605 call Refmove(X,virt4);
\r
2606 if not Member(X) then exit fi;
\r
2611 (*######################################################################*)
\r
2613 (* END OF SPECIFICATION PART *)
\r
2615 (*######################################################################*)
\r
2618 (*-----------------------------------------------------------------------*)
\r
2620 unit DISPL: function(d:integer): integer;
\r
2621 (* auxiliary function returning an address of DISPLAY[d] in M *)
\r
2623 result:=DISPLAY+(d-1)*reflength;
\r
2627 (*-----------------------------------------------------------------------*)
\r
2629 unit Update: procedure (X:integer);
\r
2632 (* Update DISPLAY procedure, see LNCS 208, pp.134-156 *)
\r
2634 var a,c,d,e: Prtpmod,
\r
2641 a:=PROT(M(am)); k:=a.level;
\r
2644 call Refmove(DISPL(e.perm(k)),X);
\r
2645 if k=1 then return fi;
\r
2647 j:=a.perminv(d.perm(k));
\r
2650 c:=a.declto; X:=a.Sl(am); (* compute address of Sl *)
\r
2651 am:=Physical(X); (* take next object *)
\r
2653 j:= a.perminv(c.perm(j));
\r
2654 if a.level=j then exit fi
\r
2661 (*-----------------------------------------------------------------------*)
\r
2663 unit killer: procedure;
\r
2665 (* this procedure kills Sl chain of virt3 , if Statussl allows it *)
\r
2673 am:=Physical(virt3); a:=PROT(M(am));
\r
2674 Stat:=a.Statsl(am); M(Stat):=M(Stat)-1;
\r
2675 if M(Stat)=0 (* StatusSl = 0 *)
\r
2676 andif (not a in Prtpclass) (* it is not class *)
\r
2677 andif Equal(virt3,a.Dl(am)) (* object terminated *)
\r
2679 call Refmove(virt2,a.Sl(am));
\r
2681 call Refmove(virt3,virt2);
\r
2688 (*-----------------------------------------------------------------------*)
\r
2690 unit killafter: procedure;
\r
2692 (* this procedure kills an object of non-class after return *)
\r
2693 (* the reference to returned object is kept on virt2 always *)
\r
2700 am:=Physical(virt2);
\r
2702 Stat:=a.Statsl(am);
\r
2705 call Refmove(virt3,a.Sl(am));
\r
2712 (*-----------------------------------------------------------------------*)
\r
2719 (* OBJECTS body *)
\r
2721 a:=PROT(1); (* a is prototype of main *)
\r
2722 i:=a.Size(0); (* i = length of main object *)
\r
2723 call Request(1,i,virt1);
\r
2724 am:=Physical(virt1); (* am is physical of main *)
\r
2725 DISPLAY:=am+a qua Prtpproc.displ; (* define address of DISPLAY[1] *)
\r
2726 current:=am+a qua Prtpproc.curr; (* define current *)
\r
2727 call Refmove(current,virt1);
\r
2728 call Refmove(DISPL(1),current); (* define Display for main *)
\r
2745 (************************************************************************)
\r
2749 (* inherits OBJECTS *)
\r
2751 (* performs coroutine sequencing *)
\r
2753 (************************************************************************)
\r
2761 unit COROUTINES : OBJECTS class;
\r
2763 var lastcor: integer, (* reference to the last attaching coroutine *)
\r
2764 corhead: integer; (* reference to the active coroutine *)
\r
2767 (*--------------------------------------------------------------------*)
\r
2769 unit Endcor: procedure ;
\r
2771 (* - in Loglan 82 coroutine end was equivalent to detach - *)
\r
2772 (* here, if lastcor=/=none attach(lastcor) else attach(main) *)
\r
2778 am:=Physical(current);
\r
2780 IC:=0; (* prepare M(a.Lsc(am))=0 *)
\r
2781 if Member(lastcor)
\r
2783 call Attch(lastcor)
\r
2789 (*----------------------------------------------------------------------*)
\r
2791 unit Attchaux: class(X: integer);
\r
2793 (* auxiliary for Attach and Attach with *)
\r
2796 var amnew: integer,
\r
2804 call Raising(ilattach,virt2);
\r
2806 amnew:=Physical(X); (* take physical of X *)
\r
2807 a:=PROT(M(amnew)); (* a is prototype of X *)
\r
2808 if not (a in Prtpcor)
\r
2810 call Raising(ilattach,virt2);
\r
2812 if M(a.Lsc(amnew))=0
\r
2814 call Raising(corterm,virt2);
\r
2816 if Equal(corhead,X) then return fi; (* equivalent to empty *)
\r
2817 call Refmove(virt2,corhead); (* save lastcoroutine *)
\r
2818 amold:=Physical(corhead); (* physical of head *)
\r
2819 b:=PROT(M(amold)); (* b is prototype of old *)
\r
2820 Dl:=b.Dl(amold); (* compute Dl of old *)
\r
2821 call Refmove(corhead,X); (* set coroutinehead *)
\r
2822 call Refmove(Dl,current); (* set Dl in old corout. *)
\r
2823 call Refmove(lastcor,virt2); (* set lastcor *)
\r
2824 b:=a; (* b is prototype of new *)
\r
2825 Dl:=b.Dl(amnew); (* compute Dl of new *)
\r
2826 amold:=Physical(current); (* compute current *)
\r
2827 a:=PROT(M(amold)); (* a prototype of curr. *)
\r
2828 M(a.Lsc(amold)):=IC; (* remember IC *)
\r
2832 (*--------------------------------------------------------------------*)
\r
2834 unit Attch : Attchaux procedure;
\r
2836 (* performs Attach(X) *)
\r
2839 call Update(Dl); (* update DISPLAY *)
\r
2840 call Refmove(current,Dl); (* set new current *)
\r
2841 call Setnone(Dl); (* Dl of corhead is none *)
\r
2842 amnew:=Physical(current); (* compute physical add. *)
\r
2843 a:=PROT(M(amnew)); (* a is prototype of cur.*)
\r
2844 IC:=M(a.Lsc(amnew)); (* define new IC *)
\r
2847 (*--------------------------------------------------------------------*)
\r
2849 (* body of COROUTINES *)
\r
2851 lastcor:=am+ a qua Prtpproc . lstcr;
\r
2852 corhead:=am+ a qua Prtpproc . chead;
\r
2853 call Setnone(lastcor); (* lastcor=none *)
\r
2854 call Refmove(corhead,current); (* corhead=main *)
\r
2876 (************************************************************************)
\r
2880 (* inherits COROUTINES *)
\r
2882 (* performs exception handling *)
\r
2884 (************************************************************************)
\r
2888 unit HANDLING : COROUTINES class;
\r
2890 unit virtual Raising : procedure (signalnum,X:integer);
\r
2892 (* Procedure Raising implements raise statement. Parameter signalnum *)
\r
2893 (* defines signal number, M[X] returns the address of opened handler *)
\r
2903 Y:=current; (* start of searching *)
\r
2904 do (* main loop *)
\r
2906 a:=PROT(M(am)); (* take prototype *)
\r
2907 if a is Prtphand (* for handlers skip *)
\r
2908 then (* to avoid recursiv. *)
\r
2909 Y:=a.Sl(am); (* handling;go via Sl *)
\r
2910 repeat; (* continue searching *)
\r
2913 do (* search prefix seq. *)
\r
2915 do (* search in module *)
\r
2916 if h=none then exit fi; (* end of handlist *)
\r
2917 if PROT(h.hand) qua Prtphand.oth (* for handler others *)
\r
2918 andif signalnum <= syssigl (* and system signals *)
\r
2920 call Slopen(h.hand,X,Y); (* open handler object *)
\r
2924 do (* search signal list *)
\r
2925 if s = none then exit fi; (* end of signal list *)
\r
2926 if s.signalnum=signalnum (* handler found *)
\r
2928 call Slopen(h.hand,X,Y); (* open handler object *)
\r
2936 if b=none then exit fi; (* end of prefix seq. *)
\r
2938 Y:=a.Dl(am); (* go via Dl *)
\r
2939 if not Member(Y) then exit fi;
\r
2941 raise Error(" Handler not found");
\r
2944 (*-----------------------------------------------------------------*)
\r
2946 unit Attchwith: Attchaux procedure (signalnum,Y:integer);
\r
2948 (* this procedure performs attach(X) with signalnum *)
\r
2949 (* Y points an object of a found handler *)
\r
2951 call Refmove(virt4,current); (* save current *)
\r
2952 call Refmove(current,Dl); (* set new current *)
\r
2953 call Setnone(Dl); (* Dl of corhead is none *)
\r
2954 call Raising(signalnum,Y);
\r
2955 call Refmove(current,virt4); (* restore current *)
\r
2958 (*-----------------------------------------------------------------*)
\r
2960 unit Termination : procedure;
\r
2962 (* Procedure Termination winds up the dynamic chain moving Lsc *)
\r
2963 (* of each object on its lastwill part. For prefixed modules *)
\r
2964 (* lastwill is performed from the innermost to the outermost; *)
\r
2965 (* so, it is sufficient to move Lsc for the innermost module *)
\r
2966 (* and for end statement in prefixed modules a jump to the *)
\r
2967 (* prefix father lastwill statement is statically executed. *)
\r
2968 (* Dummy lastwill part in this solution is always required. *)
\r
2969 (* The last statement before lastwill in such modules passes *)
\r
2970 (* control to the corresponding post inner part, as usually. *)
\r
2978 am:=Physical(current); (* take address of handler *)
\r
2979 a:=PROT(M(am)); (* prototype of handler *)
\r
2980 X:=a.Sl(am); (* find handler Sl father *)
\r
2981 Y:=a.Dl(am); (* find handler Dl father *)
\r
2982 am:=Physical(X); (* set am the last address *)
\r
2985 b:=PROT(M(Y)); (* prototype of module *)
\r
2986 M(b.Lsc(Y)):=b.lstwill; (* move Lsc on lastwill *)
\r
2987 if Y=am then exit fi; (* end of chain *)
\r
2988 Y:=b.Dl(Y); (* next chain element *)
\r
2997 (*****************************************************************************)
\r
2999 (* BODY PART OF PROGRAM *)
\r
3001 (*****************************************************************************)
\r
3005 pref HANDLING block
\r
3007 (************************************************************************)
\r
3011 (* inherits COROUTINES *)
\r
3013 (* written only for testing RS *)
\r
3014 (************************************************************************)
\r
3017 var CODES : arrayof integer; (* program code *)
\r
3019 (*----------------------------------------------------------------*)
\r
3021 (* 1 pt dn off 0 0 = Openrc(pt,X) *)
\r
3022 (* 2 pt dn1 off1 dn2 off2 = Slopen(pt,X,Y) *)
\r
3023 (* 3 pt1 pt2 dn off 0 = Dopen(pt1,pt2,X) *)
\r
3024 (* 4 pt dn1 off1 dn2 off2 = Openarr(pt,1,u,X) *)
\r
3025 (* 5 dn off 0 0 0 = Go(X) *)
\r
3026 (* 6 0 0 0 0 0 = Back address on virt2 *)
\r
3027 (* 7 k 0 0 0 0 = Inn(k) *)
\r
3028 (* 8 dn1 off1 dn2 off2 0 = a:=a+b *)
\r
3029 (* 9 " = a:=a-b *)
\r
3030 (* 10 " = a:=a*b *)
\r
3031 (* 11 " = a:=a/b *)
\r
3032 (* 12 dn1 off1 dn2 off2 s = a:=A[i] for s=0 *)
\r
3033 (* 13 dn1 off1 0 0 0 = A[i]:=a for s=1 *)
\r
3034 (* 14 dn off 0 0 0 = write(a) *)
\r
3035 (* 15 dn off 0 0 0 = read(a) *)
\r
3036 (* 16 0 0 0 0 0 = writeln *)
\r
3037 (* 17 C 0 0 0 0 = goto C *)
\r
3038 (* 18 C dn off 0 0 = if a=0 goto C *)
\r
3039 (* 19 C dn off 0 0 = if a>0 goto C *)
\r
3040 (* 20 dn off 0 0 0 = kill(X) *)
\r
3041 (* 21 dn1 off1 dn2 off2 0 = X:=Y *)
\r
3042 (* 22 dn off 0 0 0 = a:=0 *)
\r
3043 (* 23 dn off s 0 0 = a:=a+s *)
\r
3044 (* 24 dn1 off1 dn2 off2 off = a:=X.b *)
\r
3045 (* 25 dn1 off1 off dn2 off2 = X.a:=b *)
\r
3046 (* 26 dn1 off1 dn2 off2 off = Y:=X.Z *)
\r
3047 (* 27 dn1 off1 off dn2 off2 = Y.Z:=X *)
\r
3048 (* 28 0 0 0 0 0 = endrun *)
\r
3049 (* 29 dn off 0 0 0 = attach(X) *)
\r
3050 (* 30 0 0 0 0 0 = attach(lastcor) *)
\r
3051 (* 31 C dn off 0 0 = if X=none goto C *)
\r
3052 (* 32 0 0 0 0 0 = Endcor *)
\r
3053 (* 33 dn off pt 0 0 = qual X by a *)
\r
3054 (* 34 dn off 0 0 0 = gkill(X) *)
\r
3055 (* 35 dn off pt C 0 = if X in a goto C *)
\r
3056 (* 36 dn off pt C 0 = if X is a goto C *)
\r
3057 (* 37 dn off pt 0 0 = typeref(X,a) *)
\r
3058 (* 38 dn off pt pt1 0 = typed(k,s, *)
\r
3059 (* 39 k s 0 0 0 = X,pt,pt1) *)
\r
3060 (* 40 s dn off 0 0 = raise(s,X) *)
\r
3061 (* 41 0 0 0 0 0 = terminate *)
\r
3062 (* 42 0 0 0 0 0 = kill procedure on Dl *)
\r
3063 (* 43 dn1 off1 s dn2 off2 = attach(X) with s *)
\r
3064 (* 44 s dn1 off1 0 0 = attach(lastcor) with *)
\r
3065 (* 45 0 0 0 0 0 = attach(main) *)
\r
3066 (* 46 s dn1 off1 0 0 = attach(main) with s *)
\r
3067 (*----------------------------------------------------------------*)
\r
3070 unit Address: function(dnum,offset:integer):integer;
\r
3071 (* gives physical address of a variable pointed by dnum,offset *)
\r
3073 result:=Physical(DISPL(dnum))+offset
\r
3076 unit Arrelem: procedure(X,i:integer; output am,length:integer);
\r
3077 (* X - reference to array and i - index value *)
\r
3078 (* am -physical address element , length - element length *)
\r
3083 am:=Physical(X); pt:=M(am); a:=PROT(pt);
\r
3084 if i<M(am+lboffset) orif i>M(am+uboffset)
\r
3086 call Raising(arrayind,virt2);
\r
3088 i:=i-M(am+lboffset);
\r
3091 length:=a qua Prtparnst. elsize;
\r
3092 am:=am+elmoffset+length * i;
\r
3094 length:=a qua Prtparstr.references.size;
\r
3095 am:=am+elmoffset+length * i;
\r
3101 dn1,off1: integer,
\r
3102 dn2,off2: integer,
\r
3103 pt,pt1,pt2: integer,
\r
3104 l,u,k,i,C,s: integer;
\r
3107 when Error: writeln; writeln(t); terminate;
\r
3111 (* EXECUTOR body *)
\r
3114 read(f,n); n:=n*8;
\r
3115 (* each code requires 8 words, the first is the code number *)
\r
3116 (* 6 define an operation and arguments, see the table above *)
\r
3117 (* last=0,1,2 and defines trace and dump, last=1 gives trace *)
\r
3118 (* last=2 gives dump and trace simultaneously *)
\r
3119 writeln(" Print prototypes? (0,1)");
\r
3121 if i=1 then call Protwrite fi;
\r
3122 writeln(" Print memory? (0,1)");
\r
3124 if i=1 then call Memorydump fi;
\r
3125 array CODES dim (1:n);
\r
3126 for i:=1 to n do read(f,CODES(i)) od;
\r
3127 writeln(" Print codes? (0,1)");
\r
3131 writeln(" OPCODES ");
\r
3135 write(CODES(i)); k:=k+1;
\r
3136 if k=8 then k:=0 ; writeln; fi;
\r
3142 if CODES(C+7) >= 1
\r
3144 writeln(" code ");
\r
3145 write(CODES(C),CODES(C+1),CODES(C+2),CODES(C+3),CODES(C+4));
\r
3146 writeln(CODES(C+5),CODES(C+6));
\r
3148 if CODES(C+7) >= 2
\r
3150 writeln("memory dump"); call Memorydump;
\r
3154 pt:=CODES(C+2);dn:=CODES(C+3); off:=CODES(C+4);
\r
3156 call Openrc(pt,Address(dn,off));
\r
3158 pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);
\r
3159 dn2:=CODES(C+5);off2:=CODES(C+6);
\r
3161 call Slopen(pt,Address(dn1,off1),Address(dn2,off2));
\r
3163 pt1:=CODES(C+2);pt2:=CODES(C+3);dn:=CODES(C+4);off:=CODES(C+5);
\r
3165 call Dopen(pt1,pt2,Address(dn,off));
\r
3167 pt:=CODES(C+2);dn1:=CODES(C+3);off1:=CODES(C+4);
\r
3168 dn2:=CODES(C+5);off2:=CODES(C+6);
\r
3169 k:=M(Address(dn1,off1));
\r
3171 call Openarray(pt,1,k,Address(dn2,off2));
\r
3173 dn:=CODES(C+2);off:=CODES(C+3);
\r
3175 call Go(Address(dn,off));
\r
3177 dn:=CODES(C+2);off:=CODES(C+3);
\r
3185 dn1:=CODES(C+2);off1:=CODES(C+3);
\r
3186 dn2:=CODES(C+4);off2:=CODES(C+5);
\r
3187 i:=Address(dn1,off1); k:=Address(dn2,off2);
\r
3191 dn1:=CODES(C+2);off1:=CODES(C+3);
\r
3192 dn2:=CODES(C+4);off2:=CODES(C+5);
\r
3193 i:=Address(dn1,off1); k:=Address(dn2,off2);
\r
3197 dn1:=CODES(C+2);off1:=CODES(C+3);
\r
3198 dn2:=CODES(C+4);off2:=CODES(C+5);
\r
3199 i:=Address(dn1,off1); k:=Address(dn2,off2);
\r
3203 dn1:=CODES(C+2);off1:=CODES(C+3);
\r
3204 dn2:=CODES(C+4);off2:=CODES(C+5);
\r
3205 i:=Address(dn1,off1); k:=Address(dn2,off2);
\r
3209 dn1:=CODES(C+2);off1:=CODES(C+3);
\r
3210 dn2:=CODES(C+4);off2:=CODES(C+5);
\r
3212 call Arrelem(Address(dn1,off1),M(Address(dn2,off2)),k,l);
\r
3213 dn1:=CODES(C+10);off1:=CODES(C+11);
\r
3214 u:= Address(dn1,off1);
\r
3217 for i:= 0 to l-1 do M(u+i):=M(k+i) od;
\r
3219 for i:= 0 to l-1 do M(k+i):=M(u+i) od;
\r
3223 dn:=CODES(C+2);off:=CODES(C+3);
\r
3224 write(M(Address(dn,off)));
\r
3227 dn:=CODES(C+2);off:=CODES(C+3);
\r
3228 read(M(Address(dn,off)));
\r
3236 dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);
\r
3237 if M(Address(dn,off))=0
\r
3244 dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);
\r
3245 if M(Address(dn,off))>0
\r
3252 dn:=CODES(C+2); off:=CODES(C+3);
\r
3254 call Disp(Address(dn,off));
\r
3256 dn1:=CODES(C+2); off1:=CODES(C+3);
\r
3257 dn2:=CODES(C+4); off2:=CODES(C+5);
\r
3259 call Refmove(Address(dn1,off1),Address(dn2,off2));
\r
3261 dn:=CODES(C+2); off:=CODES(C+3);
\r
3262 M(Address(dn,off)):=0;
\r
3265 dn:=CODES(C+2); off:=CODES(C+3);
\r
3267 k:=Address(dn,off); M(k):=M(k)+s;
\r
3270 dn1:=CODES(C+2); off1:=CODES(C+3);
\r
3271 dn2:=CODES(C+4); off2:=CODES(C+5); off:=CODES(C+6);
\r
3272 k:=Address(dn2,off2);
\r
3273 k:=Physical(k); k:=k+off;
\r
3274 M(Address(dn1,off1)):=M(k);
\r
3277 dn1:=CODES(C+2); off1:=CODES(C+3); off:=CODES(C+4);
\r
3278 dn2:=CODES(C+5); off2:=CODES(C+6);
\r
3279 k:=Address(dn1,off1);
\r
3280 k:=Physical(k); k:=k+off;
\r
3281 M(k):= M(Address(dn2,off2));
\r
3284 dn1:=CODES(C+2); off1:=CODES(C+3);
\r
3285 dn2:=CODES(C+4); off2:=CODES(C+5); off:=CODES(C+6);
\r
3286 k:=Address(dn2,off2);
\r
3287 k:=Physical(k); k:=k+off;
\r
3288 call Refmove(Address(dn1,off1),k);
\r
3291 dn1:=CODES(C+2); off1:=CODES(C+3); off:=CODES(C+4);
\r
3292 dn2:=CODES(C+5); off2:=CODES(C+6);
\r
3293 k:=Address(dn1,off1);
\r
3294 k:=Physical(k); k:=k+off;
\r
3295 call Refmove(k,Address(dn2,off2));
\r
3300 dn:=CODES(C+2); off:=CODES(C+3);
\r
3302 call Attch(Address(dn,off));
\r
3305 call Attch(lastcor);
\r
3307 dn:=CODES(C+3); off:=CODES(C+4); C:=CODES(C+2);
\r
3308 if not Member(Address(dn,off))
\r
3318 dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);
\r
3319 call qual(Address(dn,off),PROT(pt));
\r
3322 dn:=CODES(C+2); off:=CODES(C+3);
\r
3323 call gkill(Address(dn,off));
\r
3326 dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);
\r
3328 if inl(Address(dn,off),PROT(pt))
\r
3335 dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);
\r
3337 if isl(Address(dn,off),PROT(pt))
\r
3344 dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);
\r
3346 call typeref(Address(dn,off),PROT(pt));
\r
3348 dn:=CODES(C+2); off:=CODES(C+3); pt:=CODES(C+4);
\r
3350 k:=CODES(C+10); s:=CODES(C+11);
\r
3352 call typed(k,s,Address(dn,off),PROT(pt),PROT(pt1));
\r
3354 s:=CODES(C+2); dn:=CODES(C+3); off:=CODES(C+4);
\r
3356 call Raising(s,Address(dn,off));
\r
3364 dn1:=CODES(C+2); off1:=CODES(C+3); s:=CODES(C+4);
\r
3365 dn2:=CODES(C+5); off2:=CODES(C+6);
\r
3367 call Attchwith(Address(dn1,off1),s,Address(dn2,off2));
\r
3370 dn1:=CODES(C+3); off1:=CODES(C+4);
\r
3372 call Attchwith(lastcor,s,Address(dn1,off1));
\r
3375 call Attch(virt1);
\r
3378 dn1:=CODES(C+3); off1:=CODES(C+4);
\r
3380 call Attchwith(virt1,s,Address(dn1,off1));
\r
projects / loglan.git / blob