DataMuseum.dk

top - download

    Length: 6400 (0x1900)
    Types: TextFile
    Names: »IO«

└─⟦8c5bcce80⟧ Bits:30005186 8" CR80 Floppy CR80FD_0183 ( CR/D/0436 PASCAL UTILITIES HPH Date 790524 Copy of CR/D/0958 )
    └─⟦12c79cc2c⟧ 
        └─ ⟦this⟧ »BLK.IO« 
└─⟦9975dd352⟧ Bits:30005088 8" CR80 Floppy CR80FD_0043 ( CR/D/1032 PROMGEN (HBA) 790917 HBA PROMGEN BACKUP )
    └─⟦69b0db55a⟧ 
        └─ ⟦this⟧ »HBA.IO« 

TextFile

"PAGE"\f


"***********************
*  PASCAL I/O PACKAGE  *
***********************"

PROCEDURE XXXERROR(T:     TEXT);
VAR I:INTEGER;
BEGIN
  DISPLAY(NL);
  DISPLAY('?');
  DISPLAY('?');
  I:=1;
  WHILE T[I]<>NULL DO
  BEGIN
    DISPLAY(T[I]);
    I:=SUCC(I);
  END;
  DISPLAY(NL);
  HALT;
END "XXXERROR";


"OPEN AND CLOSE STREAMS"
"----------------------"

PROCEDURE OPEN(VAR S:STREAM; NAME:TEXT; DIR:DIRECTION);
CONST OC='OC          ';
VAR ID:IDENTIFIER; CTRL:INTEGER; ARG:ARGTYPE;
BEGIN
  IF NOT (DIR IN [INPUT,OUTPUT]) THEN
    XXXERROR('ILLEGAL DIRECTION(:0:)');
  FOR CTRL:=1 TO IDLENGTH DO
    ID[CTRL]:=' ';
  CTRL:=1;
  WHILE (NAME[CTRL]<>'(:0:)') AND
        (CTRL<SUCC(IDLENGTH)) DO
  BEGIN
    ID[CTRL]:=NAME[CTRL];
    CTRL:=SUCC(CTRL);
  END;
  IF ID=OC THEN
    IF DIR=INPUT
      THEN S:=INOC
      ELSE S:=OUTOC
  ELSE
  BEGIN
    ARG.TAG:=IDTYPE;
    ARG.ID:=ID;
    IF DIR=INPUT THEN
    BEGIN
      S:=INFILE;
      WRITEARG(INP,ARG);
    END
    ELSE
    BEGIN
      S:=OUTFILE;
      WRITEARG(OUT,ARG);
    END;
  END;
END "OPEN";


PROCEDURE CLOSE(S:STREAM);
VAR ARG:ARGTYPE;
BEGIN
  CASE S OF
  INOC,OUTOC:
    ;
  INFILE:
    READARG(INP,ARG);
  OUTFILE:
    READARG(OUT,ARG)
  END "CASE";
END "CLOSE";


"I/O OF BYTES (CHARACTERS)"
"-------------------------"

PROCEDURE OUTBYTE(S:STREAM; B:UNIV CHAR);
BEGIN
  CASE S OF
  OUTOC:
    DISPLAY(B);
  OUTFILE:
    WRITE(B);
  INOC,INFILE:
    XXXERROR('OUTPUT TO AN INPUT STREAM(:0:)')
  END "CASE";
END "OUTBYTE";


PROCEDURE INBYTE(S:STREAM; VAR B:UNIV CHAR);
BEGIN
  CASE S OF
  INOC:
    ACCEPT(B);
  INFILE:
    READ(B);
  OUTOC,OUTFILE:
    XXXERROR('INPUT FROM AN OUTPUT STREAM(:0:)')
  END "CASE";
END "INBYTE";


PROCEDURE OUTNL(S:STREAM);
BEGIN
  OUTBYTE(S,NL);
END "OUTNL";


PROCEDURE BACKSPACE(S:STREAM);
BEGIN
  " UNIMPLEMENTED "
END "BACKSPACE";


"I/O OF TEXT STRINGS"
"-------------------"

PROCEDURE INLINE(S:STREAM; VAR T:TEXT);
VAR CH:CHAR; I:INTEGER;
BEGIN
  I:=1;
  REPEAT
    INBYTE(S,CH);
    T[I]:=CH;
    I:=SUCC(I);
  UNTIL (CH=NL) OR (CH=EM) OR (I>=TEXT_SIZE);
  T[I]:=NULL;
END "INLINE";


