DataMuseum.dk

Presents historical artifacts from the history of:

DANOSI

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about DANOSI

Excavated with: AutoArchaeologist - Free & Open Source Software. 

top - download

⟦5c1b78e00⟧ TextFile

    Length: 8378 (0x20ba)
    Types: TextFile
    Names: »RC35SYS.RTP«

Derivation

└─⟦289818552⟧ Bits:30010516 DVBS1.SW2114.src.2.7-3 SW2114 3/4 Real Time Pascal 2.7
    └─⟦this⟧ »RTP\RC35SYS.RTP« 
└─⟦783187a02⟧ Bits:30010525 DVBS1.SW2114.src.2.6-3 RTP compiler source SW2104+SW2114 Disk#3 30/1-92 HHA
    └─⟦this⟧ »RTP\RC35SYS.RTP« 
└─⟦ca921ce75⟧ Bits:30010528 DVBS1.SW2114.src.2.6-6 RTP Compiler Source SW2104+SW2114 Disk 3 92.02.03 HEJ HHA
    └─⟦this⟧ »RTP\RC35SYS.RTP« 
└─⟦d5707feda⟧ Bits:30010512 DVBS1.SW2114.src.2.14-3 SW2114 REAL #3/4 TIME PASCAL SOURCE REL 2.14 92.09.01
    └─⟦this⟧ »RTP\RC35SYS.RTP«

TextFile

rtp3502sys;\r
   (* Routines used by the DOS-RTP Compiler *)\r
TYPE\r
  stType = Array(1..255) OF Char;\r
  StPtr = ^StType;\r
\r
  ArType = Array(1..MaxInt) OF Byte;\r
  ArPtr = ^ArType;\r
\r
  IntegerPtr = ^Integer;\r
  \r
  Programrec = record\r
                programref : IntegerPtr;\r
                Firstparam :IntegerPtr;\r
                paramsize  : integer;\r
               END;\r
  \r
  FuskProgramrec =\r
               record\r
                 progrec : programrec;\r
                 filler : array(1..(typesize(program_Descriptor) -\r
                                     typesize(programrec)) ) of byte;\r
               end;\r
FUNCTION RCNew = _new______rc(bytes : Integer; wordallignment : Boolean):\r
                                IntegerPtr; EXTERNAL;\r
.\r
PROCEDURE RTP_ExcRec(a,b: ArPtr;Length : integer);\r
VAR help : byte;\r
BEGIN\r
 FOR i := 1 to length do\r
   BEGIN\r
     help := b^(i);\r
     b^(i) := a^(i);\r
     a^(i) := help;\r
   END;\r
END;\r
\r
PROCEDURE RTP_ExPack(a : IntegerPtr;FirstLastBit : Integer;\r
                  b : IntegerPtr;FirstLastBit1 : Integer);\r
var a1 : integer;\r
    maske : integer;\r
    firstbit,lastbit : integer;\r
    b1 : integer;\r
    maske1 : integer;\r
    firstbit1, lastbit1 : integer;\r
BEGIN\r
  with firstlastbit as x : record\r
                              high , low : byte;\r
                            end \r
     do\r
   begin\r
     firstbit := x.high;\r
     lastbit := x.low;\r
   end;\r
  maske := ((1 shift(lastbit - firstbit + 1)) - 1) shift (15 - lastbit);\r
  with firstlastbit1 as x : record\r
                              high , low : byte;\r
                            end \r
     do\r
   begin\r
     firstbit1 := x.high;\r
     lastbit1 := x.low;\r
   end;\r
  maske1 := ((1 shift(lastbit1 - firstbit1 + 1)) - 1) shift (15 - lastbit1);\r
  b1 := (b^ and maske1) shift (lastbit1 - 15);\r
  a1 := (a^ and maske) shift (lastbit - 15);\r
  a^ := (a^ and (not maske)) or (b1 shift (15 -lastbit));\r
  b^ := (b^ and (not maske1)) or (a1 shift (15 -lastbit1));\r
END;\r
\r
PROCEDURE RTP_ExPackRec(a : IntegerPtr;FirstLastBit : Integer;\r
                     b : IntegerPtr);\r
var a1 : integer;\r
    maske : integer;\r
    firstbit,lastbit : integer;\r
