DataMuseum.dk

top - download

    Length: 8576 (0x2180)
    Types: TextFile
    Names: »POLYPAS.PAS«

└─⟦490a8e2df⟧ Bits:30003937 SW1501 RcComal-80 v3.0 (thykier)
    └─ ⟦this⟧ »POLYPAS.PAS« 
└─⟦72a4952a6⟧ Bits:30004362 SW1501 RcComal-80 v3.0
    └─ ⟦this⟧ »POLYPAS.PAS« 
└─⟦dcb507fe6⟧ Bits:30003936 SW1501 RcComal-80 v3.0 (ils)
    └─ ⟦this⟧ »POLYPAS.PAS« 

TextFile

CONST
  versno : INTEGER = $8324;
  ppasmodif  = 41;
  valuepar   = 0;
  refpar     = 1;
  realpar    = 0;
  stringpar  = 2;
  proc       = 5;
  realfunc   = 9;
  stringfunc = 10;
  ppaserr    = 190;
  konverr    = 191;   

TYPE
  navne = STRINGÆ16Å;
    
VAR
  (* de fire reserver må ikke slettes *)
  reserver,
  reserver1,
  reserver2,
  reserver3 : INTEGER;
  hovedfil  : FILE OF BYTE;
  helptal   : ARRAY Æ1..8Å OF BYTE;



(* -------------------------------- *)
(* RUTINER TIL UDSKRIVNING AF HOVED *)
  
PROCEDURE openfile(filnavn : navne);
BEGIN
  assign(hovedfil, filnavn);
  rewrite(hovedfil);
END;

PROCEDURE closefile;
BEGIN
  close(hovedfil);
END;

PROCEDURE skriv_byte(tal : byte);
BEGIN
  write(hovedfil,tal);
END;

PROCEDURE skriv_navn(varnavn : navne);
VAR 
  i : integer;
BEGIN
  skriv_byte(len(varnavn));
  FOR i:=1 TO len(varnavn) DO
    skriv_byte(ord(varnavnÆiÅ));
END;

PROCEDURE skriv_offset(offset : integer);
BEGIN
  skriv_byte(lo(offset));
  skriv_byte(hi(offset));
END;

PROCEDURE skriv_packtype;
BEGIN
  skriv_offset(ppasmodif);
END;

PROCEDURE skriv_versionsno;
BEGIN
  skriv_offset(versno);
END;

PROCEDURE skriv_proc;
BEGIN
  skriv_byte(proc);
END;

PROCEDURE skriv_realfunc;
BEGIN
  skriv_byte(realfunc);
END;

PROCEDURE skriv_stringfunc;
BEGIN
  skriv_byte(stringfunc);
END;

PROCEDURE skriv_typeogdim(partype, pardim : byte);
BEGIN
  
  
  skriv_byte(partype);
  skriv_byte(pardim);
END;

PROCEDURE skriv_reserver;
BEGIN
  skriv_offset(ofs(reserver));
END;


(* -------------------------------- *)
(* RUTINER TIL PARAMETER BEHANDLING *)
  
TYPE
  stringmax = STRINGÆ255Å;


PROCEDURE comalerror(errorkode : integer);
BEGIN CODE
  $8B,$76,$04,           (* MOV SI,4ÆBPÅ  ; ERRORKODE   *)
  $BB,$20,$00,           (* MOV BX,32                   *)
  $8B,$2E,reserver3,     (* MOV BP,RESERVER3            *)
  $1E,                   (* PUSH DS                     *)
  $8E,$5E,$04,           (* MOV DS,4ÆBPÅ                *)
  $FF,$5E,$00,           (* CALLF DWORD PTR ÆBPÅ        *)       
  $1F,                   (* POP DS                      *)
  $8B,$2E,reserver3,     (* MOV BP,RESERVER3            *)
  $83,$ED,$06,           (* SUB BP,6                    *)
  $8B,$E5,               (* MOV SP,BP                   *)
  $CB;                   (* RETF                        *)
END;

(* UNDERRUTINER *)  
    