PROCEDURE OUTBYTES(S:STREAM; B:UNIV CHAR; COUNT:INTEGER);
VAR CTRL:INTEGER;
BEGIN
  FOR CTRL:=1 TO COUNT DO
    OUTBYTE(S,B);
END "OUTBYTES";


PROCEDURE OUTSTRING(S:STREAM; T:TEXT);
VAR DONE:BOOLEAN; I:INTEGER;
BEGIN
  I:=1;   DONE:=FALSE;
  WHILE NOT DONE DO
    IF T[I]<>NULL THEN
      IF I<=TEXT_SIZE THEN
      BEGIN
        OUTBYTE(S,T[I]);
        I:=SUCC(I);
      END
      ELSE DONE:=TRUE
    ELSE DONE:=TRUE;
END "OUTSTRING";


PROCEDURE OUTTEXT(S:STREAM; T:TEXT; SIZE:INTEGER);
VAR CTRL:INTEGER;
BEGIN
  IF SIZE>TEXT_SIZE THEN
    XXXERROR('TEXT TOO LARGE(:0:)');
  FOR CTRL:=1 TO SIZE DO
    OUTBYTE(S,T[CTRL]);
END "OUTTEXT";


"I/O OF INTEGERS"
"---------------"

FUNCTION BIN_TO_ASCII(INT:INTEGER):CHAR;
BEGIN
  IF INT<10
    THEN BIN_TO_ASCII:=CHR(INT+ORD('0'))
    ELSE BIN_TO_ASCII:=CHR(INT-10+ORD('A'));
END "BIN_TO_ASCII";


PROCEDURE OUTHEXA(S:STREAM; INT:UNIV INTEGER; WIDTH:INTEGER);
VAR T:TEXT; CTRL:INTEGER; TEMP:INTEGER;
BEGIN
  FOR CTRL:=1 TO TEXT_SIZE DO
    T[CTRL]:=SP;
  TEMP:=INT;
  FOR CTRL:=1 TO 4 DO
  BEGIN
    T[CTRL]:=BIN_TO_ASCII(GETBITS(TEMP,3,4));
    TEMP:=RIGHTSHIFT(TEMP,4);
  END;
  T[5]:='#';
  IF WIDTH<5 THEN
    FOR CTRL:=1 TO WIDTH DO
      T[CTRL]:='*';
  FOR CTRL:=WIDTH DOWNTO 1 DO
    OUTBYTE(S,T[CTRL]);
END "OUTHEXA";


PROCEDURE OUTINTEGER(S:STREAM; INT:UNIV INTEGER; WIDTH:INTEGER);
VAR T:TEXT; CTRL:INTEGER;
    NEGATIVE:BOOLEAN; TEMP:INTEGER;
BEGIN
  FOR CTRL:=1 TO TEXT_SIZE DO
    T[CTRL]:=SP;
  IF INT=#8000 THEN
  BEGIN
    "HANDLE SPECIAL CASE"
  END
  ELSE
  BEGIN
    TEMP:=INT;
    NEGATIVE:=TEMP<0;
    IF NEGATIVE THEN TEMP:=-TEMP;
    CTRL:=1;
    REPEAT
      T[CTRL]:=BIN_TO_ASCII(TEMP MOD 10);
      TEMP:=TEMP DIV 10;
      CTRL:=SUCC(CTRL);
    UNTIL TEMP=0;
    IF NEGATIVE
      THEN T[CTRL]:='-'
      ELSE CTRL:=PRED(CTRL);
  END;
  IF WIDTH<CTRL THEN
    FOR CTRL:=1 TO WIDTH DO
      T[CTRL]:='*';
  FOR CTRL:= WIDTH DOWNTO 1 DO
    OUTBYTE(S,T[CTRL]);
END "OUTINTEGER";


FUNCTION XXXDIGIT(CH:CHAR):BOOLEAN;
BEGIN
  XXXDIGIT:=('0'<=CH) AND (CH<='9');
END "XXXDIGIT";


FUNCTION XXXHEXADIGIT(CH:CHAR):BOOLEAN;
BEGIN
   XXXHEXADIGIT:=XXXDIGIT(CH) OR
                 (('A'<=CH) AND (CH<='F'));
END "HEXADIGIT";


FUNCTION ASCII_TO_BIN(CH:CHAR):INTEGER;
BEGIN
  IF XXXDIGIT(CH) THEN
    ASCII_TO_BIN:=ORD(CH)-ORD('0')
  ELSE IF XXXHEXADIGIT(CH)
    THEN ASCII_TO_BIN:= ORD(CH)-ORD('A')+10
    ELSE XXXERROR('ILLEGAL CHARACTER CONVERSION(:0:)');
