DataMuseum.dk

top - download

    Length: 10403 (0x28a3)
    Types: TextFile
    Names: »STHP34.PAS«

└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
    └─⟦this⟧ »RTP\STHP34.PAS« 
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
    └─⟦this⟧ »RTP\STHP34.PAS« 
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
    └─⟦this⟧ »RTP\STHP34.PAS« 
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
    └─⟦this⟧ »STHP34.PAS« 
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
    └─⟦this⟧ »RTP\STHP34.PAS« 

TextFile

{$O+,F+}\r
unit sthp34;\r
(**\r
this context contains types and routines concerning\r
the symbol table handler.\r
**)\r
interface\r
uses pscplm, mpaunit, sthunit, sthint, sthcom, vmmunit, nthunit;\r
const\r
ShieldType =    [mailboxtype, referencetype, pooltype, processtype,\r
                 porttype, chaintype, programtype,pointertype];\r
ShieldType35 =    [mailboxtype, referencetype, pooltype,porttype];\r
\r
function st_caselabel( low_limit, high_limit : integer;\r
var first_addr, cur_addr : st_address ): boolean;\r
\r
\r
procedure st_new_fixupp( no, offset: word;\r
var startlist, slutlist : st_address );\r
\r
procedure st_externallist( spix : spixrange;\r
owner: st_address;\r
var startlist, slutlist : st_address );\r
\r
procedure st_reserve( total_size : word;\r
var st_addr : st_address; var st_ptr : st_elemptr );\r
\r
\r
procedure st_reservejump(var st_addr : st_address; var st_ptr : st_elemptr );\r
\r
function SimpelFuncRes(st_ptr : st_elemptr) : boolean;\r
\r
  Function ExtNoOfParams(Lab : St_Address): Integer;\r
\r
  Procedure ExtParamKind(code : Codes;TypeRef : St_Address;\r
                          VAR Typ : Integer; VAR Size : Integer);\r
\r
\r
  Procedure Makeparamdesc(Lab : St_Address;VAR parstr : string);\r
