mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
148 lines
2.9 KiB
Plaintext
148 lines
2.9 KiB
Plaintext
$title ('SUBROUTINE MODULE - PART 2')
|
|
subr2:
|
|
do;
|
|
$include(:f1:macro.lit)
|
|
$INCLUDE (:F1:STRUC.LIT)
|
|
$include(:f1:io.ext)
|
|
|
|
/*
|
|
|
|
modified 3/26/81 R. Silberstein
|
|
modified 3/28/81 R. Silberstein
|
|
modified 3/30/81 R. Silberstein
|
|
|
|
*/
|
|
|
|
outtext: procedure (t) public;
|
|
dcl t addr,
|
|
ch based t byte;
|
|
do while ch <> 0;
|
|
call write$console(ch);
|
|
t=t+1;
|
|
end$while;
|
|
end outtext;
|
|
|
|
OUTFILENAME: PROCEDURE (PTR);
|
|
DECLARE PTR ADDRESS, X BASED PTR FILEOSTRUCTURE, I BYTE;
|
|
CALL WRITE$CONSOLE (X.DISK + 'A');
|
|
CALL WRITE$CONSOLE (':');
|
|
DO I = 1 TO 8;
|
|
IF (X.FCBBLOCK (I) AND 7FH) = SPACE THEN I = 8;
|
|
ELSE CALL WRITE$CONSOLE (X.FCBBLOCK (I) AND 7FH);
|
|
END;
|
|
CALL WRITE$CONSOLE ('.');
|
|
DO I = 9 TO 11;
|
|
CALL WRITE$CONSOLE (X.FCBBLOCK (I) AND 7FH);
|
|
END;
|
|
CALL SYSTEMRESET;
|
|
END OUTFILENAME;
|
|
|
|
FILEABORT: PROCEDURE (PTR, TEXTADR) PUBLIC;
|
|
DECLARE (PTR, TEXTADR) ADDRESS;
|
|
CALL OUTTEXT (TEXTADR);
|
|
CALL WRITE$CONSOLE (':');
|
|
CALL WRITE$CONSOLE (SPACE);
|
|
CALL OUTFILENAME (PTR);
|
|
END FILEABORT;
|
|
|
|
fill: procedure (ch,n,pt) public;
|
|
dcl (ch,n) byte,pt address,buffer based pt byte;
|
|
DO WHILE (N := N - 1) <> 0FFH;
|
|
buffer=ch;
|
|
pt = pt + 1;
|
|
end$while;
|
|
end fill;
|
|
|
|
digit: procedure(ch) byte public;
|
|
dcl ch byte;
|
|
IF CH < '0' THEN RETURN FALSE;
|
|
return (ch <= '9');
|
|
end digit;
|
|
|
|
letter: procedure(ch) byte public;
|
|
dcl ch byte;
|
|
IF CH < 'A' THEN RETURN FALSE;
|
|
return (ch <= 'Z');
|
|
end letter;
|
|
|
|
alphanumeric: proc(ch) byte public;
|
|
dcl ch byte;
|
|
if letter(ch) then return true;
|
|
return digit(ch);
|
|
end alphanumeric;
|
|
|
|
asciichar: proc (ch) byte public;
|
|
dcl ch byte;
|
|
if ch=cr then return true;
|
|
IF CH = LF THEN RETURN TRUE;
|
|
IF CH < SPACE THEN RETURN FALSE;
|
|
return (ch <= 7eh);
|
|
end asciichar;
|
|
|
|
|
|
upper: procedure(ch) byte public;
|
|
dcl ch byte;
|
|
if ch >= 61h THEN IF ch <= 7eh then ch=ch-20h;
|
|
return ch;
|
|
end upper;
|
|
|
|
equal: procedure(n,s,d) byte public;
|
|
dcl n byte,
|
|
(s,d) address,
|
|
sch based s byte,
|
|
dch based d byte;
|
|
DO WHILE (N := N - 1) <> 0FFH;
|
|
IF SCH <> DCH THEN RETURN FALSE;
|
|
S = S + 1;
|
|
D = D + 1;
|
|
END$WHILE;
|
|
return true;
|
|
end equal;
|
|
|
|
|
|
hex1out: procedure(n,d) public;
|
|
dcl n byte,d addr,
|
|
dest based d (1) byte;
|
|
hexdigit: procedure(digit) byte;
|
|
dcl digit byte;
|
|
digit=digit+'0';
|
|
if digit > '9' then digit=digit+7;
|
|
return digit;
|
|
end hexdigit;
|
|
|
|
dest(0)=hexdigit(SHR (N, 4));
|
|
dest(1)=hexdigit(n and 0fh);
|
|
end hex1out;
|
|
|
|
hex2out: proc (n,d) public;
|
|
dcl n addr,
|
|
d addr;
|
|
call hex1out(HIGH (N),d);
|
|
call hex1out(LOW (N),d+2);
|
|
end hex2out;
|
|
|
|
|
|
decout: proc (n,d) public;
|
|
dcl
|
|
n addr,
|
|
d address,
|
|
dest based d (1) byte,
|
|
(i,space$or$zero,digit) byte,
|
|
divis(5) addr data (10000,1000,100,10,1);
|
|
|
|
space$or$zero=space;
|
|
do i=0 to 4;
|
|
if i=4 then space$or$zero='0';
|
|
digit=n/divis(i);
|
|
n=n mod divis(i);
|
|
if digit=0 then$do
|
|
dest(i)=space$or$zero;
|
|
else$do
|
|
dest(i)=digit+'0';
|
|
space$or$zero='0';
|
|
end$if;
|
|
end$do;
|
|
end decout;
|
|
|
|
end subr2;
|