|
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: 5632 (0x1600) Types: TextFile Names: »TST0102.PAS«
└─⟦d814f614c⟧ Bits:30008872 EDB Trænings- og Erhvervs Center / Almen Nyttig Data Service └─⟦this⟧ »TST0102.PAS«
program test; const lf = @10; maxline = 132; loc_att = @28; bell = @7; delscr = 12; cr = @13; nul = @0; cmd = 'term'; var i, q, valg : integer; c : char; tekst : string(.maxline.); readtimeout : boolean; maxtry : boolean; f : file; res : integer; buf : string(.127.); type strform = string(.maxline.); pchar = ^char; procedure name(p:pchar; s:strform); var i : integer; begin p := ptr(ord(p)+13); (* nb! ikke flytbart *) for i := 1 to ord(s(.0.)) do begin p^ := s(.i.); p := ptr(ord(p) +1); end; end; function rdrstatus : boolean; var res : byte; begin code $2A,$01,$00, (* LD HL,(1) *) $01,$4A,$00, (* LD BC,04AH *) $09, (* ADD HL,BC *) $CD,*+7, (* CALL L1 *) $32,RES, (* LD (RES),A *) $18,1, (* JR L2 *) $E9; (* L1: JP (HL) *) (* L2: *) rdrstatus := (res = 255); end; function readchraux: char; var c : char; i : integer; begin i:=1; repeat i:=i+1 until rdrstatus or (i=1000); if i = 1000 then begin readtimeout:=true; readchraux := (chr(255)); end else begin read(aux,c); readchraux:=chr(ord(c) and 127); end; end; function readstraux: strform; var c : char; s : string(.maxline.); begin s:=''; repeat read(aux,c); c:=chr(ord(c) and 127); s:=s+c; until (c = lf) or (len(s) = maxline); readstraux:=s; end; procedure write_str_aux( s : strform ); var i : integer; begin s := s + cr + lf; for i := 1 to len(s) do begin write(aux,s(.i.)); c:= readchraux; end; end; procedure tryk_loc_att; var c : char; p : integer; begin readtimeout:=false; maxtry := false; p:=1; repeat if readtimeout then p := p + 1; write(aux,loc_att); readtimeout := false; repeat c:=readchraux; until readtimeout or (c=bell); until (c = bell) or (p = 5); if p= 5 then maxtry := true; end; procedure fejl( art : integer); begin gotoxy(0,0); write(chr(delscr)); gotoxy(10,10); writeln('DET ER IKKE MULIGT AT ETABLERE FORBINDELSE TIL DEN VALGTE MASKINE.'); gotoxy(10,11); writeln('KONTAKT VENLIGST BRUGERSERVICE FOR YDERLIGERE INFORMATION. '); gotoxy(10,12); write('FEJLEN KAN SPORES TIL : '); case art of 1 : writeln('FRONT-END. '); 2 : writeln('HOST UNKNOWN. '); 3 : writeln('RC8000. '); end; (* case *) end; BEGIN assign(f,'A:$$$.SUB'); name(ptr(ord(addr(f))),'$$$ SUB'); rewrite(f); if iores <> 0 then write('bad makefile') else begin gotoxy(0,0); write(chr(delscr)); writeln; writeln; writeln(' ** RC855 - RCNETMENU ** '); writeln; writeln(' 1: RCADM '); writeln; writeln(' 2: RCPA '); writeln; writeln(' 3: TELE-KUW1 '); writeln; writeln(' 4: TELE-KUW2 '); writeln; writeln(' 5: TELE-DEMO '); writeln; writeln(' 6: UDSALG '); writeln; writeln(' 7: BALMU1 '); writeln; writeln(' 8: BALMU2 '); writeln; writeln; write (' INDTAST NUMMER FOR VALG AF VÆRTSDATAMAT : '); read(valg); tryk_loc_att; if not maxtry then begin write_str_aux('re'); if false then begin tekst := readstraux; writeln(tekst); end; tryk_loc_att; if not maxtry then begin case valg of 1 : write_str_aux('se rcadm'); 2 : write_str_aux('se rcpa'); 3 : write_str_aux('se tele-kuw1'); 4 : write_str_aux('se tele-kuw2'); 5 : write_str_aux('se tele-demo'); 6 : write_str_aux('se udsalg'); 7 : write_str_aux('se balmu1'); 8 : write_str_aux('se balmu2'); end; (* case *) if rdrstatus then begin tekst := readstraux; if pos('ok',tekst) <> 0 then begin if rdrstatus then tekst := readstraux else begin write(aux,loc_att,'se'); if rdrstatus then tekst := readstraux else fejl(1); end; if pos('busy',tekst) <> 0 then fejl(3) else begin if pos('connected',tekst) = 0 then fejl(1) else begin q:=1; readtimeout := false; repeat while (readchraux <> bell) or readtimeout do; until (not readtimeout) or (q=5); if q=5 then fejl(3) else begin buf := cmd; buf(.ord(buf(.0.)) + 1 .) := chr(0); blockwrite(f,buf,1); end; end; end; end else fejl(2); end else fejl(1); end else fejl(1); end else fejl(1); close(f); end; END. «eof»