|
DataMuseum.dkPresents historical artifacts from the history of: CR80 Hard and Floppy Disks |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CR80 Hard and Floppy Disks Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 20224 (0x4f00)
Types: TextFile
Names: »CNPMOD«
└─⟦927b41227⟧ Bits:30005184 8" CR80 Floppy CR80FD_0181 ( CR/D/1189 (ulæseligt) )
└─⟦cac81710b⟧
└─⟦this⟧ »PHO.CNPMOD«
"----------------------------------------------------------------------"
" 790523 HOH"
" CONPAS"
" ======"
" CONVERTS PASCAL PROGRAMS FROM UTILITY TO DRIVER FORMAT"
"----------------------------------------------------------------------"
%WORKAREACLAIM=3000
%SUMMARY
"##################################################"
"CR80 SEQUENTIAL PASCAL STANDARD PREFIX. PHO-790330"
"##################################################"
CONST NL = '(:10:)'; FF = '(:12:)'; CR = '(:13:)'; EM = '(:25:)';
CONST NULL = '(:0:)'; SP = ' ';
CONST PAGELENGTH = 256;
TYPE PAGE = ARRAY [1..PAGELENGTH] OF INTEGER;
CONST LINELENGTH = 132;
TYPE LINE = ARRAY [1..LINELENGTH] OF CHAR;
CONST IDLENGTH = 12;
TYPE IDENTIFIER = ARRAY [1..IDLENGTH] OF CHAR;
TYPE FILE = 1..2;
TYPE ARGTAG = (NILTYPE, BOOLTYPE, INTTYPE, IDTYPE, PTRTYPE);
TYPE POINTER = @BOOLEAN;
TYPE ARGTYPE = RECORD
CASE TAG: ARGTAG OF
NILTYPE, BOOLTYPE: (BOOL: BOOLEAN);
INTTYPE: (INT: INTEGER);
IDTYPE: (ID: IDENTIFIER);
PTRTYPE: (PTR: POINTER)
END;
CONST MAXARG = 10;
TYPE ARGLIST = ARRAY [1..MAXARG] OF ARGTYPE;
CONST S = 2; P = 3; O = 4; N = 5; D = 6; L = 7;
TYPE ARGSEQ = (INP, OUT);
TYPE PROGRESULT = (TERMINATED, OVERFLOW, POINTERERROR,
RANGEERROR, VARIANTERROR, HEAPLIMIT,
STACKLIMIT, CODELIMIT, TIMELIMIT, CALLERROR);
TYPE BITPOSITION = 0..15;
TYPE BITFIELDLENGTH = 0..16;
TYPE BITVALUE = (LOW, HIGH);
TYPE MESSAGE_BUFFER = ARRAY (.1..5.) OF INTEGER;
TYPE EVENT_TYPE = (TIME_OUT, ANSWER, MESSAGE, INTERRUPT);
TYPE WORD_ADDRESS = RECORD
MEMORY_SECTION: INTEGER;
WORD_DISPLACEMENT:INTEGER
END;
TYPE BYTE_ADDRESS = RECORD
BYTE_DISPLACEMENT: INTEGER;
WORD_ADDR: WORD_ADDRESS
END;
TYPE PROCESS_NAME = RECORD
NAME: ARRAY [0..2] OF CHAR;
NAME_IDENT:INTEGER;
PROC_IDENT:INTEGER
END;
PROCEDURE READ(VAR C: CHAR);
PROCEDURE WRITE(C: CHAR);
PROCEDURE OPEN(F: FILE; ID: IDENTIFIER; VAR FOUND: BOOLEAN);
PROCEDURE CLOSE(F: FILE);
PROCEDURE GET(F: FILE; P: INTEGER; VAR BLOCK: UNIV PAGE);
PROCEDURE PUT(F: FILE; P: INTEGER; VAR BLOCK: UNIV PAGE);
PROCEDURE READARG(S: ARGSEQ; VAR ARG: ARGTYPE);
PROCEDURE WRITEARG(S: ARGSEQ; ARG: ARGTYPE);
PROCEDURE ACCEPT(VAR C:CHAR);
PROCEDURE DISPLAY(C: CHAR);
PROCEDURE MARK(VAR TOP: INTEGER);
PROCEDURE RELEASE(TOP: INTEGER);
PROCEDURE RUN(ID: IDENTIFIER; VAR PARAM: ARGLIST;
VAR LINE: INTEGER; VAR RESULT: PROGRESULT);
PROCEDURE EXIT;
PROCEDURE HALT;
PROCEDURE SET_TRACE(MASK: INTEGER; DEVICE:IDENTIFIER);
PROCEDURE PRINT_TRACE(ON: BOOLEAN);
FUNCTION IAND(MASK1, MASK2: UNIV INTEGER): INTEGER;
FUNCTION IOR(MASK1, MASK2: UNIV INTEGER): INTEGER;
FUNCTION XOR(MASK1, MASK2: UNIV INTEGER): INTEGER;
FUNCTION INV(MASK: UNIV INTEGER): INTEGER;
FUNCTION LEFTSHIFT(BITS: UNIV INTEGER; SHIFTS: INTEGER): INTEGER;
FUNCTION RIGHTSHIFT(BITS: UNIV INTEGER; SHIFTS: INTEGER): INTEGER;
FUNCTION GETBITS(BITS: UNIV INTEGER; LEFTMOST: BITPOSITION;
FIELDLENGTH: BITFIELDLENGTH): INTEGER;
PROCEDURE PUTBITS(FROM: UNIV INTEGER; VAR TO_: UNIV INTEGER;
LEFTTO: BITPOSITION; FIELDLENGTH: BITFIELDLENGTH);
FUNCTION TESTBIT(BITS: UNIV INTEGER; BITNUMBER: BITPOSITION): BOOLEAN;
PROCEDURE SETBIT(VAR BITS: UNIV INTEGER; BITNUMBER: BITPOSITION);
PROCEDURE CLEARBIT(VAR BITS: UNIV INTEGER; BITNUMBER: BITPOSITION);
PROCEDURE PACK(UNPACKED, PACKED: IDENTIFIER; NO_OF_BYTES: INTEGER);
PROCEDURE UNPACK(PACKED, UNPACKED: IDENTIFIER; NO_OF_BYTES: INTEGER);
PROCEDURE PACK_SWAPPED(UNPACKED, PACKED: IDENTIFIER; NO_OF_BYTES: INTEGER);
PROCEDURE UNPACK_SWAPPED(PACKED, UNPACKED: IDENTIFIER; NO_OF_BYTES: INTEGER);
PROCEDURE RESERVE_INTERRUPT(DEVPR: INTEGER; VAR INTRPT: INTEGER);
PROCEDURE RELEASE_INTERRUPT(INTRPT: INTEGER);
PROCEDURE CLEAR_INTERRUPT(INTRPT: INTEGER; VAR COUNT: INTEGER);
PROCEDURE WAIT_INTERRUPT(DELAY: INTEGER; INTRPT: INTEGER;
VAR TIMED_OUT: BOOLEAN; VAR COUNT: INTEGER);
PROCEDURE SENSE_IO(DEVICE: INTEGER; VAR STATUS: INTEGER);
PROCEDURE READ_IO(DEVICE: INTEGER; VAR DATA: INTEGER);
PROCEDURE CONTROL_IO(DEVICE: INTEGER; STATUS: INTEGER);
PROCEDURE WRITE_IO(DEVICE: INTEGER; DATA: INTEGER);
PROCEDURE SEND_MESSAGE(RECEIVER: PROCESS_NAME; MSG:UNIV MESSAGE_BUFFER;
VAR EVENT: INTEGER);
PROCEDURE SEND_ANSWER(ANS: UNIV MESSAGE_BUFFER; EVENT: INTEGER);
PROCEDURE WAIT_ANSWER(DELAY: INTEGER; EVENT: INTEGER;
VAR ANS: UNIV MESSAGE_BUFFER; VAR TIMED_OUT: BOOLEAN);
PROCEDURE WAIT_MESSAGE(DELAY: INTEGER; VAR MSG: UNIV MESSAGE_BUFFER;
VAR EVENT: INTEGER; VAR TIMED_OUT: BOOLEAN);
PROCEDURE WAIT_EVENT(DELAY: INTEGER; INTRPT: INTEGER;
VAR MSG: UNIV MESSAGE_BUFFER;
VAR EVENT: INTEGER; VAR EVTTYPE: EVENT_TYPE;
VAR COUNT: INTEGER; VAR TIMED_OUT: BOOLEAN);
PROCEDURE RESUME_EVENT;
PROCEDURE COPY(SOURCE, DEST: BYTE_ADDRESS; NO_OF_BYTES: INTEGER);
PROCEDURE GET_ABS_ADDR(STRUCTURE: LINE; VAR WORD_ADDR: WORD_ADDRESS);
PROCEDURE GET_ABS_ADDR1(STRUCTURE: LINE; VAR WORD_ADDR: WORD_ADDRESS);
PROCEDURE GET_ABS_ADDR2(STRUCTURE: LINE; VAR WORD_ADDR: WORD_ADDRESS);
FUNCTION CURRENT_LINE: INTEGER;
PROCEDURE CURRENT_LEVEL(VAR LEVEL: INTEGER);
PROCEDURE LONG_EXIT(LEVEL: INTEGER);
PROCEDURE ASSIGNBITS(VALUE: UNIV BITVALUE; VAR P: UNIV PAGE;
FIRSTBIT, NO_OF_BITS: INTEGER);
PROCEDURE SKIPBITS(VALUE: UNIV BITVALUE; P: UNIV PAGE;
VAR FIRSTBIT: INTEGER; NO_OF_BITS: INTEGER;
VAR BITSSKIPPED: INTEGER);
PROGRAM MAIN(VAR PARAM: ARGLIST);
"PAGE"\f
"****************************
* PASCAL I/O DECLARATIONS *
****************************"
CONST TEXT_SIZE=132;
TYPE TEXT=ARRAY[1..TEXT_SIZE] OF CHAR;
TYPE STREAM=(INOC,OUTOC,INFILE,OUTFILE);
TYPE DIRECTION=(INPUT,OUTPUT);
TYPE BYTE=0..255;
"----------------------------------------------------------------------"
CONST
SIZE_DISP = 4;
PRG_DISP = 23;
REF_DISP = 54;
BUF_DISP = 55;
CURIN_DISP = 90;
NAME_DISP = 7;
SHARE_TOP = #AF7;
SHARE_BOTTOM = #189;
REFLENGTH = 4;
BUFLENGTH = 9;
NEXT = 3;
PG_HEADERLENGTH = 31;
DRIVERHEADER = 13;
"----------------------------------------------------------------------"
TYPE
REF_BUFFER = ARRAY(.1..REFLENGTH.) OF INTEGER;
BUF_BUFFER = ARRAY(.1..BUFLENGTH.) OF INTEGER;
"----------------------------------------------------------------------"
VAR
REF,BUF,REFS,BUFS: INTEGER;
ABS_ADDRESS: INTEGER;
CONSOLE, SOURCE_STREAM, OBJECT_STREAM: STREAM;
FORTOLKER: BOOLEAN;
SOURCE_NAME, OBJECT_NAME, PROCESSNAME: IDENTIFIER;
PGHEAD: ARRAY(.0..PG_HEADERLENGTH.) OF INTEGER;
WORDS: INTEGER;
PG_SIZE, CONSTS, PR_SIZE, SHARE_SIZE: INTEGER;
ASS_SIZE, PROCESS_SIZE, PRG, REFREF, BUFREF: INTEGER;
GLCOUNT: INTEGER;
"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";
PROCEDURE OUTHEX(S:STREAM; CH: UNIV CHAR; INT: UNIV INTEGER);
VAR CTRL: INTEGER;
BEGIN
OUTBYTE(S,CH);
FOR CTRL:= 4 DOWNTO 1 DO
OUTBYTE(S,BIN_TO_ASCII(GETBITS(INT,4*CTRL-1,4)));
END "OUTHEX";
"----------------------------------------------------------------------"
PROCEDURE OUTWORD(INT: UNIV INTEGER);
"----------------------------------------------------------------------"
BEGIN
IF ABS_ADDRESS MOD 8 = 0
THEN BEGIN
OUTNL(OBJECT_STREAM);
OUTHEX(OBJECT_STREAM,SP,ABS_ADDRESS);
OUTSTRING(OBJECT_STREAM, 'L(:0:)');
END;
OUTHEX(OBJECT_STREAM,SP,INT);
ABS_ADDRESS:=ABS_ADDRESS+1;
END "OUTWORD" ;
"----------------------------------------------------------------------"
PROCEDURE MAKE_BUFS(VAR BUF: INTEGER; VAR BUFS: INTEGER);
"----------------------------------------------------------------------"
VAR B: BUF_BUFFER; I: INTEGER;
BEGIN
WHILE BUFS > 0 DO
BEGIN
FOR I:= 1 TO BUFLENGTH DO B(.I.):= 0;
BUF:= BUF+BUFLENGTH;
BUFS:= PRED(BUFS);
IF BUFS > 0 THEN B(.NEXT.):= BUF;
FOR I:=1 TO BUFLENGTH DO OUTWORD(B(.I.));
END;
END "MAKE_BUFS";
"----------------------------------------------------------------------"
PROCEDURE MAKE_REFS(VAR REF: INTEGER; VAR REFS: INTEGER);
"----------------------------------------------------------------------"
VAR R:REF_BUFFER; I: INTEGER;
BEGIN
WHILE REFS > 0 DO
BEGIN
FOR I:=1 TO REFLENGTH DO R(.I.):=0;
REF:= REF+REFLENGTH;
REFS:= PRED(REFS);
IF REFS > 0 THEN R(.NEXT.):= REF;
FOR I:=1 TO REFLENGTH DO
OUTWORD(R(.I.) );
END;
END "MAKE_REFS";
"----------------------------------------------------------------------"
PROCEDURE PRESET_INPUT(S: STREAM);
"----------------------------------------------------------------------"
VAR CHA: CHAR;
BEGIN
REPEAT
INBYTE(S,CHA)
UNTIL CHA = 'P';
GLCOUNT:= 0;
END "PRESET_INPUT";
"----------------------------------------------------------------------"
PROCEDURE RESET(VAR S:STREAM;NAME:TEXT;DIR:DIRECTION);
"----------------------------------------------------------------------"
BEGIN
CLOSE(S);
OPEN(S,NAME,DIR);
PRESET_INPUT(S);
END "RESET";
"----------------------------------------------------------------------"
PROCEDURE CHECKTYPE(TAG:ARGTAG;PARMTYPE:ARGTAG; PARM:INTEGER);
"----------------------------------------------------------------------"
BEGIN
IF TAG <> PARMTYPE
THEN BEGIN
OUTSTRING(CONSOLE,'PARAMETER (:0:)');
OUTINTEGER(CONSOLE,PARM,4);
OUTSTRING(CONSOLE,' IS OF ILLEGAL TYPE(:0:)');
OUTNL(CONSOLE);
HALT;
END " ERROR PRINTOUT"
END "CHECKTYPE";
"----------------------------------------------------------------------"
PROCEDURE INWORD(S: STREAM; VAR INT: INTEGER);
"----------------------------------------------------------------------"
BEGIN
IF GLCOUNT MOD 8 = 0 THEN INHEXA(S,INT);
INHEXA(S,INT);
GLCOUNT:= SUCC(GLCOUNT);
END "INWORD";
"----------------------------------------------------------------------"
PROCEDURE SKIP(COUNT: INTEGER);
"----------------------------------------------------------------------"
VAR I,INT: INTEGER;
BEGIN
FOR I:=1 TO COUNT DO INWORD(SOURCE_STREAM,INT);
END "SKIP";
"----------------------------------------------------------------------"
PROCEDURE TRANSFER(COUNT: INTEGER);
"----------------------------------------------------------------------"
VAR I,INT: INTEGER;
BEGIN
FOR I:=1 TO COUNT DO
BEGIN
INWORD(SOURCE_STREAM,INT);
OUTWORD(INT);
END
END "TRANSFER" ;
"----------------------------------------------------------------------"
PROCEDURE READ_PARAMETERS;
"----------------------------------------------------------------------"
VAR I: INTEGER;
BEGIN
FOR I:=1 TO 7 DO
BEGIN
WITH PARAM(.I.) DO
BEGIN
CASE I OF
1:
BEGIN CHECKTYPE(TAG,IDTYPE,I);
IF ID(.1.) = 'F' THEN FORTOLKER :=TRUE
ELSE FORTOLKER :=FALSE;
END;
2:
BEGIN CHECKTYPE(TAG,IDTYPE,I);
SOURCE_NAME:=ID;
END;
3:
BEGIN CHECKTYPE(TAG,IDTYPE,I);
OBJECT_NAME:=ID;
END;
4:
BEGIN CHECKTYPE(TAG,IDTYPE,I);
PROCESSNAME:=ID;
END;
5:
BEGIN CHECKTYPE(TAG,INTTYPE,I);
ABS_ADDRESS:= INT;
END;
6:
BEGIN CHECKTYPE(TAG,INTTYPE,I);
BUFS:= INT;
END;
7:
BEGIN CHECKTYPE(TAG,INTTYPE,I);
REFS:= INT;
END
END "CASE";
END "WITH PARAM";
END;
END "READ_PARAMETERS";
"----------------------------------------------------------------------"
PROCEDURE CALCULATE_DISPS;
"----------------------------------------------------------------------"
VAR I: INTEGER;
BEGIN
FOR I:=0 TO PG_HEADERLENGTH DO INWORD(SOURCE_STREAM,PGHEAD(.I.));
WORDS:=PGHEAD(.3.);
PG_SIZE:= PGHEAD(.4.);
IF FORTOLKER THEN CONSTS:=0 ELSE CONSTS:=PGHEAD(.31.);
PR_SIZE:=PGHEAD(.11.);
SHARE_SIZE:=SHARE_TOP - SHARE_BOTTOM;
ASS_SIZE:= PR_SIZE-CONSTS-SHARE_SIZE;
PROCESS_SIZE:= ASS_SIZE+CONSTS+WORDS+REFS*REFLENGTH+BUFS*BUFLENGTH;
PRG:= PROCESS_SIZE-DRIVERHEADER;
REF:= ASS_SIZE+CONSTS+WORDS-DRIVERHEADER;
BUF:= REF+REFS*REFLENGTH;
PGHEAD(.11.):= ASS_SIZE;
END "CALCULATE_DISPS";
"----------------------------------------------------------------------"
PROCEDURE GENERATE_HEADER;
"----------------------------------------------------------------------"
BEGIN
OUTNL(OBJECT_STREAM);
OUTSTRING(OBJECT_STREAM, 'Z(:0:)');
OUTHEX(OBJECT_STREAM,'0',ABS_ADDRESS);
OUTSTRING(OBJECT_STREAM,' T0000(:0:)');
OUTNL(OBJECT_STREAM);
OUTSTRING(OBJECT_STREAM,'P(:0:)');
OUTNL(OBJECT_STREAM);
END "GENERATE_HEADER";
"----------------------------------------------------------------------"
PROCEDURE WRITE_DRIVERPROCESS;
" GENERATES DRIVER PROCESS PART, I.E. FROM DRIVER HEADER UNTIL PG HEADR"
"----------------------------------------------------------------------"
VAR I: INTEGER;
BEGIN
SKIP(PG_SIZE-(PG_HEADERLENGTH+1));
TRANSFER(SIZE_DISP);
SKIP(1); OUTWORD(PROCESS_SIZE);
TRANSFER(NAME_DISP-SIZE_DISP-1);
PACK(PROCESSNAME,PROCESSNAME,6);
SKIP(3);
OUTWORD(PROCESSNAME(.1.));
OUTWORD(PROCESSNAME(.2.));
OUTWORD(PROCESSNAME(.3.));
TRANSFER(PRG_DISP-NAME_DISP-3);
SKIP(1); OUTWORD(PRG);
IF FORTOLKER THEN TRANSFER(1)
ELSE BEGIN SKIP(1); OUTWORD(256) END;
TRANSFER(REF_DISP-PRG_DISP-2);
SKIP(2);
OUTWORD(REF); OUTWORD(BUF);
TRANSFER(CURIN_DISP-REF_DISP-2);
SKIP(1); OUTWORD(0);
TRANSFER(ASS_SIZE-CURIN_DISP-1);
SKIP(SHARE_SIZE); TRANSFER(CONSTS);
FOR I:=1 TO WORDS DO OUTWORD(0);;
MAKE_REFS(REF,REFS);
MAKE_BUFS(BUF,BUFS);
END "WRITE_DRIVERPROCESS";
"----------------------------------------------------------------------"
PROCEDURE WRITE_DRIVERPROGRAM;
"----------------------------------------------------------------------"
VAR I: INTEGER;
BEGIN
FOR I:= 0 TO PG_HEADERLENGTH DO OUTWORD(PGHEAD(.I.));
RESET(SOURCE_STREAM,SOURCE_NAME,INPUT);
SKIP(PG_HEADERLENGTH+1);
TRANSFER(PG_SIZE-(PG_HEADERLENGTH+1));
END "WRITE_DRIVERPROGRAM";
"----------------------------------------------------------------------"
PROCEDURE GENERATE_TAIL;
"----------------------------------------------------------------------"
BEGIN
OUTNL(OBJECT_STREAM);
OUTSTRING(OBJECT_STREAM,'S(:0:)');
OUTNL(OBJECT_STREAM);
END "GENERATE_TAIL" ;
"----------------------------------------------------------------------"
" MAIN PROGRAM"
"----------------------------------------------------------------------"
BEGIN
OPEN(CONSOLE,'OC(:0:)',OUTPUT);
READ_PARAMETERS;
OPEN(SOURCE_STREAM,SOURCE_NAME,INPUT);
OPEN(OBJECT_STREAM,OBJECT_NAME,OUTPUT);
PRESET_INPUT(SOURCE_STREAM);
CALCULATE_DISPS;
GENERATE_HEADER;
WRITE_DRIVERPROCESS;
WRITE_DRIVERPROGRAM;
GENERATE_TAIL;
CLOSE(CONSOLE);
CLOSE(SOURCE_STREAM);
CLOSE(OBJECT_STREAM);
END.
«eof»