BEGIN\r
  with firstlastbit as x : record\r
                              high , low : byte;\r
                            end \r
     do\r
   begin\r
     firstbit := x.high;\r
     lastbit := x.low;\r
   end;\r
  maske := ((1 shift(lastbit - firstbit + 1)) - 1) shift (15 - lastbit);\r
  a1 := (a^ and maske) shift (lastbit - 15);\r
  if (lastbit - firstbit) > 7 then\r
  begin\r
    a^ := (a^ and (not maske)) or ( (b^ shift (15 -lastbit)) and maske);\r
    b^ := a1; \r
  end else\r
  with b^ as b1 : byte do\r
  begin\r
    a^ := (a^ and (not maske)) or ( (b1 shift (15 -lastbit)) and maske);\r
    b1 := a1; \r
  end;\r
END;\r
\r
\r
PROCEDURE RTP_ExRecPack(a : IntegerPtr;\r
                     b : IntegerPtr;FirstLastBit1 : Integer);\r
PROCEDURE RTP_ExPackRec(a : IntegerPtr;FirstLastBit : Integer;\r
                     b : IntegerPtr);EXTERNAL;\r
BEGIN\r
  RTP_ExPackRec(b, FirstLastBit1, a);\r
END;\r
\r
Function RTP_EqRec(a,b: ArPtr;Length : integer) : Boolean;\r
BEGIN\r
 RTP_EqRec := True;\r
 for i := 1 to length DO\r
   IF a^(i) <> b^(i) THEN\r
     BEGIN\r
       RTP_EqRec := false;\r
       Exit\r
     END;\r
END;\r
PROCEDURE RTP_StStr(s1,s2: StPtr;LengthS1,LengthS2 : integer);\r
BEGIN\r
  for i := 1 to LengthS1 DO\r
    BEGIN\r
      IF i <= LengthS2 THEN s1^(i) := s2^(i)\r
      ELSE s1^(i) := ' ';\r
    END;\r
END;\r
PROCEDURE RTP_ExStr(s1,s2: StPtr;LengthS1,LengthS2 : integer);\r
var maxleng,leng : integer;\r
    s : StPtr;\r
    help : char;\r
BEGIN\r
 if lengthS1 > Lengths2 THEN\r
  BEGIN\r
   Leng := LengthS2;\r
   MaxLeng := LengthS1;\r
   s := s1;\r
  END\r
 ELSE\r
  BEGIN\r
   Leng := LengthS1;\r
   MaxLeng := LengthS2;\r
   s := s2;\r
  END;\r
 FOR i := 1 TO Leng DO\r
  BEGIN\r
   help := s2^(i);\r
   s2^(i) := s1^(i);\r
   s1^(i) := help;\r
  END;\r
  FOR i := leng + 1 to MaxLeng DO\r
     s^(i) := ' ';\r
END;\r
\r
\r
FUNCTION RTP_GtStr(s1,s2: StPtr;LengthS1,LengthS2 : integer) : Boolean;\r
var i,leng : integer;\r
BEGIN\r
 if lengthS1 > Lengths2 THEN\r
  BEGIN\r
   Leng := LengthS2;\r
  END\r
 ELSE\r
  BEGIN\r
   Leng := LengthS1;\r
  END;\r
 i := 1;\r
 while i <= leng do \r
   BEGIN\r
     IF  (s1^(i) <> s2^(i)) THEN ExitLoop;\r
     i := i + 1;\r
   END;\r
 IF i <= Leng THEN RTP_GTStr := (s1^(i) > s2^(i))\r
 ELSE\r
IF LengthS1 > LengthS2 THEN\r
  BEGIN\r
    RTP_GTStr := false; \r
    for i := leng + 1 to LengthS1 DO\r
     IF s1^(i) > ' ' THEN RTP_GtStr := true;\r
  END\r
 ELSE\r
   BEGIN\r
     RTP_GTStr := false;\r
   END;\r
END;\r
\r
FUNCTION RTP_LtStr(s1,s2: StPtr;LengthS1,LengthS2 : integer) : Boolean;\r
var i,leng : integer;\r
BEGIN\r
 if lengthS1 > Lengths2 THEN\r
  BEGIN\r
   Leng := LengthS2;\r
  END\r
 ELSE\r
  BEGIN\r
   Leng := LengthS1;\r
  END;\r
 i := 1;\r
 while i <= leng do \r
   BEGIN\r
     IF  (s1^(i) <> s2^(i)) THEN ExitLoop;\r
     i := i + 1;\r
   END;\r
 IF i <= Leng THEN RTP_LTStr := (s1^(i) < s2^(i))\r
 ELSE\r
IF LengthS1 < LengthS2 THEN\r
  BEGIN\r
    RTP_LTStr := false; \r
    for i := leng + 1 to LengthS2 DO\r
     IF s2^(i) > ' ' THEN RTP_LtStr := true;\r
  END\r
 ELSE\r
   BEGIN\r
     RTP_LTStr := false;\r
   END;\r
