|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 16384 (0x4000) Types: TextFile Names: »DSIMTHF2.PAS«
└─⟦da1b76629⟧ Bits:30008866 Indeholder bla. RCKAT └─⟦this⟧ »DSIMTHF2.PAS«
(*$I-,R-,A+,O+,C-,V-*) PROGRAM DSIMT; LABEL IGEN,TEM; TYPE STRING14 = STRINGÆ14Å; STRING28 = STRINGÆ28Å; STRING80 = STRINGÆ80Å; DEFTYP = RECORD CLRSKM : STRING28; PAUSE : STRING28; SLUTTR : STRING28; SKIFT : STRING28; ADDLF : BOOLEAN; BURATE : INTEGER; TRTYPE : INTEGER; BFTYPE : INTEGER; TRANCH : INTEGER; FILLER : ARRAYÆ1..3Å OF CHAR; END; CONST CRTLTAB: ARRAYÆ1..31Å OF STRINGÆ3Å = ('SOH','STX','ETX','EOT','ENQ','ACK','BEL','BS','HT','LF','VT','FF', 'CR','SO','SI','DLE','DC1','DC2','DC3','DC4','NAK','SYN','ETB','CAN', 'EM','SUB','ESC','FS','GS','RS','US'); VAR DEF : DEFTYP; PAKCHR , BUFCUR , CH , CH1 , CH2 : CHAR; CONTROL , BUFNR , DEFBUF : INTEGER; BUFMIN , BUFMAX , BUFVP , BUFVC , BUFVL , BUFLIN , BUFELIN : ARRAYÆ1..2Å OF INTEGER; BUFPOS : ARRAYÆ1..2,1..230Å OF INTEGER; I,K,J,A,L,W,O, FLIN , LIN , FRA,TIL , PAKCNT , BUFPEG , SIDSTE , LCHECK : INTEGER; STR0 , STR1 , STR2 , FNAV , FILN : STRING14; VISSTR , INSTR : STRING80; BUFFER : ARRAYÆ1..26000Å OF CHAR; IOBUF : ARRAYÆ1..128Å OF CHAR; EKKO,CRTL, DUPR , LF_SW , CR_SW , OK_SW , CRLF_SW2 , CRLF_SW : BOOLEAN; FIL : FILE; PROCEDURE BUF_VRS(NR: INTEGER); BEGIN BUFVL ÆNRÅ:=1; BUFVP ÆNRÅ:=BUFMINÆNRÅ; BUFVC ÆNRÅ:=0; END; PROCEDURE BUF_RES(NR: INTEGER); BEGIN BUFLINÆNRÅ:=1; BUF_VRS(NR); END; PROCEDURE BUF_CLR(NR: INTEGER); BEGIN BUFMINÆNRÅ:=SIZE(BUFFER)*PRED(NR); BUFMAXÆNRÅ:=SIZE(BUFFER)*PRED(NR); BUFPOSÆNR,1Å:=SIZE(BUFFER)*PRED(NR); BUFELINÆNRÅ:=1; IF NR=1 THEN SIDSTE:=0 ELSE FNAV:=''; BUF_RES(NR); END; PROCEDURE SETBUF(TAL: INTEGER); BEGIN PAKCNT:=0; BUFPEG:=TAL; IF (BUFPEG>0) AND ((ORD(BUFFERÆBUFPEGÅ) AND $80)<>0) AND (DEF.BFTYPE<2) THEN PAKCHR:=CHR(ORD(BUFFERÆPRED(BUFPEG)Å) AND $7F) ELSE PAKCHR:=CHR(0); END; FUNCTION PUTBUF(CH: CHAR): BOOLEAN; PROCEDURE IND(B: BYTE); BEGIN IF BUFPEG<SIZE(BUFFER) THEN BEGIN BUFPEG:=SUCC(BUFPEG); BUFFERÆBUFPEGÅ:=CHR(B); END; IF B=10 THEN CRLF_SW:=TRUE; CR_SW:=FALSE; LF_SW:=FALSE; PAKCHR:=CHR(0); PUTBUF:=TRUE; END; BEGIN PUTBUF:=FALSE; CRLF_SW:=FALSE; IF DEF.BFTYPE<4 THEN BEGIN IF CH=PAKCHR THEN BEGIN BUFFERÆBUFPEGÅ:=CHR(SUCC(ORD(BUFFERÆBUFPEGÅ))); PUTBUF:=TRUE; END ELSE CASE CH OF @08: BEGIN IF PAKCHR=CHR(0) THEN BUFPEG:=PRED(BUFPEG) ELSE BEGIN BUFFERÆBUFPEGÅ:=CHR(PRED(ORD(BUFFERÆBUFPEGÅ))); IF BUFFERÆBUFPEGÅ=CHR($80) THEN BEGIN BUFPEG:=PRED(PRED(BUFPEG)); PAKCHR:=CHR(0); END; END; IF BUFPEG<0 THEN BUFPEG:=0; PUTBUF:=TRUE; LF_SW:=FALSE; CR_SW:=FALSE; END; @10: BEGIN IF CR_SW THEN IND(10) ELSE LF_SW:=TRUE; END; @12: BEGIN IND(13); IND(10); IND(12); CR_SW:=TRUE; END; @13: BEGIN IF NOT CR_SW THEN BEGIN IF LF_SW THEN BEGIN IND(13); IND(10); END ELSE IND(13); CR_SW:=TRUE; END; END; @32..@255: BEGIN IF (CH<>BUFFERÆBUFPEGÅ) OR (BUFPEG<=0) OR (DEF.BFTYPE>1) THEN IND(ORD(CH)) ELSE BEGIN BUFFERÆBUFPEGÅ:=CHR(ORD(BUFFERÆBUFPEGÅ) OR $80); IND($80+2); PAKCHR:=CH; END; PUTBUF:=TRUE; END; OTHERWISE IF NOT ODD(DEF.BFTYPE) THEN IND(ORD(CH)); END; END ELSE BEGIN CASE CH OF @32..@255: IND(ORD(CH)); OTHERWISE IF NOT ODD(DEF.BFTYPE) THEN IND(ORD(CH)); END; END; END; PROCEDURE GETBUF(VAR CH: CHAR); BEGIN IF PAKCNT=0 THEN BEGIN BUFPEG:=SUCC(BUFPEG); IF ((ORD(BUFFERÆBUFPEGÅ) AND $80)<>0) AND (DEF.BFTYPE<2) THEN BEGIN BUFPEG:=SUCC(BUFPEG); PAKCNT:=ORD(BUFFERÆBUFPEGÅ) AND $7F; END ELSE BEGIN CH:=BUFFERÆBUFPEGÅ; PAKCNT:=0; END; END; IF PAKCNT>0 THEN BEGIN PAKCNT:=PRED(PAKCNT); CH:=CHR(ORD(BUFFERÆPRED(BUFPEG)Å) AND $7F); END; END; PROCEDURE PUTCON(CH: CHAR); BEGIN WRITE(CH); END; FUNCTION GETCON(VAR CH: CHAR): BOOLEAN; BEGIN IF KEYPRESS THEN BEGIN GETCON:=TRUE; READ(KBD,CH); CH:=CHR(ORD(CH) AND $7F); END ELSE GETCON:=FALSE; END; PROCEDURE NYDISK; VAR G: INTEGER; BEGIN G:=BDOSB(25); BDOS(13); BDOS(14,G); END; PROCEDURE FIND(LIN: INTEGER); VAR I: INTEGER; BEGIN IF LIN<1 THEN BEGIN BUFPEG:=BUFPOSÆBUFNR,1Å; FLIN:=1; END ELSE BEGIN IF LIN>BUFELINÆBUFNRÅ THEN BEGIN BUFPEG:=BUFMAXÆBUFNRÅ; FLIN:=SUCC(BUFELINÆBUFNRÅ); END ELSE BEGIN I:=(PRED(LIN) DIV 20)+1; BUFPEG:=BUFPOSÆBUFNR,IÅ; FLIN:=I*20-19; WHILE FLIN<LIN DO BEGIN BUFPEG:=SUCC(BUFPEG); IF BUFFERÆBUFPEGÅ=CHR(10) THEN FLIN:=SUCC(FLIN); END; END; END; END; FUNCTION CONV(STR: STRING14): INTEGER; BEGIN CONV:=1; IF STR<>'B' THEN BEGIN IF STR='E' THEN BEGIN CONV:=BUFELINÆBUFNRÅ; END ELSE BEGIN IF COPY(STR,1,2)='E-' THEN BEGIN VAL(COPY(STR,3,LEN(STR)-2),I,J); IF J=0 THEN CONV:=BUFELINÆBUFNRÅ-I ELSE WRITE(CHR(07)); END ELSE BEGIN VAL(STR,I,J); IF J<>0 THEN WRITE(CHR(07)) ELSE IF I<=BUFELINÆBUFNRÅ THEN CONV:=I ELSE WRITE(CHR(07)); END; END; END; END; FUNCTION FRATIL: BOOLEAN; LABEL FTERR; BEGIN STR0:=''; STR1:=''; STR2:=''; FRATIL:=TRUE; WHILE (INSTRÆ1Å=' ') AND (INSTR<>'') DO DELETE(INSTR,1,1); WHILE INSTR<>'' DO BEGIN I:=POS(',',INSTR); IF I<>0 THEN BEGIN STR0:=COPY(INSTR,1,PRED(I)); DELETE(INSTR,1,I); END ELSE BEGIN STR0:=INSTR; INSTR:=''; END; IF STR0 = 'K' THEN BUFNR:=1 ELSE IF STR0 = 'F' THEN BUFNR:=2 ELSE IF STR0 = 'I' THEN CRTL:=FALSE ELSE IF STR0 = 'G' THEN EKKO:=TRUE ELSE IF (STR0 = '*') OR (STR0 = 'P') THEN DUPR:=TRUE ELSE IF STR1 = '' THEN STR1:=STR0 ELSE IF STR2 = '' THEN STR2:=STR0 ELSE GOTO FTERR; END; IF STR1='' THEN STR1:='B'; FRA:=CONV(STR1); IF STR2='' THEN STR2:='E'; TIL:=CONV(STR2); IF FRA>TIL THEN BEGIN FTERR: WRITELN(CHR(07),' Fejl i kommando !!'); FRATIL:=FALSE; END; END; PROCEDURE ERR; BEGIN WRITELN(CHR(07)); END; PROCEDURE DISP_HOP(L: INTEGER); VAR I,K: INTEGER; BEGIN FIND(L); SETBUF(BUFPEG); BUFLINÆBUFNRÅ:=FLIN; BUFVL ÆBUFNRÅ:=FLIN; BUFVP ÆBUFNRÅ:=BUFPEG; BUFVC ÆBUFNRÅ:=PAKCNT; LIN:=PRED(FLIN); I:=0; WHILE (LIN<BUFELINÆBUFNRÅ) AND (I<20) DO BEGIN I:=SUCC(I); LIN:=SUCC(LIN); IF I=1 THEN WRITE(DEF.CLRSKM) ELSE WRITELN; STR(LIN+10000:5,FILN); WRITE(COPY(FILN,2,4),' '); K:=0; CH:=CHR(0); WHILE ((BUFPEG<BUFMAXÆBUFNRÅ) OR (PAKCNT<>0)) AND (CH<>CHR(10)) DO BEGIN GETBUF(CH); IF K<70 THEN BEGIN IF CH>=' ' THEN BEGIN PUTCON(CH); K:=SUCC(K); END ELSE IF (CH<>CHR(10)) AND (CH<>CHR(13)) THEN BEGIN WRITE('<',CRTLTABÆORD(CH)Å,'>'); K:=K+2+LEN(CRTLTABÆORD(CH)Å); END; END; IF (K>=70) AND (K<>MAXINT) THEN BEGIN WRITE(' +'); K:=MAXINT; END; END; END; IF (LIN>=BUFELINÆBUFNRÅ) AND (BUFNR=2) THEN WRITE('<EOF>'); WRITELN; WRITELN; END; (*$I B:DSIMTINT *) (*$I B:DSIMTHLP *) (*$I B:DSIMTCPM *) (*$I B:DSIMTLSP *) PROCEDURE OPLYS; BEGIN WRITELN(BUFMAXÆ1Å-BUFMINÆ1Å:6,' Bytes brugt til kommunikations-buffer.'); WRITE (BUFMAXÆ2Å-BUFMINÆ2Å:6,' Bytes brugt til fil-buffer. '); IF FNAV ='' THEN WRITE('Ingen fil') ELSE WRITE('"',FNAV,'"'); WRITELN(' gemt.'); WRITELN(BUFMINÆ2Å-BUFMAXÆ1Å:6,' Bytes ledige.'); END; PROCEDURE VIS; BEGIN BUFPEG:=BUFVPÆBUFNRÅ; J:=BUFPEG; PAKCNT:=BUFVCÆBUFNRÅ; K:=PAKCNT; I:=0; WHILE ((BUFPEG<BUFMAXÆBUFNRÅ) OR (PAKCNT<>0)) AND (I<LEN(VISSTR)) DO BEGIN GETBUF(CH); I:=SUCC(I); CASE I OF 1: BEGIN IF CH=CHR(10) THEN BUFVLÆBUFNRÅ:=SUCC(BUFVLÆBUFNRÅ); IF CH<>VISSTRÆ1Å THEN I:=0; END; OTHERWISE IF I=2 THEN BEGIN IF (ORD(BUFFERÆBUFPEGÅ) AND $80)<>0 THEN BEGIN BUFVPÆBUFNRÅ:=BUFPEG; BUFVCÆBUFNRÅ:=SUCC(PAKCNT); END ELSE BEGIN BUFVPÆBUFNRÅ:=PRED(BUFPEG); BUFVCÆBUFNRÅ:=0; END; END; IF CH<>VISSTRÆIÅ THEN BEGIN BUFPEG:=BUFVPÆBUFNRÅ; PAKCNT:=BUFVCÆBUFNRÅ; I:=0; END; END; END; IF I=LEN(VISSTR) THEN BEGIN J:=BUFPEG; K:=PAKCNT; DISP_HOP(BUFVLÆBUFNRÅ); WRITELN('Strengen "',VISSTR,'" fundet i linie ',BUFVLÆBUFNRÅ); END ELSE WRITELN(CHR(07),' Strengen "',VISSTR,'" ikke fundet!!'); BUFVPÆBUFNRÅ:=J; BUFVCÆBUFNRÅ:=K; BUFVLÆBUFNRÅ:=BUFLINÆBUFNRÅ; END; PROCEDURE PUTMOD(CH: CHAR); BEGIN WRITE(AUX,CH); END; FUNCTION GETMOD(VAR CH: CHAR): BOOLEAN; VAR STATUS: INTEGER; BEGIN CODE $F3,$D3,$00,$3E,$00,$32,$08,$EF; STATUS:=MEMÆ$2A00Å; CODE $D3,$01,$3E,$01,$32,$08,$EF,$FB; IF (STATUS AND $01)<>0 THEN BEGIN READ(AUX,CH); IF DEF.BFTYPE<4 THEN CH:=CHR(ORD(CH) AND $7F); GETMOD:=TRUE; END ELSE GETMOD:=FALSE; END; PROCEDURE SETUP; BEGIN CONTROL:=64+DEF.TRTYPE*4; IF DEF.BURATE=1200 THEN CONTROL:=CONTROL+1 ELSE CONTROL:=CONTROL+2; CODE $F3,$D3,$00,$3E,$00,$32,$08,$EF; MEMÆ$2A00Å:=CONTROL; CODE $D3,$01,$3E,$01,$32,$08,$EF,$FB; CONTROL:=BDOSB(7); BDOS(8,((CONTROL AND $C3)+$14)); (* INIT RDR: OG PUN: TIL AUX *) END; FUNCTION TRANSMIT(FRA,TIL: INTEGER): BOOLEAN; LABEL UD,CONT; BEGIN FOR J:=1 TO 3000 DO IF GETMOD(CH) THEN ; FIND(SUCC(TIL)); K:=BUFPEG; FIND(FRA); SETBUF(BUFPEG); LCHECK:=3; WHILE (BUFPEG<K) OR (PAKCNT<>0) DO BEGIN; IF GETCON(CH) THEN BEGIN IF EKKO THEN BEGIN WRITELN; WRITELN; END; WRITE(CHR(07),' Afbrydelse !! ',SUCC(K-BUFPEG):5, ' Bytes tilbage i bufferen. Stop? (J/N): '); REPEAT UNTIL GETCON(CH) AND (CH IN Æ'J','N'Å); WRITELN(CH); IF CH = 'J' THEN BEGIN FOR J:=1 TO LEN(DEF.SLUTTR) DO PUTMOD(DEF.SLUTTRÆJÅ); WRITELN(' Transmittion stoppet.'); SIDSTE:=BUFMAXÆ1Å; TRANSMIT:=FALSE; GOTO UD; END; IF EKKO THEN WRITELN; END; GETBUF(CH); OK_SW:=CRTL; IF NOT CRTL THEN CASE CH OF @10,@13,@32..@127: OK_SW:=TRUE; END; IF OK_SW THEN BEGIN PUTMOD(CH); CASE DEF.TRANCH OF 1: IF LCHECK>0 THEN BEGIN IF CH=CHR(10) THEN LCHECK:=PRED(LCHECK); J:=0; WHILE J<1000 DO BEGIN J:=SUCC(J); IF GETMOD(CH2) THEN IF CH2<>CH THEN J:=1000 ELSE J:=MAXINT; END; IF (J=1000) AND (CH>=' ') THEN BEGIN FOR J:=1 TO LEN(DEF.SLUTTR) DO PUTMOD(DEF.SLUTTRÆJÅ); WRITELN(CHR(07), ' Transmittions-fejl / Linie ej klar !!'); SIDSTE:=BUFMAXÆ1Å; TRANSMIT:=FALSE; GOTO UD; END; END; 2: IF CH=CHR(10) THEN BEGIN J:=-32700; WHILE J<MAXINT DO BEGIN J:=SUCC(J); IF GETMOD(CH2) THEN BEGIN IF CH2=CHR(17) THEN GOTO CONT; END; END; FOR J:=1 TO LEN(DEF.SLUTTR) DO PUTMOD(DEF.SLUTTRÆJÅ); WRITELN(CHR(07), ' Transmittions-fejl / Linie ej klar !!'); SIDSTE:=BUFMAXÆ1Å; TRANSMIT:=FALSE; GOTO UD; CONT: END; END; IF EKKO THEN PUTCON(CH); END; END; WRITELN; WRITELN(' Transmittion færdig.'); J:=0; WHILE J<1000 DO BEGIN J:=SUCC(J); IF GETMOD(CH) THEN J:=0; END; FOR J:=1 TO LEN(DEF.SLUTTR) DO PUTMOD(DEF.SLUTTRÆJÅ); TRANSMIT:=TRUE; UD: END; PROCEDURE ONLINE; LABEL SLUT,LOOP; BEGIN SETBUF(SIDSTE); WHILE (BUFPEG<BUFMAXÆ1Å) OR (PAKCNT<>0) DO BEGIN GETBUF(CH); PUTCON(CH); END; CH:=CHR(0); SETBUF(BUFMAXÆ1Å); L:=BUFELINÆ1Å; O:=0; W:=MAXINT; LOOP: WHILE GETMOD(CH) AND (CH<>CHR(0)) DO BEGIN IF (O<>2) AND (SIZE(BUFFER)-BUFPEG<256) THEN BEGIN IF LEN(DEF.PAUSE)<>0 THEN BEGIN O:=2; W:=0; FOR I:=1 TO LEN(DEF.PAUSE) DO PUTMOD(DEF.PAUSEÆIÅ); END; END ELSE IF (O<>1) AND (BUFMINÆ2Å-BUFPEG<256) THEN BEGIN IF LEN(DEF.PAUSE)<>0 THEN BEGIN O:=1; W:=0; FOR I:=1 TO LEN(DEF.PAUSE) DO PUTMOD(DEF.PAUSEÆIÅ); END; END; IF PUTBUF(CH) THEN BEGIN IF CRLF_SW THEN BEGIN L:=SUCC(L); IF (PRED(L) MOD 20)=0 THEN BUFPOSÆ1,SUCC(PRED(L) DIV 20)Å:=BUFPEG; SIDSTE:=BUFPEG; BDOS(6,13); BDOS(6,10); END ELSE BDOS(6,ORD(CH)); CASE CH OF @08: WRITE(' ',CHR(08)); @13: IF DEF.ADDLF THEN BEGIN IF PUTBUF(CHR(10)) THEN ; IF CRLF_SW THEN BEGIN L:=SUCC(L); IF (PRED(L) MOD 20)=0 THEN BUFPOSÆ1,SUCC(PRED(L) DIV 20)Å:=BUFPEG; SIDSTE:=BUFPEG; BDOS(6,13); BDOS(6,10); END ELSE BDOS(6,ORD(CH)); END; END; IF W<>MAXINT THEN W:=0; END; END; IF W<>MAXINT THEN BEGIN W:=SUCC(W); IF W>5000 THEN BEGIN BUFMAXÆ1Å:=BUFPEG; WRITELN; WRITELN; OPLYS; WRITELN; WRITE(' Kommunikationsbuffer næsten fuld...',CHR(07)); W:=MAXINT; END; END; IF GETCON(CH) THEN BEGIN IF CH=DEF.SKIFTÆ1Å THEN GOTO SLUT; PUTCON(CH); PUTMOD(CH); END; GOTO LOOP; SLUT: BUFMAXÆ1Å:=BUFPEG; BUFELINÆ1Å:=L; WRITELN; IF DEFBUF=1