\r
(*******************)\r
\r
implementation\r
\r
procedure link_newnode(var ptr: st_elemptr; var addr1,addr2: st_address);\r
var ptr2 : st_elemptr;\r
begin\r
elementextend( ptr, cexternal );\r
if equal_addr( addr1, st_nilladdr ) then addr1:= currant_addr else\r
begin\r
st_lock(ptr);\r
elementretrieve( false, true, addr2, ptr2 );\r
st_unlock(ptr);\r
ptr2^.ext_ref:= currant_addr;\r
end;\r
addr2:= currant_addr;\r
end;\r
\r
\r
\r
function st_caselabel( low_limit, high_limit : integer;\r
var first_addr, cur_addr : st_address ): boolean;\r
var\r
ptr, next_ptr : st_elemptr;\r
next, former_addr : st_address;\r
stop : boolean;\r
\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start  caselabel');\r
(*endtest#*)\r
(**  insert new label node **)\r
st_declaration( clabel, anonymousname, cur_addr, ptr );\r
ptr^.label_low:= low_limit;\r
ptr^.label_high:= high_limit;\r
\r
stop:= false;\r
st_caselabel:= true;\r
if equal_addr( first_addr, st_nilladdr) then\r
first_addr:= cur_addr else\r
begin\r
next := first_addr;\r
elementretrieve( false, false, next, next_ptr );\r
\r
while (next_ptr^.label_high < low_limit) and not stop do\r
begin\r
if equal_addr( next_ptr^.listref, st_stopaddr) then\r
begin\r
stop:= true;\r
st_update(next_ptr);\r
next_ptr^.listref:= cur_addr;\r
end else\r
begin\r
former_addr:= next;\r
next:= next_ptr^.listref;\r
elementretrieve( false, false, next, next_ptr );\r
end;\r
end;\r
(** result : stop or high_limit < next_ptr^.label_low .\r
  then insert new label    **)\r
\r
if not stop then\r
begin\r
if ( next_ptr^.label_low  > high_limit ) then\r
begin\r
ptr^.listref:= next;\r
if equal_addr( next, first_addr) then\r
first_addr:= cur_addr else\r
begin\r
elementretrieve( false, true, former_addr, next_ptr );\r
next_ptr^.listref:= cur_addr;\r
end;\r
end else st_caselabel:= false;\r
end;\r
end;\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
elem_print( ptr, cur_addr);\r
writeln(testoutput,'slut caselabel');\r
printstars;\r
end;\r
(*endtest#*)\r
end;\r
\r
\r
\r
procedure st_new_fixupp( no, offset : word;\r
var startlist, slutlist : st_address );\r
var\r
ptr : st_elemptr;\r
begin\r
link_newnode( ptr, startlist, slutlist );\r
with ptr^ do\r
begin\r
ext_spix:= anonymousspix;\r
fixup_no:= no;\r
fixup_offset:= offset;\r
end;\r
end;\r
\r
\r
procedure st_externallist( spix : spixrange;\r
owner: st_address;\r
var startlist,\r
slutlist : st_address );\r
var ptr : st_elemptr;\r
begin\r
link_newnode( ptr, startlist, slutlist );\r
ptr^.ext_spix:= spix;\r
ptr^.ext_owner:= owner;\r
end;\r
\r
\r
procedure st_reserve( total_size : word;\r
var st_addr : st_address; var st_ptr : st_elemptr );\r
\r
var\r
length : word;\r
i : word;\r
ptr    : st_elemptr;\r
begin\r
(*#begintest\r
if teststh then writeln(testoutput,'  start  st_reserve');\r
(*endtest#*)\r
if total_size <= max_data_size-st_reserve_offset then\r
length:= total_size else length:= max_data_size - st_reserve_offset;\r
\r
node_length[ cstrucconst ]:= length + minlength + st_reserve_offset;\r
elementextend( st_ptr, cstrucconst );\r
st_ptr^.st_size:= length;\r
for i:=1 to length do st_ptr^.data_area[i]:=0;\r
st_addr:= currant_addr;\r
\r
if total_size > length then\r
begin\r
repeat\r
total_size:= total_size - length;\r
if total_size + st_reserve_offset <= max_data_size then\r
length:= total_size else length:= max_data_size - st_reserve_offset;\r
node_length[ cstrucelem ]:= length + minlength + st_reserve_offset;\r
st_lock(st_ptr);\r
elementextend( ptr, cstrucelem );\r
st_unlock(st_ptr);\r
st_ptr^.listref:= currant_addr;\r
ptr^.st_size:= length;\r
for i:=1 to length do ptr^.data_area[i]:=0;\r
st_ptr:= ptr;\r
until total_size<=length;\r
st_ptr^.st_listend:= true;\r
elementretrieve( false, true, st_addr, st_ptr );\r
end else st_ptr^.st_listend:=true;\r
(*#begintest\r
if teststh then\r
begin\r
printstars;\r
writeln(testoutput,'slut st_reserve');\r
printstars;\r
end;\r
(*endtest#*)\r
end;\r
\r
\r
\r
procedure st_reservejump(var st_addr : st_address; var st_ptr : st_elemptr );\r
\r
var\r
length : word;\r
begin\r
length:= max_data_size - st_labeldef_offset;\r
\r
node_length[ clabeldef ]:= minlength + max_data_size;\r
elementextend( st_ptr, clabeldef );\r
st_ptr^.st_size:= length div 9; (* typesize(tempbin1_record *)\r
st_addr:= currant_addr;\r
\r
end;\r
\r
\r
function SimpelFuncRes(st_ptr : st_elemptr) : boolean;\r
Begin\r
IF Computer = RC5000 THEN\r
 BEGIN\r
   SimpelFuncRes := (st_ptr^.St_Size = 1) OR (st_ptr^.St_Size = 4);\r
 END\r
ELSE\r
IF Computer = RC3502 THEN\r
  BEGIN\r
   with st_ptr^ DO\r
   SimpelFuncRes :=  ((St_Size = 3) AND (St_Kind = cpointerType)) OR\r
                     (   ( (St_Size=1) OR (st_Size = 2) ) AND\r
                         ( (St_Kind <> CArrayType) AND\r
                           (st_kind <> cRecordType) AND\r
                           (st_Kind <> cSetType)           )  );\r
  END\r
ELSE\r
  BEGIN\r
    SimpelFuncRes := st_ptr^.St_Size <= 4;\r
  END;\r
end;\r
\r
\r
  Function ExtNoOfParams(Lab : St_Address): Integer;\r
  VAR Ptr : St_ElemPtr;\r
      help : Integer;\r
      next : St_address;\r
  BEGIN\r
\r
    St_Retrieve(Lab,Ptr);\r
    help := ord(Ptr^.St_Kind = CFunction);\r
    Next := Ptr^.ListRef;\r
    WHILE Not Equal_Addr(Next,St_StopAddr) DO\r
     BEGIN\r
       help := help + 1;\r
       st_Retrieve(Next,ptr);\r
       Next := Ptr^.ListRef;\r
       st_Retrieve(ptr^.TypeRef,Ptr);\r
       IF Ptr^.type_Mode = Open_Fam THEN Help := Help + 1;\r
     END;\r
    ExtNoOfParams := help;\r
  END;\r
\r
\r
  Procedure ExtParamKind(code : Codes;TypeRef : St_Address;\r
                          VAR Typ : Integer; VAR Size : Integer);\r
  VAR Kind : Byte;\r
      Ptr : St_ElemPtr;\r
      Struc :St_Protect_type;\r
  BEGIN\r
    Case Code OF\r
     CFunction :\r
       BEGIN\r
         St_RetrieveType(TypeRef,Ptr);\r
         IF not simpelFuncRes(ptr) THEN typ := 1 else typ := 3;\r
       END;\r
     CValueParam : Typ := 2;\r
     CVarParam : Typ := 1;\r
     CSharedParam,cShared : Typ := 101;\r
     CInspectParam : Typ := 102;\r
     ELSE  Typ := 0;\r
    END;\r
\r
    St_Retrieve(TypeRef,Ptr);\r
    IF (Ptr^.Spec_Struct * (Shieldtype + [MailboxPointer]) = []) OR\r
       (Ptr^.Type_Mode = fam)\r
        THEN  Kind := 8\r
    ELSE\r
    BEGIN\r
    struc := Ptr^.Spec_struct;\r
    St_RetrieveType(TypeRef,Ptr);\r
     Case Ptr^.St_Kind OF\r
     CPointertype : Kind := 1;\r
     cArrayType   : Kind := 7;\r
     ELSE\r
      BEGIN\r
       size := Ptr^.St_Size;\r
       IF (Struc = [Mailboxtype]) and (Size = MailBoxSize) THEN Kind := 2\r
       ELSE\r
       IF (Struc = [Referencetype]) and (Size = ReferenceSize) THEN Kind := 3\r
       ELSE\r
       IF (Struc = [Processtype]) and (Size = ProcessSize) THEN Kind := 4\r
       ELSE\r
       IF (Struc = [Pooltype]) and (Size = PoolSize)  THEN Kind := 5\r
       ELSE\r
(*     IF (Struc = [Porttype]) and (Size = PortSize) THEN Kind := 9\r
       ELSE\r
*)     IF (Struc = [Chaintype]) and (Size = ChainSize) THEN Kind := 10\r
       ELSE  Kind := 6;\r
     END;\r
    END;\r
   END;\r
   typ := kind*4+typ;\r
   Size := Ptr^.St_Size;\r
  END;\r
\r
\r
  Procedure Makeparamdesc(Lab : St_Address;VAR parstr : string);\r
  VAR Ptr : St_ElemPtr;\r
      help : Integer;\r
      typeAddr,Addr : St_Address;\r
\r
  Procedure PutParamKind(code : Codes;typeRef : St_Address);\r
   (* only used when target = RC5000 *)\r
  VAR kind : char;\r
      Typ     : char;\r
      helpstr : string[10];\r
      sys : boolean;\r
      Struc :St_Protect_type;\r
      Ptr : St_ElemPtr;\r
      size : integer;\r
\r
  BEGIN\r
   Case Code OF\r
     CFunction :\r
       BEGIN\r
         St_RetrieveType(TypeRef,Ptr);\r
         IF not simpelFuncRes(ptr) THEN typ := 'f' else typ := 'F';\r
       END;\r
     CValueParam : Typ := 'V';\r
     CVarParam : Typ := 'v';\r
     CSharedParam,cShared : Typ := 'S';\r
     CInspectParam : Typ := 'I';\r
     ELSE  Typ := 'U';\r
    END;\r
\r
    St_Retrieve(TypeRef,Ptr);\r
    sys := (Ptr^.Spec_Struct * (Shieldtype + [MailboxPointer]) <> []);\r
    IF (Ptr^.Type_Mode = open_fam) THEN\r
      BEGIN\r
        IF sys then Kind :='F' else Kind := 'f';\r
      END\r
    ELSE\r
    IF not sys then kind := 'N'\r
    ELSE\r
    BEGIN\r
    struc := Ptr^.Spec_struct;\r
    St_RetrieveType(TypeRef,Ptr);\r
     Case Ptr^.St_Kind OF\r
     CPointertype : Kind := 'P';\r
     cArrayType   : Kind := 'A';\r
     ELSE\r
      BEGIN\r
       size := Ptr^.St_Size;\r
       IF (Struc = [Mailboxtype]) and (Size = MailBoxSize) THEN Kind := 'M'\r
       ELSE\r
       IF (Struc = [Referencetype]) and (Size = ReferenceSize) THEN Kind := 'r'\r
       ELSE\r
       IF (Struc = [Processtype]) and (Size = ProcessSize) THEN Kind := 'p'\r
       ELSE\r
       IF (Struc = [Pooltype]) and (Size = PoolSize)  THEN Kind := 'O'\r
       ELSE\r
       IF (Struc = [Porttype]) and (Size = PortSize) THEN Kind := 'o'\r
       ELSE\r
       IF (Struc = [Chaintype]) and (Size = ChainSize) THEN Kind := 'C'\r
       ELSE  Kind := 'R';\r
     END;\r
    END;\r
   END;\r
\r
   str(Ptr^.St_size,helpstr);\r
   parstr := concat(parstr,typ,kind,helpstr);\r
\r
  END;\r
\r
  BEGIN\r
    parstr := '$RTP';\r
    St_Retrieve(Lab,Ptr);\r
    Addr := Ptr^.ListRef;\r
    IF Ptr^.St_Kind = CFunction THEN\r
      BEGIN\r
        PutParamKind(CFunction,Ptr^.TypeRef);\r
      END;\r
    WHILE Not Equal_Addr(Addr,St_StopAddr) DO\r
     BEGIN\r
       st_Retrieve(Addr,ptr);\r
       Addr := Ptr^.ListRef;\r
       TypeAddr := Ptr^.TypeRef;\r
       PutParamKind(Ptr^.St_Kind,TypeAddr);\r
     END;\r
  END;\r
\r
\r
end.\r
\r
«eof»