END "ASCII_TO_BIN";


PROCEDURE INHEXA(S:STREAM; VAR INT:INTEGER);
VAR CH:CHAR;
BEGIN
  "SKIP INITIAL GARBAGE"
  REPEAT
    INBYTE(S,CH);
    IF CH=EM THEN XXXERROR('INPUT STREAM TERMINATED(:0:)');
  UNTIL XXXHEXADIGIT(CH);
  "ASSEMBLE VALUE"
  INT:=0;
  WHILE XXXHEXADIGIT(CH) DO
  BEGIN
    INT:=LEFTSHIFT(INT,4);
    PUTBITS(ASCII_TO_BIN(CH),INT,3,4);
    INBYTE(S,CH);
  END;
END "INHEXA";


PROCEDURE ININTEGER(S:STREAM; VAR INT:INTEGER);
VAR CH:CHAR; POSITIVE:BOOLEAN;
BEGIN
  "SKIP INITIAL GARBAGE"
  REPEAT
    INBYTE(S,CH);
    IF CH=EM THEN XXXERROR('INPUT STREAM  TERMINATED(:0:)');
  UNTIL (CH='#') OR (CH='-') OR XXXDIGIT(CH);
  "GO HANDLE HEXADECIMAL CASE"
  IF CH='#' THEN
  BEGIN
    INHEXA(S,INT);
    EXIT;
  END;
  "CHECK FOR SIGN"
  POSITIVE:=TRUE;
  IF CH='-' THEN
  BEGIN
    POSITIVE:=FALSE;
    INBYTE(S,CH);
  END;
  "ASSEMBLE VALUE"
  INT:=0;
  WHILE XXXDIGIT(CH) DO
  BEGIN
    INT:=INT*10-ASCII_TO_BIN(CH);
    INBYTE(S,CH);
  END;
  "REVERSE SIGN IF POSITIVE"
  IF POSITIVE THEN INT:=-INT;
END "ININTEGER";

PROCEDURE IN_LONG_INTEGER(S: STREAM; VAR LINT: LONG_INTEGER);
VAR
  CH: CHAR;
  POSITIVE: BOOLEAN;
BEGIN
  "SKIP INITTIAL GARBAGE"
  REPEAT
    INBYTE(S,CH);
    IF CH=EM THEN XXXERROR('INPUT STREAM TERMINATED(:0:)');
  UNTIL (CH='#') OR (CH='-') OR XXXDIGIT(CH);
  "HANDLE HEXADECIMAL CASE"
  IF CH='#' THEN
  BEGIN
    EXIT;
  END;
  "HANDLE SIGN"
  POSITIVE:= TRUE;
  IF CH='-' THEN
  BEGIN
    POSITIVE:= FALSE;
    INBYTE(S,CH);
  END;
  "ASSEMBLE VALUE, NEGATIVE"
  LINT:= 0L;
  WHILE XXXDIGIT(CH) DO
  BEGIN
    LINT:= LINT*10L-LONG(ASCII_TO_BIN(CH));
    INBYTE(S,CH);
  END;
  "REVERSE SIGN IF POSITIVE"
  IF POSITIVE THEN
    LINT:= -LINT;
END "IN_LONG_INTEGER";

PROCEDURE OUT_LONG_INTEGER(S: STREAM; LINT: LONG_INTEGER; WIDTH: INTEGER);
VAR
  T: TEXT;
  I: INTEGER;
  NEGATIVE: BOOLEAN;
  TEMP: LONG_INTEGER;
BEGIN
  FOR I:= 1 TO TEXT_SIZE DO
    T[I]:= SP;
  IF LINT=#80000000L THEN
  BEGIN
    "HANDLE SPECIAL CASE"
  END
  ELSE
  BEGIN
    TEMP:= LINT;
    NEGATIVE:= TEMP<0L;
    IF NEGATIVE THEN
      TEMP:= -TEMP;
    I:= 1;
    REPEAT
      T[I]:= BIN_TO_ASCII(SHORT(TEMP-(TEMP/10L)*10L));
      TEMP:= TEMP/10L;
      I:= SUCC(I);
    UNTIL TEMP= 0L;
    IF NEGATIVE THEN
      T[I]:= '-'
    ELSE
      I:= PRED(I);
  END;
  IF WIDTH<I THEN
    FOR I:= 1 TO WIDTH DO
      T[I]:= '*';
  FOR I:= WIDTH DOWNTO 1 DO
    OUTBYTE(S,T[I]);
END "OUT_LONG_INTEGER";
«eof»