END;\r
$code\r
FUNCTION RTP_EqStr(s1,s2: StPtr;LengthS1,LengthS2 : integer) : Boolean;\r
var maxleng,leng : integer;\r
    bool : Boolean := true;\r
    s : StPtr;\r
BEGIN\r
 if lengthS1 > Lengths2 THEN\r
  BEGIN\r
   Leng := LengthS2;\r
   MaxLeng := LengthS1;\r
   s := s1;\r
  END\r
 ELSE\r
  BEGIN\r
   Leng := LengthS1;\r
   MaxLeng := LengthS2;\r
   s := s2;\r
  END;\r
 FOR i := 1 TO Leng DO\r
   Bool := Bool AND (s1^(i) = s2^(i));\r
 IF Bool then\r
   FOR i := leng + 1 to MaxLeng DO\r
     Bool := Bool AND (s^(i) = ' ');\r
RTP_EqStr := Bool;  \r
END;\r
$nocode\r
\r
function create(inspect incname: string; var prog: Fuskprogramrec;\r
     var pr: process; size: integer; prio: integer): create_result;\r
\r
\r
  function oldcreate = create(Inspect pn : alfa; prog : programrec;\r
      var p : process; bytes : integer;prio:priotype) : create_result;\r
                           EXTERNAL;\r
var  a : alfa;\r
BEGIN\r
  a := incname;\r
  create := oldcreate(a,prog.ProgRec,pr,size,prio);\r
END;\r
\r
function link(inspect incname: string;var prog: program_descriptor):\r
              link_result;\r
 function oldlink = link(inspect incname: alfa;var prog: program_descriptor):\r
              link_result; EXTERNAL;\r
 var\r
   a : alfa;\r
   ll : link_result;\r
BEGIN\r
  a := incname;\r
  for i := 1 to 12 do\r
   if ( (ord(a(i)) >= ord('A') ) AND (ord(a(i)) <= ord('Z'))) THEN\r
     a(i) := chr(ord(a(i)) - ord('A') + ord('a'));\r
  ll := oldlink(a,prog);  \r
  link := ll;\r
END;\r
\r
function allocmempool(var p: pool; no_of_bufs, bufsize: 0..maxint;\r
mem: mem_type): 0..maxint;\r
BEGIN\r
  Allocmempool := AllocPool(p,No_Of_bufs,bufsize);\r
END;\r
\r
PROCEDURE new(VAR  p : IntegerPtr; Size : Integer);\r
BEGIN\r
 p := RCNew(size,true);\r
END;\r
\r
function deletemailbox(inspect mbx_name: string): integer;\r
function delmail = deletemailbox(inspect mbx_name: alfa): integer;\r
external;\r
VAR a : alfa;\r
BEGIN\r
  a := mbx_name;\r
  deletemailbox := delmail(a);\r
END;\r
\r
function namemailbox(var m: mailbox; inspect mbx_name: string): integer;\r
function namemail = namemailbox(var m: mailbox; inspect mbx_name: alfa): integer;\r
external;\r
VAR a : alfa;\r
BEGIN\r
  a := mbx_name;\r
  namemailbox := namemail(m,a);\r
END;\r
\r
function ownname(var name:string): byte;\r
function own = ownname(var name:alfa): byte;\r
external;\r
VAR a : alfa;\r
BEGIN\r
  a := name;\r
  ownname := own(a);\r
  name := a;\r
END;\r
\r
function ownprogramname(var name:string): byte;\r
function own = ownprogramname(var name:alfa): byte;\r
external;\r
VAR a : alfa;\r
BEGIN\r
  a := name;\r
  ownprogramname := own(a);\r
  name := a;\r
END;\r
\r
function searchmailbox(inspect mbx_name: string): ^mailbox;\r
function search = searchmailbox(inspect mbx_name: alfa): ^mailbox;\r
external;\r
VAR a : alfa;\r
BEGIN\r
  a := mbx_name;\r
  searchmailbox := search(a);\r
END;\r
\r
Procedure setownname(INSPECT name : string);\r
Procedure setownnamerc(INSPECT name : alfa); External;\r
VAR a : alfa;\r
BEGIN\r
  a := name;\r
  setownnamerc(a);\r
END;\r
\r
function callremote(VAR r : Reference; Inspect name: string) : Integer;\r
function oldcallremote = callremote(VAR r : Reference;\r
                     Inspect name: alfa) : Integer; EXTERNAL;\r
VAR\r
  a : alfa;\r
BEGIN\r
 a := name;\r
 callremote := oldcallremote(r,a);\r
END.\r
\r
\r
«eof»