PROCEDURE henttal(segadr, ofsadr : integer; VAR tal : real);
VAR 
  i,
  expo : integer;
  help : real;
  
  FUNCTION konv(segadr, ofsadr, no : integer): integer;
  VAR
    j,
    k : integer;
  BEGIN
    j:=no div 2;
    k:=memÆsegadr:ofsadr+jÅ;
    IF no mod 2 = 0 THEN konv:=k div 16
                    ELSE konv:=k mod 16;
  END; (* konv *)

BEGIN
  help:=0.0;
  FOR i:=1 TO 13 DO
  BEGIN
    help:=help*10+konv(segadr, ofsadr, i);
  END;
  IF konv(segadr,ofsadr,0) <> 0 THEN help:=-help;
  IF help <> 0 THEN
  BEGIN
    help:=help*pwrten(-13);
    expo:=memÆsegadr:ofsadr+7Å-128;
    IF (expo>63) OR (expo<-63) THEN 
    BEGIN
      comalerror(konverr);
    END;
    help:=help*pwrten(expo);
  END;
  tal:=help;
END; (* henttal *)


PROCEDURE gemtal(segadr, ofsadr : integer; tal : real);
VAR
  expo,
  k,
  ciffer  : integer;
  mystr   : stringÆ18Å;

  PROCEDURE nibble(segadr, ofsadr : integer; no, value : byte);
  VAR
    j,
    k : integer;
  BEGIN
    j:=no div 2;
    k:=memÆsegadr:ofsadr+jÅ;
    IF no mod 2 = 0 THEN memÆsegadr:ofsadr+jÅ:=value*16+k mod 16
                    ELSE memÆsegadr:ofsadr+jÅ:=(k div 16)*16+value;
  END; (* nibble *)    
  
  FUNCTION somtal(ch :char): integer;
  BEGIN
    somtal:=ord(ch)-ord('0');
  END;
  
BEGIN
  str(tal,mystr);
  IF mystrÆ2Å='-' THEN nibble(segadr,ofsadr,0,8)
                  ELSE nibble(segadr,ofsadr,0,0);
  k:=1;
  WHILE (k<=13) DO
  BEGIN
    IF k>=12 THEN ciffer:=0
    ELSE
      IF k=1 THEN ciffer:=somtal(mystrÆ3Å)
      ELSE ciffer:=somtal(mystrÆk+3Å);
    nibble(segadr, ofsadr, k, ciffer);
    k:=k+1;
  END;
  expo:=somtal(mystrÆ17Å)*10+somtal(mystrÆ18Å);
  IF mystrÆ16Å='-' THEN expo:=-expo;
  expo:=129+expo;
  memÆsegadr:ofsadr+7Å:=expo;
END; (* gemtal *)

PROCEDURE hentstring(segadr, ofsadr : integer; VAR mystr : stringmax);
VAR
  i,
  antal,
  myseg,
  myofs  : integer;

BEGIN
  antal:=memwÆsegadr:ofsadr+2Å;
  IF antal>255 THEN comalerror(konverr);
  myseg:=seg(mystr);
  myofs:=ofs(mystr);
  FOR i:=1 TO antal DO
  BEGIN
    memÆmyseg:myofs+iÅ:=memÆsegadr:ofsadr+i+3Å;
  END;
  memÆmyseg:myofsÅ:=antal;
END; (* hentstring *)

PROCEDURE gemstring(segadr, ofsadr : integer; mystr : stringmax);
VAR
  i,
  antal,
  myseg,
  myofs  : integer;

BEGIN
  antal:=len(mystr);
  IF antal > memwÆsegadr:ofsadrÅ THEN comalerror(konverr);
  myseg:=seg(mystr);
  myofs:=ofs(mystr);
  FOR i:=1 TO antal DO
  BEGIN
    memÆsegadr:ofsadr+i+3Å:=memÆmyseg:myofs+iÅ;
  END;
  memwÆsegadr:ofsadr+2Å:=antal;
END; (* gemstring *)


(* DE VÆSENTLIGE RUTINER *)

PROCEDURE getrealpar(no : byte; VAR tal : real);
VAR
  stackadr : integer;
BEGIN
  stackadr:=memwÆseg(reserver):ofs(reserver)+6Å;
  henttal(memwÆsseg:stackadr+4Å,memwÆsseg:stackadr+4+no*2Å,tal);
END; (* getrealpar *)

PROCEDURE putrealpar(no : byte; tal : real);
VAR
  stackadr : integer;
BEGIN
  stackadr:=memwÆseg(reserver):ofs(reserver)+6Å;
  gemtal(memwÆsseg:stackadr+4Å,memwÆsseg:stackadr+4+no*2Å,tal);
END; (* putrealpar *)

PROCEDURE getstringpar(no : byte; VAR mystr : stringmax);
VAR
  stackadr : integer;
BEGIN
  stackadr:=memwÆseg(reserver):ofs(reserver)+6Å;
  hentstring(memwÆsseg:stackadr+4Å,memwÆsseg:stackadr+4+no*2Å,mystr);
END; (* getstringpar *)

PROCEDURE putstringpar(no : byte; mystr : stringmax);
VAR
  stackadr : integer;
BEGIN
  stackadr:=memwÆseg(reserver):ofs(reserver)+6Å;
  gemstring(memwÆsseg:stackadr+4Å,memwÆsseg:stackadr+4+no*2Å,mystr);
END; (* putstringpar *)


(* CODE RUTINER *)

PROCEDURE returnfar;
BEGIN CODE
  $8B,$2E,reserver3,     (* MOV BP,RESERVER3 *)
  $83,$ED,$06,           (* SUB BP,6         *)
  $8B,$E5,               (* MOV SP,BP        *)
  $CB;                   (* RETF             *)
END;

PROCEDURE comalprgfunckey;
BEGIN CODE
  $55,                   (* PUSH BP              *)
  $BB,$1F,$00,           (* MOV BX,31            *)
  $8B,$2E,reserver3,     (* MOV BP,RESERVER3     *)
  $1E,                   (* PUSH DS              *)
  $8E,$5E,$04,           (* MOV DS,4ÆBPÅ         *)
  $FF,$5E,$00,           (* CALLF DWORD PTR ÆBPÅ *)       
  $1F,                   (* POP DS               *)
  $5D;                   (* POP BP               *)
END;

PROCEDURE returnresult(resseg, resofs, mylen : integer);
BEGIN CODE
  $8B,$46,$08,           (* MOV AX,8ÆBPÅ  ; RESSEG   *)
  $8B,$4E,$06,           (* MOV CX,6ÆBPÅ  ; RESOFS   *)
  $8B,$56,$04,           (* MOV DX,4ÆBPÅ  ; MYLEN    *)
  $8B,$2E,reserver3,     (* MOV BP,RESERVER3         *)
  $83,$ED,$06,           (* SUB BP,6                 *)
  $8B,$E5,               (* MOV SP,BP                *)
  $CB;                   (* RETF                     *)
END;

PROCEDURE return_realresult(tal : real);
BEGIN
  gemtal(seg(helptal),ofs(helptal),tal);
  returnresult(seg(helptal),ofs(helptal),0);
END;

PROCEDURE return_stringresult(mystr : stringmax);
VAR
  leng : integer;
BEGIN
  leng:=len(mystr);
  returnresult(seg(mystr),ofs(mystr)+1,leng);
END;


(* BEHANDLING AF POLYPASCAL-FEJL *)

PROCEDURE error(errno, errofs : integer);

  PROCEDURE hexwrite(no, antalfelter : integer);
  
    PROCEDURE hexciffer(cif : integer);
    BEGIN
      IF cif<=9 THEN write(cif:1)
      ELSE
      BEGIN
        write(chr(ord(cif-10)+ord('A')));
      END;
    END;
  
  BEGIN
    IF antalfelter = 1 THEN
    BEGIN
      hexciffer(no);
    END
    ELSE
    BEGIN
      hexwrite(no div 16, antalfelter-1);
      hexciffer(no mod 16);
    END;
  END;

BEGIN
  write('PolyPascal ');
  CASE hi(errno) OF
    0 : write('programafbrydelse (Ctrl C) ');
    1 : BEGIN
          write('I/0 fejl ');
          hexwrite(lo(errno),2);
        END;
    2 : BEGIN
          write('kørselsfejl ');
          hexwrite(lo(errno),2);
        END;
  END;
  write(' ved PC=');
  hexwrite(errofs,4);
  comalerror(ppaserr);
END;

PROCEDURE init_errorhandler;
BEGIN
  ehofs:=ofs(error);
END;

«eof»