seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-26 09:54:20 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DA.PLM Normal file
View File

@@ -0,0 +1,75 @@
$title ('SDIR - Arithmetic')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
darithmetic:
do;
/* arithmetic module for extended directory */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
word lit 'address',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10';
add3byte: procedure(byte3adr,num) public;
dcl (byte3adr,num) address,
b3 based byte3adr structure (
lword address,
hbyte byte),
temp address;
temp = b3.lword;
if (b3.lword := b3.lword + num) < temp then /* overflow */
b3.hbyte = b3.hbyte + 1;
end add3byte;
/* add three byte number to 3 byte value structure */
add3byte3: procedure(totalb,numb) public;
dcl (totalb,numb) address,
num base<73> num<75> structur<75> (
lword address,
hbyte byte),
total based totalb structure (
lword address,
hbyte byte);
cal<61> add3byte(totalb,num.lword);
total.hbyte = num.hbyte + total.hbyte;
end add3byte3;
/* divide 3 byte value by 8 */
shr3byte: procedure(byte3adr) public;
dcl byte3adr address,
b3 based byte3adr structure (
lword address,
hbyte byte),
temp1 based byte3adr (2) byte,
temp2 byte;
temp2 = ror(b3.hbyte,3) and 11100000b; /* get 3 bits */
b3.hbyte = shr(b3.hbyte,3);
b3.lword = shr(b3.lword,3);
temp1(1) = temp1(1) or temp2; /* or in 3 bits from hbyte */
end shr3byte;
end darithmetic;


38
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DALL.SUB Normal file
View File

@@ -0,0 +1,38 @@
pip a:=dm.plm[g9]
seteof dm.plm
pip a:=sn.plm[g9]
seteof sn.plm
pip a:=dse.plm[g9]
seteof dse.plm
pip a:=dsh.plm[g9]
seteof dsh.plm
pip a:=dso.plm[g9]
seteof dso.plm
pip a:=da.plm[g9]
seteof da.plm
pip a:=dp.plm[g9]
seteof dp.plm
pip a:=dts.plm[g9]
seteof dts.plm
isx
plm80 dm.plm object(dm) debug nolist
plm80 sn.plm object(sn) debug nolist
plm80 dse.plm object(dse) debug nolist
plm80 dsh.plm object(dsh) debug nolist
plm80 dso.plm object(dso) debug nolist
plm80 dp.plm object(dp) debug nolist
plm80 da.plm object(da) debug nolist
plm80 dts.plm object(dts) debug nolist
link x0100,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d1.lnk
locate d1.lnk code(0100H) stacksize(50)
era d1.lnk
objhex d1 to d1.hex
link x0200,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d2.lnk
locate d2.lnk code(0200H) stacksize(50)
era d2.lnk
objhex d2 to d2.hex
cpm
objcpm d1
pip d.hex=d1.hex,d2.hex
genmod d.hex xsdir.prl


612
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DM.PLM Normal file
View File

@@ -0,0 +1,612 @@
$title ('Super Directory Command')
sdir:
do;
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
declare start label,
jump byte data (0c3h),
jadr address data (.start-3);
/<2F> <20> P <20> M - M P / M <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> <20> (SDIR<49> */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10',
tab lit '9';
declare cright (*) byte data (cr,lf,
'SDIR V1.0 ',
'Copyright(c) 1981 ',
'Digital Research ',
'Box 579 ',
'Pacific Grove, CA ',
'93950',01AH);
/* definitions for assembly interface module */
declare
fcb (33) byte external, /* default file control block */
maxb address external, /* top of memory */
buff(128)byte external; /* default buffer */
mon1: procedure(f,a) external;
declare f byte, a address;
end mon1;
mon2: procedure(f,a) byte external;
declare f byte, a address;
end mon2;
mon3: procedure(f,a) address external;
declare f byte, a address;
end mon3;
scan: procedure(pcb$adr) external;
declare pcb$adr address;
end scan;
scan$init: procedure(pcb$adr) external;
declare pcb$adr address;
end scan$init;
get$files: procedure external;
end get$files;
sort: procedure external;
end sort;
mult23: procedure (num) address external;
dcl num address;
end mult23;
show$files: procedure external;
end show$files;
printb: procedure external;
end printb;
print$char: procedure(c) external;
dcl c byte;
end print$char;
print: procedure(string$adr) external;
dcl string$adr address;
end print;
crlf: procedure external;
end crlf;
p$decimal: procedure(value,fieldsize,zsup) external;
dcl value address,
fieldsize address,
zsup boolean;
end p$decimal;
dcl debug boolean public initial (false);
/* version information */
dcl (os,bdos) byte public,
bdos20 lit '20H',
bdos30 lit '30H',
mpm lit '10H';
/* fcb and dma buffer constants */
declare
f$drvusr lit '0', /* drive/user byte */
f$name lit '1', /* file name */
fnamelen lit '8', /* file name length */
f$type lit '9', /* file type field */
ftypelen lit '3', /* type length */
f$rw lit '9', /* high bit is R/W attribute */
f$dirsys lit '10'; /* high bit is dir/sys attribute */
/* search variables */
dcl search$ops address public initial(0),/* search options or'd in here */
s$dir lit '1',
s$sys lit '2',
s$ro lit '4',
s$rw lit '8',
s$pass lit '16',
s$xfcb lit '32',
s$nonxfcb lit '64',
s$exclude lit '128';
dcl max$search$files lit '10', /* files to search for on each pass through */
num$s$files byte public initial(0), /* the directory */
search (max$search$files) structure(
name(8) byte,
type (3) byte,
drv byte,
anyfile byte ) public; /* if explicit drive byte has been given */
/* with the file spec : "A:JUNK.JNK" */
dcl file$info structure (
space(23) byte);
dcl get$all$dir$entries boolean public;
dcl end$adr address external;
dcl hash$table$len lit '128';
dcl hash$table(hash$table$len) address external;
dcl first$pass boolean public;
dcl usr$vector address public initial(0), /* bits for user #s to scan */
active$usr$vector address public, /* active users on curdrv */
drv$vector address initial (0); /* bits for drives to scan */
dcl form$short lit '0',
form$size lit '1',
form$full lit '2',
format byte public initial (form$full),
page$len address public initial (0), /* lines on a page before printing */
/* new headers, 0 forces initial hdrs */
message boolean public initial(false),/* show titles when no files found*/
formfeeds boolean public initial(false);/* use form feeds */
dcl file$displayed boolean external;
/* 1 or more files displayed by dsh.plm */
dcl sort$op boolean initial (true); /* default is to do sorting */
dcl sorted boolean external; /* if successful sort */
/* other globals */
dcl cur$usr byte public, /* current user being searched */
cur$drv byte public; /* current drive " " */
/* BDOS calls */
get$version: procedure address; /* returns current cp/m - mp/m version # */
return mon2(12,0);
end get$version;
select$drive: procedure(d);
declare d byte;
call mon1(14,d);
end select$drive;
search$first: procedure(d) byte external;
dcl d address;
end search$first;
search$next: procedure byte external;
end search$next;
get$cur$drv: procedure byte; /* return current drive number */
return mon2(25,0);
end get$cur$drv;
getlogin: procedure address; /* get the login vector */
return mon3(24,0);
end getlogin;
getusr: procedure byte; /* return current user number */
return mon2(32,0ffh);
end getusr;
terminate: procedure public;
if os = mpm then
call mon1(0,143); /* MP/M */
else
cal<61> mon<6F> (0,0)<29> /* CP/M */<2F>
end terminate;
/* Utility routines */
number: procedure (char) boolean;
dcl char byte;
return(char >= '0' and char <= '9');
end number;
make$numeric: procedure(char$adr,len,val$adr) boolean;
dcl (char$adr, val$adr, place) address,
chars based char$adr (1) byte,
value based val$adr address,
(i,len) byte;
value = 0;
place = 1;
do i = 1 to len;
if not number(chars(len - i)) then
return(false);
value = value + (chars(len - i) - '0') * place;
place = place * 10;
end;
return(true);
end make$numeric;
set$vec: procedure(v$adr,num) public;
dcl v$adr address, /* set bit number given by num */
vector based v$adr address, /* 0 <= num <= 15 */
num byte;
if num = 0 then
vector = vector or 1;
else
vector = vector or shl(double(1),num);
end set$vec;
bit$loc: procedure(vector) byte;
/* return location of right most on bit vector */
dcl vector address, /* 0 - 15 */
i byte;
i = 0;
do while i < 16 and (vector and double(1)) = 0;
vector = shr(vector,1);
i = i + 1;
end;
return(i);
end bit$loc;
get$nxt: procedure(vector$adr) byte;
dcl i byte,
(vector$adr,mask) address,
vector based vector$adr address;
if debug then
do; call print(.(cr,lf,'getnxt: vector = $'));
call pdecimal(vector,10000,false);
end;
if (i := bit$loc(vector)) > 15 then
return(0ffh);
mask = 1;
if i > 0 then
mask = shl(mask,i);
vector = vector xor mask; /* turn off bit */
if debug then
do; call print(.(cr,lf,'getnxt: vector, i, mask $'));
call pdecimal(vector,10000,false);
call printb;
call pdecimal(i,10000,false);
call printb;
call pdecimal(mask,10000,false);
end;
return(i);
end get$nxt; /* too bad plm rotates only work on byte values */
dcl t$null lit '0',
t$param lit '1',
t$op lit '2',
t$mod lit '4',
t$identifier lit '8',
t$string lit '16',
t$numeric lit '32',
t$filespec lit '64',
t$error lit '128';
dcl pcb structure (
state address,
scan$adr address,
token$adr address,
tok$typ byte,
token$len byte,
p$level byte,
nxt$token byte) initial (0,.buff(0),.fcb(0),0,0,0,0) ;
help: procedure; /* show options for this program */
call print(.(cr,lf,
tab,tab,tab,'SDIR EXAMPLES',cr,lf,lf,
'sdir file.one',tab,tab,tab,
'(find a file on current user and default drive)',cr,lf,
'sdir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)',
cr,lf,
'sdir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf,
'sdir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf,
'sdir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf,
'sdir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf,
'sdir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf,
'sdir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf,
'sdir [full]',tab,tab,tab,'(show all file information)',cr,lf,
'sdir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf,
'sdi<64> [short]',tab<61>tab,tab,'(sho<68> jus<75> th<74> fil<69> names)',cr,lf,
'sdir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf,
'sdir [drive = (a,b,p)]',tab,tab,
'(search specified drives, ''disk'' is synonym)',cr,lf,
'sdir [user = all]',tab,tab,'(find files with any user number)',cr,lf,
'sdir [user = (0,1,15)]',tab,tab,'(find files with specified user number)',
cr,lf,
'sdir [length = n]',tab,tab,'(print headers every n lines)',cr,lf,
'sdir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf,
'sdir [message user=all]',tab,tab,'(show user/drive areas with no files)',
cr,lf,
'sdir [help]',tab,tab,tab,'(show this message)',cr,lf,
'sdir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$'));
call terminate;
end help;
dcl token based pcb.token$adr (12) byte;
dcl got$options boolean;
get$options: procedure;
dcl temp byte;
do while pcb.scan$adr <> 0ffffh and ((pcb.tok$typ and t$op) <> 0);
if pcb.nxt$token <> t$mod then
do; /* options with no modifiers */
if token(1) = 'D' and token(2) = 'I' then
search$ops = search$ops or s$dir;
/* else if token(1) = 'D' and token(2) = 'E' then
debug = true; */
else if token(1) = 'E' then
search$ops = search$ops or s$exclude;
else if token(1) = 'F'then
if token(2) = 'F' then
formfeeds = true;
else if token(2) = 'U' then
format = form$full;
else goto op$err;
else if token(1) = 'H' then
call help;
else if token(1) = 'M' then
message = true;
else if token(1) = 'N' then
if token(4) = 'X' then
search$ops = search$ops or s$nonxfcb;
else if token(3) = 'S' then
sort$op = false;
else goto op$err;
else if token(1) = 'P' then
search$ops = search$ops or s$pass;
else if token(1) = 'S' then
if token(2) = 'Y' then
search$ops = search$ops or s$sys;
else if token(2) = 'H' then
format = form$short;
else if token(2) = 'I' then
format = form$size;
else if token(2) = 'O' then
sort$op = true;
else goto op$err;
else if token(1) = 'R' and token(2) = 'O' then
search$ops = search$ops or s$ro;
else if token(1) = 'R' and token(2) = 'W' then
search$ops = search$ops or s$rw;
else if token(1) = 'X' then
search$ops = search$ops or s$xfcb;
else goto op$err;
call scan(.pcb);
end;
else
do; /* options with modifiers */
if token(1) = 'L' then
do;
call scan(.pcb);
if (pcb.tok$typ and t$numeric) <> 0 then
if make$numeric(.token(1),pcb.token$len,.page$len) then
if page$len < 5 then
goto op$err;
else call scan(.pcb);
else goto op$err;
else goto op$err;
end;
else if token(1) = 'U' then
do;
if debug then
call print(.(cr,lf,'In User option$'));
call scan(.pcb);
if ((pcb.tok$typ and t$mod) = 0) or bdos < bdos20 then
goto op$err;
do while (pcb.tok$typ and t$mod) <> 0 and
pcb.scan$adr <> 0ffffh;
if token(1) = 'A' and token(2) = 'L' then
usr$vector = 0ffffh;
else if (pcb.tok$typ and t$numeric) <> 0
and pcb.token$len < 3 then
do;
if pcb.token$len = 1 then
temp = token(1) - '0';
else
temp = (token(1) - '0') * 10 + (token(2) - '0');
if temp >= 0 and temp <= 15 then
call set$vec(.usr$vector,temp);
else goto op$err;
end;
else goto op$err;
call scan(.pcb);
end;
end;
else if token(1) = 'D' and (token(2) = 'R' or token(2) = 'I') then
do; /* allow DRIVE or DISK */
call scan(.pcb);
if (pcb.tok$typ and t$mod) = 0 then
goto op$err;
do while (pcb.tok$typ and t$mod ) <> 0 and
pcb.scan$adr <> 0ffffh;
if token(1) = 'A' and token(2) = 'L' then
do;
drv$vector = 0ffffh;
drv$vector = drv$vector and get$login;
end;
else if token(1) >= 'A' and token(1) <= 'P' then
call set$vec(.drv$vector,token(1) - 'A');
else goto op$err;
call scan(.pcb);
end;
end; /* drive option */
else goto op$err;
end; /* options with modifiers */
end; /* do while */
got$options = true;
return;
op$err:
call print(.('Illegal Option or Modifier$'));
call terminate;
end get$options;
get$file$spec: procedure;
dcl i byte;
if num$s$files < max$search$files then
do;
call move(f$namelen + f$typelen,.token(1),
.search(num$s$files).name(0));
if search(num$s$files).name(f$name - 1) = ' ' and
search(num$s$files).name(f$type - 1) = ' ' then
search(num$s$files).anyfile = true; /* match on any file */
else search(num$s$files).anyfile = false;
if token(0) = 0 then
search(num$s$files).drv = 0ffh; /* no drive letter with */
else /* file spec */
search(num$s$files).drv = token(0) - 1;
/* 0ffh in drv field indicates to look on all drives that will be */
/* scanned as set by the "drive =" option, see "match:" proc in */
/* dsearch module */
num$s$files = num$s$files + 1;
end;
else
do; call print(.('File Spec Limit is $'));
call p$decimal(max$search$files,100,true);
call crlf;
end;
call scan(.pcb);
end get$file$spec;
set$defaults: procedure;
/* set defaults if not explicity set by user */
if ((search$ops and s$dir) = 0 and (search$ops and s$sys) = 0) then
search$ops = search$ops or s$dir or s$sys;
if ((search$ops and s$ro) = 0 and (search$ops and s$rw) = 0) then
search$ops = search$ops or s$rw or s$ro;
if ((search$ops and s$xfcb) <> 0 or (search$ops and s$nonxfcb) <> 0) then
do; if format = form$short then
format = form$full;
end;
else /* both xfcb and nonxfcb are off */
search$ops = search$ops or s$nonxfcb or s$xfcb;
if num$s$files = 0 then
do;
search(num$s$files).anyfile = true;
search(num$s$files).drv = 0ffh;
num$s$files = 1;
end;
if drv$vector = 0 then
do i = 0 to num$s$files - 1;
if search(i).drv = 0ffh then search(i).drv = cur$drv;
call set$vec(.drv$vector,search(i).drv);
end;
else /* a "[drive =" option was found */
do i = 0 to num$s$files - 1;
if search(i).drv <> 0ffh and search(i).drv <> cur$drv then
do; call print(.('Illegal Global/Local Drive Spec Mixing$'));
call terminate;
end;
end;
if usr$vector = 0 then
call set$vec(.usr$vector,get$usr);
end set$defaults;
dcl (save$uvec,temp) address;
dcl i byte;
declare last$dseg$byte byte
initial (0);
start:
os = high(get$version);
bdos = low(get$version);
/* note - initialized declarations set defaults */
cur$drv = get$cur$drv;
call scan$init(.pcb);
call scan(.pcb);
got$options = false;
do while pcb.scan$adr <> 0ffffh;
if (pcb.tok$typ and t$op) <> 0 then
if got$options = false then
call get$options;
else
do;
call print (.('Only One Set of Options Allowed$'));
call terminate;
end;
else if (pcb.tok$typ and t$filespec) <> 0 then
call get$file$spec;
else
do;
call print(.('Illegal File Spec$'));
call terminate;
end;
end;
call set$defaults;
/* call set$mem$buffer; allocate memory on 8086 if ever needed */
end$adr = .hash$table + size(hash$table) - size(file$info);
/* end$adr is a constant, set here and used by dshow to find the */
/* end of the file$info records when not sorted */
/* main control loop */
do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh;
call select$drive(cur$drv);
save$uvec <20> usr$vector; /* user numbers to search on each drive*/
active$usr$vector = 0; /* users active on cur$drv */
cur$usr = get$nxt(.usr$vector); /* get first user num and mask */
get$all$dir$entries = false; /* off it off */
if usr$vector <> 0 then /* find high water mark if */
do; /* more than one user requested */
fcb(f$drvusr) = '?';
i = search$first(.fcb); /* get first directory entry */
temp = 0;
do while i <> 255;
temp = temp + 1;
i = search$next;
end; /* is there enough space in the */
/* worst case ? */
if maxb > mult23(temp + 1) + shl(temp,1) then
get$all$dir$entries = true; /* location of last possible */
end; /* file info record and add */
first$pass = true; /* room for sort indices */
active$usr$vector = 0ffffh;
do while cur$usr <> 0ffh;
if debug then
call print(.(cr,lf,'in user loop $'));
call set$vec(.temp,cur$usr);
if (temp and active$usr$vector) <> 0 then
do;
if format <> form$short and
(first$pass or not get$all$dir$entries) then
do;
call getfiles; /* collect files in memory and */
first$pass = false; /* build the active usr vector */
sorted = false; /* sort module will set sorted */
if sort$op then /* to true, if successful sort */
call sort;
end;
call show$files;
end;
cur$usr = get$nxt(.usr$vector);
end;
usr$vector = save$uvec; /* restore user vector for nxt */
end; /* do while drv$usr drive scan */
if not file$displayed and not message then
call print(.('File Not Found.$'));
error:
call terminate;
end;


133
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DP.PLM Normal file
View File

@@ -0,0 +1,133 @@
$title ('SDIR - Print')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
dprint:
do;
/* print routines for extended directory */
declare dcl literally 'declare',
lit literally 'literally',
word lit 'address',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10';
mon1: procedure(f,a) external;
declare f byte, a address;
end mon1;
dcl debug byte external;
break: procedure external;
end break;
/* fcb and dma buffer constants */
declare
f$name lit '1', /* file name */
fnamelen lit '8', /* file name length */
f$type lit '9', /* file type field */
f$typelen lit '3'; /* type length */
/* BDOS calls */
print$char: procedure(char) public;
declare char byte;
call mon1(2,char);
end print$char;
print: procedure(string$adr) public;
dcl string$adr address;
call mon1(9,string$adr);
if debug then
call break;
end print;
printb: procedure public;
call print$char(' ');
end printb;
crlf: procedure public;
call print$char(cr);
call print$char(lf);
end crlf;
printfn: procedure(fname$adr) public;
dcl fname$adr address,
file$name based fname$adr (1) byte,
i byte; /* <filename> ' ' <filetype> */
do i = 0 to f$namelen - 1;
call printchar(file$name(i) and 7fh);
end;
call printchar(' ');
do i = f$namelen to f$namelen + f$typelen - 1;
call printchar(file$name(i) and 7fh);
end;
end printfn;
pdecimal: procedure(v,prec,zerosup) public;
/* print value v, field size = (log10 prec) + 1 */
/* with leading zero suppression if zerosup = true */
declare v address, /* value to print */
prec address, /* precision */
zerosup boolean, /* zero suppression flag */
d byte; /* current decimal digit */
do while prec <> 0;
d = v / prec; /* get next digit */
v = v mod prec; /* get remainder back to v */
prec = prec / 10; /* ready for next digit */
if prec <> 0 and zerosup and d = 0 then
call printb;
else
do;
zerosup = false;
call printchar('0'+d);
end;
end;
end pdecimal;
p3byte: procedure(byte3adr,prec) public;
/* print 3 byte value with 0 suppression */
dcl byte3adr address, /* assume high order bit is < 10 */
prec address,
b3 based byte3adr structure (
lword address,
hbyte byte),
i byte;
/* prec = 1 for 6 chars, 2 for 7 */
if b3.hbyte <> 0 then
do;
call pdecimal(b3.hbyte,prec,true); /* 3 for 8 chars printed */
call pdecimal(b3.lword,10000,false);
end;
else
do;
i = 1;
do while i <= prec;
call printb;
i = i * 10;
end;
call pdecimal(b3.lword,10000,true);
end;
end p3byte;
end dprint;


489
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DSE.PLM Normal file
View File

@@ -0,0 +1,489 @@
$title ('SDIR - Search')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
dsearch:
do;
/* search module for extended dir */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
word lit 'address',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10';
/* definitions for assembly interface module */
declare
maxb address external, /* addr field of jmp BDOS */
fcb (33) byte external, /* default file control block */
fcb16(16)byte external,
tbuff(128)byte external,
buff(128)byte external; /* default buffer */
mon1: procedure(f,a) external;
declare f byte, a address;
end mon1;
mon2: procedure(f,a) byte external;
declare f byte, a address;
end mon2;
mon3: procedure(f,a) address external;
declare f byte, a address;
end mon3;
dcl debug boolean external;
/* version information */
dcl (os,bdos) byte external,
bdos20 lit '20H',
bdos30 lit '30H',
mpm lit '10H';
dcl first$pass boolean external;
dcl get$all$dir$entries boolean external;
dcl usr$vector address external;
dcl active$usr$vector address external;
dcl used$de address public; /* used directory entries */
dcl filesfound address public; /* num files collected in memory */
/* fcb and dma buffer constants */
declare
sectorlen lit '128', /* sector length */
f$drvusr lit '0', /* drive and user byte */
f$name lit '1', /* file name */
fnamelen lit '8', /* file name length */
f$type lit '9', /* file type field */
f$typelen lit '3', /* type length */
f$rw lit '9', /* high bit is R/W attribute */
f$dirsys lit '10', /* high bit is dir/sys attribute */
f$arc lit '11', /* high bit is archive attribute */
f$ex lit '12', /* extent */
f$s1 lit '13', /* module byte */
f$rc lit '15', /* record count */
f$diskmap lit '16', /* file disk map */
diskmaplen lit '16', /* disk map length */
f$drvusr2 lit '16', /* fcb2 */
f$name2 lit '17',
f$type2 lit '25',
f$rrec lit '33', /* random record */
f$rreco lit '35'; /* " " overflow */
declare
deleted$type lit '0E5H';
declare /* XFCB */
xfcb$type lit '10h', /* identifier on disk */
xf$passmode lit '12', /* pass word protection mode */
xf$pass lit '16', /* XFCB password */
passlen lit '8', /* password length */
xf$create lit '24', /* creation/access time stamp */
xf$update lit '28'; /* update time stamp */
declare /* directory label: special case of XFCB */
dirlabeltype lit '20h', /* identifier on disk */
dl$password lit '128', /* masks on data byte */
dl$access lit '64',
dl$update lit '32',
dl$makexfcb lit '16',
dl$exists lit '1';
/* search variables */
dcl search$ops address external, /* search options or'd in here */
s$dir lit '1',
s$sys lit '2',
s$ro lit '4',
s$rw lit '8',
s$pass lit '16',
s$xfcb lit '32',
s$nonxfcb lit '64',
s$exclude lit '128';
dcl format byte external,
form$short lit '0';
dcl max$search$files lit '10', /* files to search for on each pass through */
num$s$files byte external, /* the directory */
search (max$search$files) structure(
name(8) byte,
type(3) byte,
drv byte,
anyfile boolean) external;
/* logical drive information */
/* function call 32 in 2.0 or later BDOS, returns the address of the disk
parameter block for the currently selected disk, which consists of:
spt (2 bytes) number of sectors per track
blkshf (1 byte) log2 of blocksize (2**blkshf=blksize)
blkmsk (1 byte) 2**blkshf-1
extmsk (1 byte) logical/physical extents
blkmax (2 bytes) max alloc number
dirmax (2 bytes) size of directory-1
dirblk (2 bytes) reservation bits for directory
chksiz (2 bytes) size of checksum vector
offset (2 bytes) offset for operating system
*/
dcl dpb$adr address public, /* disk parameter block address */
dpb based dpb$adr structure
(spt address, blkshf byte, blkmsk byte, extmsk byte, blkmax address,
dirmax address, dirblk address, chksiz address, offset address),
bytes$per$block address; /* bytes per block */
/* other globals */
dcl cur$usr byte external,
cur$drv byte external, /* current drive " " */
dir$label byte public; /* directory label for BDOS 3.0 */
/* error flags */
/* BDOS calls */
read$char: procedure byte;
return mon2 (1,0);
end read$char;
print: procedure(string$adr) external;
dcl string$adr address;
end print;
print$char: procedure(char) external;
dcl char byte;
end print$char;
pdecimal:procedure(val,prec,zsup) external;
dcl (val, prec) address;
dcl zsup boolean;
end pdecimal;
printfn: procedure(fnameadr) external;
dcl fnameadr address;
end printfn;
check$console$status: procedure byte;
return mon2 (11,0);
end check$console$status;
search$first: procedure (fcb$address) byte public;
declare fcb$address address;
return mon2 (17,fcb$address);
end search$first;
search$next: procedure byte public;
return mon2 (18,0);
end search$next;
get$dpb: procedure address; /* return base of dpb */
return mon3(31,0);
end get$dpb;
terminate: procedure external;
end terminate;
set$vec: procedure(vector,value) external;
dcl vector address,
value byte;
end set$vec;
mult23: procedure (f$i$num) address external;
dcl f$i$num address;
end mult23;
/* Utility routines */
crlf: procedure external; /* print carriage return, linefeed */
end crlf;
set$drive: procedure public; /* base of disk parm block for the */
dpb$adr = get$dpb; /* currently selected drive */
bytes$per$block = shl(double(1),dpb.blkshf) * sectorlen;
end set$drive;
break: procedure public;
dcl x byte;
if check$console$status then
do;
x = read$char;
call terminate;
end;
end break;
number: procedure (char) boolean;
dcl char byte;
return(char >= '0' and char <= '9');
end number;
add3byte: procedure(byte3adr,num) external;
dcl (byte3adr,num) address;
end add3byte;
/* add three byte number to 3 byte accumulater */
add3byte3: procedure(totalb,numb) external;
dcl (totalb,numb) address;
end add3byte3;
/* divide 3 byte value by 8 */
shr3byte: procedure(byte3adr) external;
dcl byte3adr address;
end shr3byte;
add$block: procedure(ak,ab);
declare (ak, ab) address;
/* add one block to the kilobyte accumulator */
declare kaccum based ak address; /* kilobyte accum */
declare baccum based ab address; /* byte accum */
baccum = baccum + bytes$per$block;
do while baccum >= 1024;
baccum = baccum - 1024;
kaccum = kaccum + 1;
end;
end add$block;
declare
buf$fcb$adr address public, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(f$i$adr, end$adr, last$f$i$adr) address public,
/* indices into file$info array */
file$info based f$i$adr structure(
usr byte, /* user number */
name (8) byte,
type (3) byte,
bytes address, /* byte count (mod kilobyte) */
kbytes address, /* kilobyte count */
recs$lword address, /* record count is 3 byte value */
recs$hbyte byte, /* low word, high byte */
hash$link address, /* link for collison */
x$i$adr address), /* index into time stamp array for */
/* this file */
x$i$adr address public,
xfcb$info based x$i$adr structure (
create (4) byte,
update (4) byte,
passmode byte);
compare: procedure(length, str1$adr, str2$adr) boolean;
dcl (length,i) byte,
(str1$adr, str2$adr) address,
str1 based str1$adr (1) byte,
str2 based str2$adr (1) byte;
do i = 0 to length - 1;
if ((str1(i) and 7fh) <> (str2(i) and 7fh)) and str2(i) <> '?' then
return(false);
end;
return(true);
end compare;
match: procedure boolean public;
dcl i byte,
temp word;
if (i := (buf$fcb(f$drvusr) and 0fh)) <> cur$usr then
if not get$all$dir$entries then /* Not looking for this user */
return(false); /* and not buffering all other*/
else /* specified user files on */
do; temp = 0; /* this drive. */
call set$vec(.temp,i);
if (temp and usr$vector) = 0 then /* Getting all dir entries, */
return(false); /* with user number corresp'g */
end; /* to a bit on in usr$vector */
if usr$vector <> 0 then
if i <> 0 and first$pass and usr$vector <> 0 then
call set$vec(.active$usr$vector,i);
/* build active usr vector for this drive */
do i = 0 to num$s$files - 1;
if search(i).drv = 0ffh or search(i).drv = cur$drv then
/* match on any drive if 0ffh */
if search(i).anyfile = true then
return((search$ops and s$exclude) = 0);
else if compare(11,.buf$fcb(f$name),.search(i).name(0)) then
return((search$ops and s$exclude) = 0);
end;
return((search$ops and s$exclude) <> 0);
end match;
dcl hash$table$size lit '128', /* must be power of 2 */
hash$tabl<62> (hash$table$size<7A> address public at (.memory),
/* must be initialized on each*/
hash$entry$adr address, /* disk scan */
hash$entry based hash$entry$adr address; /* where to put a new entry's */
/* address */
hash$look$up: procedure boolean;
dcl (i,found,hash$index) byte;
hash$index = 0;
do i = f$name to f$namelen + f$typelen by 2;
hash$index = hash$index + (buf$fcb(i) and 7fh); /* attributes may */
end; /* only be set w/ 1st extent */
hash$index = hash$index + cur$usr;
hash$index = hash$index and (hash$table$size - 1);
hash$entry$adr = .hash$table(hash$index);
f$i$adr = hash$table(hash$index);
found = false;
do while f$i$adr <> 0 and not found;
if file$info.usr = (buf$fcb(f$drvusr) and 0fh) and
compare(f$namelen + f$typelen,.file$info.name(0),.buf$fcb(f$name))
then
found = true;
else
do; hash$entry$adr = .file$info.hash$link; /* assuming no '?' */
f$i$adr = file$info.hash$link; /* in file name */
end;
end;
if f$i$adr = 0 then
return(false);
else return(true);
end hash$look$up;
store$file$info: procedure boolean;
/* Look for file name of last found fcb or xfcb in fileinfo */
/* array, if not found put name in fileinfo array. Copy other */
/* info to fileinfo or xfcbinfo. The lookup is hash coded with */
/* collisions handled by linking up file$info records through */
/* the hash$link field of the previous file$info record. */
/* The file$info array grows upward in memory and the xfcbinfo */
/* grows downward. */
/*
-------------------------<---.memory
__ | HASH TABLE |
hash = \ of filename -->| root of file$info list|------------>---|
func /__ letters | . | |
| . | |
lower memory ------------------------- |
| file$info entry | |
-----<--| . | <--------------|
(collision) | | . |
------->| . |
| . |-------------------->|
| last file$info entry | <- last$f$i$adr |
|-----------------------| |
| | |
| | |
| unused by dsearch, | |
| used by dsort | |
| for indices | |
| | |
| | |
|-----------------------| |
| last$xfcb entry | <- x$i$adr |
| . | |
| . | |
| . | <-------------------|
| first xfcb entry |
|-----------------------|
| un-usuable memory | <- maxb
higher memory ------------------------- */
dcl (i, j) byte,
block$num address;
if not hash$look$up then /* not in table already */
/* hash$entry is where to put adr of new entry */
do; /* copy to new position in file info array */
if f$i$adr + 2 * size(file$info) > x$i$adr then
return(false); /* out of memory */
f$i$adr = (last$f$i$adr := last$f$i$adr + size(file$info));
filesfound = filesfound + 1;
call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name);
file$info.usr = buf$fcb(f$drvusr) and 0fh;
file$info.bytes,file$info.kbytes,file$info.recs$lword,
file$info.recs$hbyte, file$info.x$i$adr,file$info.hash$link = 0;
hash$entry = f$i$adr; /* save the address of file$info */
end; /* zero totals for the new file */
/* else hash$lookup has set f$i$adr to the file entry already in the */
/* hash table */
/* save xfcb or fcb type info */
if (buf$fcb(f$drvusr) and xfcb$type) <> 0 then
do; /* XFCB */
if last$f$i$adr + size(file$info) > x$i$adr - size(xfcb$info) then
return(false); /* out of memory */
x$i$adr = x$i$adr - size(xfcb$info);
call move(8,.buf$fcb(xf$create),.xfcb$info.create);
xfcb$info.passmode = buf$fcb(xf$passmode);
file$info.x$i$adr = x$i$adr;
end;
else /* regular fcb, file$info is already positioned */
do; /* add to number of records */
call add3byte(.file$info.recs$lword, buf$fcb(f$rc)
+ shl(double(buf$fcb(f$ex) and dpb.extmsk) , 7));
file$info.name(f$arc-1) = file$info.name(f$arc-1) and buf$fcb(f$arc);
/* 0 archive bit if it is 0 in any dir entry */
/* count kilobytes */
i = 1; /* 1 or 2 byte block numbers ? */
if dpb.blk$max > 255 then
i = 2;
do j = f$diskmap to f$diskmap + diskmaplen - 1 by i;
block$num = buf$fcb(j);
if i = 2 then /* word block numbers */
block$num = block$num or buf$fcb(j+1);
if block$num <> 0 then /* allocated */
call add$block(.file$info.kbytes,.file$info.bytes);
end;
end;
return(true); /* success */
end store$file$info;
get$files: procedure public; /* with one scan through directory get */
dcl dcnt byte; /* files from currently selected drive */
last$f$i$adr = end$adr;
/* last$f$i$adr is the address of the highest file info record */
/* in memory */
do dcnt = 0 to hash$table$size - 1; /* init hash table */
hash$table(dcnt) = 0;
end;
x$i$adr = maxb; /* top of mem, put xfcb info here */
call set$drive;
dir$label,filesfound, used$de = 0;
fcb(f$drvusr) = '?'; /* match all dir entries */
dcnt = search$first(.fcb);
do while dcnt <> 255;
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
if buf$fcb(f$drvusr) <> deleted$type then
do;
used$de = used$de + 1;
if buf$fcb(f$drvusr) = dirlabel$type then /* dir label ? */
dir$label = buf$fcb(f$ex); /* save label info */
else if match then
do;
if not store$file$info then /* store fcb or xfcb info */
do; /* out of space */
call print (.(cr,lf,lf,'Out of Memory',cr,lf,lf,'$'));
return;
end;
end;
end;
call break;
dcnt = search$next; /* to next entry in directory */
end; /* of do while dcnt <> 255 */
end get$files;
end dsearch;


571
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DSH.PLM Normal file
View File

@@ -0,0 +1,571 @@
$title ('SDIR - Show')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
dshow:
do;
/* display module for extended directory */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10',
ff literally '12';
dcl buff(128) byte external,
fcb (35) byte external;
dcl (cur$drv, cur$usr) byte external;
dcl (os,bdos) byte external,
bdos20 lit '20H',
bdos30 lit '30H',
mpm lit '10H';
dcl used$de address external; /* number of used directory entries */
dcl sorted boolean external;
dcl filesfound address external;
dcl search$ops address external, /* search options */
s$dir lit '1',
s$sys lit '2',
s$ro lit '4',
s$rw lit '8',
s$xfcb lit '32', /* show files with xfcbs */
s$nonxfcb lit '64', /* " " without xfcbs */
s$exclude lit '128';
dcl format byte external, /* format is one of the following */
page$len address external, /* page size before printing new headers */
message boolean external, /* print titles and msg when no file found */
formfeeds boolean external, /* use form feeds to separate headers */
form$short lit '0',
form$size lit '1',
form$full lit '2';
dcl file$displayed boolean public initial (false);
declare /* directory label: special case of XFCB */
dirlabel byte external,
dirlabeltype lit '20', /* identifier on disk */
dl$databyte lit '12', /* data byte */
dl$password lit '128', /* masks on data byte */
dl$access lit '64',
dl$update lit '32',
dl$makexfcb lit '16',
dl$exists lit '1';
dcl
buf$fcb$adr address external, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(f$i$adr,last$f$i$adr,end$adr) address external,
cur$file address, /* number of file currently */
/* being displayed */
/* structure of file info */
file$info based f$i$adr structure(
usr byte,
name (8) byte,
type (3) byte,
bytes address, /* byte count (mod kilobyte) */
kbytes address, /* kilobyte count */
recs$lword address, /* record count is 3 byte value */
recs$hbyte byte, /* low word, high byte */
hash$link address,
x$i$adr address), /* index into time stamp array for */
/* this file */
x$i$adr address external,
xfcb$info based x$i$adr structure (
create (4) byte,
update (4) byte,
passmode byte);
dcl f$i$indices$base address external, /* if sorted then f$i$indices */
f$i$indices based f$i$indices$base (1) address; /* are here */
dcl dpb$adr address external, /* disk parameter block address */
dpb based dpb$adr structure
(spt address, blkshf byte, blkmsk byte, extmsk byte, blkmax address,
dirmax address, dirblk address, chksiz address, offset address);
printchar: procedure (char) external;
dcl char byte;
end printchar;
print: procedure (string$adr) external; /* BDOS call # 9 */
dcl string$adr address;
end print;
search$first: procedure(fcb$adr) byte external;
dcl fcb$adr address;
end search$first;
search$next: procedure byte external;
end search$next;
break: procedure external;
end break;
display$time$stamp: procedure (ts$adr) external; /* in dts.plm */
dcl ts$adr address;
end display$time$stamp;
printb: procedure external;
end printb;
crlf: procedure external;
end crlf;
printfn: procedure(fname$adr) external;
dcl fname$adr address;
end printfn;
pdecimal: procedure(v,prec,zerosup) external;
/* print value val, field size = (log10 prec) + 1 */
/* with leading zero suppression if zerosup = true */
declare v address, /* value to print */
prec address, /* precision */
zerosup boolean; /* zero suppression flag */
end pdecimal;
p3byte: procedure(byte3adr,prec)external;
/* print 3 byte value with 0 suppression */
dcl (byte3adr,prec) address; /* assume high order bit is < 10 */
end p3byte;
terminate: procedure external;
end terminate;
match: procedure boolean external;
dcl fcb$adr address;
end match;
add3byte: procedure (byte3$adr,word$amt) external;
dcl (byte3$adr, word$amt) address;
end add3byte; /* add word to 3 byte structure */
add3byte3: procedure (byte3$adr,byte3) external;
dcl (byte3$adr, byte3) address;
end add3byte3; /* add 3 byte quantity to 3 byte total */
shr3byte: procedure (byte3$adr) external;
dcl byte3$adr address;
end shr3byte;
set$drive: procedure external;
end set$drive;
/* routines local to this module */
dcl total$kbytes structure ( /* grand total k bytes of files matched */
lword address,
hbyte byte),
total$recs structure ( /* grand total records of files matched */
lword address,
hbyte byte),
total$1k$blocks structure( /* how many 1k blocks are allocated */
lword address,
hbyte byte);
add$totals: procedure;
dcl temp structure (lword address, hbyte byte);
call add3byte(.total$kbytes,file$info.kbytes);
if file$info.bytes > 0 then /* round up to nearest k */
call add3byte(.total$kbytes,1); /* actual disk space allocated */
call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */
temp.lword = file$info.recs$lword;
temp.hbyte = file$info.recs$hbyte;
call shr3byte(.temp); /* disk space if 1k blksiz */
call add3byte3(.total$1k$blocks,.temp);
if (file$info.recs$lword and 07h) <> 0 then
call add3byte(.total$1k$blocks,1); /* round up */
end add$totals;
mult23: procedure(index) address external;
dcl index address;
end mult23;
/* fcb and dma buffer constants */
declare
f$drvusr lit '0', /* drive and user field */
f$name lit '1', /* file name */
f$rw lit '9', /* high bit is R/W attribute */
f$dirsys lit '10', /* high bit is dir/sys attribute */
f$arc lit '11', /* high bit is archive attribute */
f$ex lit '12';
declare /* XFCB */
xfcb$type lit '10', /* identifier on disk */
xf$passmode lit '12', /* pass word protection mode */
xf$pass lit '16', /* XFCB password */
passlen lit '8', /* password length */
xf$create lit '25', /* creation/access time stamp */
xf$update lit '29'; /* update time stamp */
declare /* password mode of xfcb */
pm$read lit '80h',
pm$write lit '40h',
pm$delete lit '20h';
dcl files$per$line byte;
dcl cur$line address;
dcl hdr (*) byte data (' Name Bytes Recs Attributes $');
dcl hdr$bars (*) byte data ('------------ ------ ------ ------------$');
dcl hdr$pu (*) byte data (' Prot Update $');
dcl hdr$xfcb$bars (*) byte data (' ------ -------------- --------------$');
dcl hdr$access (*) byte data (' Access $');
dcl hdr$create (*) byte data (' Create $');
/* example date 04/02/55 00:34 */
display$file$info: procedure;
/* print filename.typ */
call printfn(.file$info.name(0));
call printb;
call pdecimal(file$info.kbytes,10000,true);
cal<61> printchar('k')<29> /<2F> u<> t<> 3<> Me<4D> - Byte<74> */
/* or 32,000k */
call printb;
call p3byte(.file$info.recs$lword,1); /* records */
call printb;
if rol(file$info.name(f$dirsys-1),1) then /* Type */
call print(.('Sys$'));
else call print(.('Dir$'));
call printb;
if rol(file$info.name(f$rw-1),1) then
call print(.('RO$'));
else call print(.('RW$'));
call printb;
if rol(file$info.name(f$arc-1),1) then /* arc bit was on in all */
call print$char('A'); /* dir entries */
else call printb;
if rol(file$info.name(0),1) then
call print$char('1');
else call printb;
if rol(file$info.name(1),1) then
call print$char('2');
else call printb;
if rol(file$info.name(2),1) then
call print$char('3');
else call printb;
if rol(file$info.name(3),1) then
call print$char('4');
else call printb;
end display$file$info;
display$xfcb$info: procedure;
if file$info.x$i$adr <> 0 then
do;
call printb;
x$i$adr = file$info.x$i$adr;
if (xfcb$info.passmode and pm$read) <> 0 then
call print(.('Read $'));
else if (xfcb$info.passmode and pm$write) <> 0 then
call print(.('Write $'));
else if (xfcb$info.passmode and pm$delete) <> 0 then
call print(.('Delete$'));
else
call print(.('None $'));
call printb;
if (xfcb$info.update(0) <> 0 or xfcb$info.update(1) <> 0) then
call display$timestamp(.xfcb$info.update);
else call print(.(' $'));
call printb; call printb;
if (xfcb$info.create(0) <> 0 or xfcb$info.create(1) <> 0) then
call display$timestamp(.xfcb$info.create(0));
/* Create/Access */
end;
end display$xfcb$info;
dcl first$title boolean initial (true);
display$title: procedure;
if formfeeds then
call print$char(ff);
else if not first$title then
call crlf;
call print(.('Directory For Drive $'));
call printchar('A'+ cur$drv); call printchar(':');
if bdos >= bdos20 then
do;
call print(.(' User $'));
call pdecimal(cur$usr,10,true);
end;
call crlf;
cur$line = 2;
first$title = false;
end display$title;
short$display: procedure (fname$adr);
dcl fname$adr address;
if cur$file mod files$per$line = 0 then
do;
if cur$line mod page$len = 0 then
do; call crlf;
call display$title;
call crlf;
end;
else
call crlf;
cur$line = cur$line + 1;
call printchar(cur$drv + 'A');
end;
else call printb;
call print(.(': $'));
call printfn(fname$adr);
call break;
cur$file = cur$file + 1;
end short$display;
test$att: procedure(char,off,on) boolean;
dcl (char,off,on) byte;
if (80h and char) <> 80h and (off and search$ops) <> 0 then
return(true);
if (80h and char) = 80h and (on and search$ops) <> 0 then
return(true);
return(false);
end test$att;
right$attributes: procedure(name$adr) boolean;
dcl name$adr address,
name based name$adr (1) byte;
return
test$att(name(f$rw-1),s$rw,s$ro) and
test$att(name(f$dirsys-1),s$dir,s$sys);
end right$attributes;
short$dir: procedure;
dcl dcnt byte;
fcb(f$drvusr) = '?';
files$per$line = 4;
dcnt = search$first(.fcb);
call set$drive;
do while dcnt <> 0ffh;
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
if (buf$fcb(f$drvusr) and 0f0h) = 0 and buf$fcb(f$ex)<= dpb.extmsk
then /* no dir labels, xfcbs */
if match then
if right$attributes(.buf$fcb(f$name)) then
call short$display(.buf$fcb(f$name));
dcnt = search$next;
end;
end short$dir;
dcl index address;
getnxt$file$info: procedure;
dcl right$usr boolean;
right$usr = false;
if sorted then
do while not right$usr;
if index < filesfound then
do; f$i$adr = mult23(f$i$indices(index));
index = index + 1;
right$usr = file$info.usr = cur$usr;
end;
else
do; f$i$adr = end$adr; /* no more file$info recs */
right$usr = true;
end;
end;
else
do while not right$usr and f$i$adr <> end$adr;
f$i$adr = f$i$adr - size(file$info);
right$usr = file$info.usr = cur$usr;
end;
end getnxt$file$info;
size$display: procedure;
if (format and form$size) <> 0 then
files$per$line = 3;
else files$per$line = 4;
do while f$i$adr <> end$adr;
if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb) <> 0) or
(file$info.x$i$adr = 0 and (search$ops and s$nonxfcb) <> 0)) and
right$attributes(.file$info.name(0)) then
do;
cal<61> add$totals;
call short$display(.file$info.name(0));
call pdecimal(file$info.kbytes,10000,true);
call print(.('k$'));
end;
call getnxt$file$info;
end;
end size$display;
display$no$dirlabel: procedure;
files$per$line = 2;
do while f$i$adr <> end$adr;
if right$attributes(.file$info.name(0)) then
do;
if cur$file mod files$per$line = 0 then /* need new line */
do;
if cur$line mod page$len = 0 then
do; call crlf;
call display$title;
call crlf;
call print(.hdr);
if (not sorted and f$i$adr <> end$adr + size(file$info)) or
(sorted and index < filesfound) then
do; call printb; /* then two sets of hdrs */
call print(.hdr); /* more than 1 file left */
end;
call crlf;
call print(.hdr$bars);
if (not sorted and f$i$adr <> end$adr + size(file$info)) or
(sorted and index < filesfound) then
do; call printb;
call print(.hdr$bars);
end;
call crlf;
cur$line = cur$line + 3;
end;
else
do; call crlf;
cur$line = cur$line + 1;
end;
end;
else
call printb; /* separate the files */
call display$file$info;
cur$file = cur$file + 1;
call add$totals;
call break;
end;
call getnxt$file$info;
end;
end display$no$dirlabel;
display$with$dirlabel: procedure;
files$per$line = 1;
do while f$i$adr <> end$adr;
if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb) <> 0) or
(file$info.x$i$adr = 0 and (search$ops and s$nonxfcb) <> 0)) and
right$attributes(.file$info.name(0)) then
do;
cur$file = cur$file + 1;
if cur$line mod page$len = 0 then
do; call crlf;
call display$title;
call crlf;
call print(.hdr);
call print(.hdr$pu);
if (dirlabel and dl$access) <> 0 then
call print(.hdr$access);
else
call print(.hdr$create);
call crlf;
call print(.hdr$bars);
call print(.hdr$xfcb$bars);
cur$line = cur$line + 2;
end;
call crlf;
call display$file$info; /* display non bdos 3.0 file info */
call display$xfcb$info;
call break;
cur$line = cur$line + 1;
call add$totals;
end;
call getnxt$file$info;
end;
end display$with$dirlabel;
show$files: procedure public; /* MODULE ENTRY POINT */
/* display the collected data */
cur$line, cur$file = 0; /* force titles and new line */
totalkbytes.lword, totalkbytes.hbyte, totalrecs.lword, totalrecs.hbyte =0;
total$1k$blocks.lword, total$1k$blocks.hbyte = 0;
f$i$adr = last$f$i$adr + size(file$info); /* initial if no sort */
index = 0; /* initial if sorted */
call getnxt$file$info; /* base file info record */
if format > 2 then
do;
call print(.('Illegal Format Value$'));
call terminate;
end;
do case format; /* format = */
call short$dir; /* form$short */
call size$display; /* form$size */
/* form = full */
if (dir$label and dl$exists) = 0 or ((search$ops and s$xfcb) = 0 and
(search$ops and s$nonxfcb) <> 0) then
call display$no$dirlabel;
else
call display$with$dirlabel;
end;
if cur$file > 1 and format <> form$short then /* print totals */
do;
if (page$len <> 0) and (cur$line + 4 > page$len) and formfeeds then
do;
call printchar(cr);
call printchar(ff); /* need a new page ? */
end;
else
do;
call crlf;
call crlf;
end;
call print(.( 'Total Bytes = $'));
call p3byte(.total$kbytes,1); /* 6 digit max */
call printchar('k');
call print(.(' Total Records = $'));
call p3byte(.total$recs,10); /* 7 digit max */
call print(.(' Files Found = $'));
call pdecimal(cur$file,1000,true); /* 4 digit max */
call print(.(cr,lf,'Total 1k Blocks = $'));
call p3byte(.total$1k$blocks,1); /* 6 digit max */
call print(.(' Used/Max Dir Entries For Drive $'));
call print$char('A' + cur$drv);
call print$char(':'); call printb;
call pdecimal(used$de,1000,true);
call print$char('/');
call pdecimal(dpb.dirmax + 1,1000,true);
end;
if cur$file = 0 then
do;
if message then
do; call crlf;
call display$title;
call print(.('File Not Found.',cr,lf,'$'));
end;
call break;
end;
else
do; file$displayed = true;
if not formfeeds then
call print(.(cr,lf,'$'));
end;
end show$files;
end dshow;


158
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DSO.PLM Normal file
View File

@@ -0,0 +1,158 @@
$title ('SDIR - Sort')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
dsort:
do;
/* sort module for extended dir */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
word lit 'address',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10';
print: procedure(str$adr) external;
dcl str$adr address;
end print;
dcl sorted boolean public; /* set by this module if successful sort */
declare
buf$fcb$adr address external, /* index into directory buffer */
buf$fcb based buf$fcb$adr (32) byte,
/* fcb template for dir */
(f$i$adr, end$adr, last$f$i$adr, x$i$adr, filesfound)
address external,
/* indices into file$info array */
file$info based f$i$adr structure(
user byte,
name (8) byte,
type (3) byte,
bytes address, /* byte count (mod kilobyte) */
kbytes address, /* kilobyte count */
recs$lword address, /* record count is 3 byte value */
recs$hbyte byte, /* low word, high byte */
hash$link address,
x$i$adr address), /* index into time stamp array for */
/* this file */
mid$adr address,
mid$file$info based mid$adr structure(
user byte,
name (8) byte,
type (3) byte,
bytes address, /* byte count (mod kilobyte) */
kbytes address, /* kilobyte count */
recs$lword address, /* record count is 3 byte value */
recs$hbyte byte, /* low word, high byte */
hash$link address,
x$i$adr address); /* index into time stamp array for */
/* this file */
mult23: procedure(index) address public;
dcl index address; /* return address of file$info numbered by index */
return shl(index, 4) + shl(index,2) + shl(index,1) + index + end$adr +
size(file$info);
/* index * size(file$info) + base of file$info array */
end mult23;
lessthan: procedure( str1$adr, str2$adr) boolean;
dcl (i,c1,c2) byte, /* true if str1 < str2 */
(str1$adr, str2$adr) address, /* sorting on name and type field */
str1 based str1$adr (1) byte, /* only, assumed to be first in */
str2 based str2$adr (1) byte; /* file$info record */
do i = 0 to 10;
if (c1:=(str1(i) and 7fh)) <> (c2:=(str2(i) and 7fh)) then
return(c1 < c2);
end;
return(false);
end lessthan;
dcl f$i$indices$base address public,
f$i$indices based f$i$indices$base (1) address;
qsort: procedure(l,r);
dcl (l,r,i,j,temp) address,
stacksiz lit '14', /* should always be able to sort 2 ** stacksiz */
stack (stack$siz) structure (l address, r address),
sp byte;
sp = 0; stack(0).l = l; stack(0).r = r;
do while sp < stack$siz - 1;
l = stack(sp).l; r = stack(sp).r; sp = sp - 1;
do while l < r;
i = l; j = r;
mi<6D>$adr <20> mult23(f$i$indices(shr(l+r,1))<29>;
do while i <= j;
f$i$adr = mult23(f$i$indices(i));
do while lessthan(f$i$adr,mid$adr);
i = i + 1;
f$i$adr = mult23(f$i$indices(i));
end;
f$i$adr = mult23(f$i$indices(j));
do while lessthan(mid$adr,f$i$adr);
j = j - 1;
f$i$adr = mult23(f$i$indices(j));
end;
if i <= j then
do; temp = f$i$indices(i); f$i$indices(i) = f$i$indices(j);
f$i$indices(j) = temp;
i = i + 1;
if j > 0 then j = j - 1;
end;
end; /* while i <= j */
if j - l < r - i then
do; if i < r then
do; sp = sp + 1; stack(sp).l = i; stack(sp).r = r;
end;
r = j; /* continue sorting left partition */
end;
else
do; if l < j then
do; sp = sp + 1; stack(sp).l = l; stack(sp).r = j;
end;
l = i; /* continue sorting right partition */
end;
end; /* while l < r */
end; /* while sp < stack$siz - 1 */
if sp <> 255 then
call print(.(cr,lf,lf,'Sort Stack Overflow',cr,lf,'$'));
else sorted = true;
end qsort;
sort: procedure public;
dcl i address;
f$i$indices$base = last$f$i$adr + size(file$info);
if filesfound < 2 then
return;
if shr((x$i$adr - f$i$indices$base),1) < filesfound then
do;
call print(.(cr,lf,lf,'Not enough memory for sort',cr,lf,lf,'$'));
return;
end;
do i = 0 to filesfound - 1;
f$i$indices(i) = i; /* initialize f$i$indices */
end;
call qsort(0,filesfound - 1);
sorted = true;
end sort;
end dsort;


248
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DTS.PLM Normal file
View File

@@ -0,0 +1,248 @@
$title ('SDIR - Time Stamp')
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
dtimestamp:
do;
/* Display time stamp module for extended directory */
/* Time & Date ASCII Conversion Code */
/* From MP/M 1.1 TOD program */
/* commonly used macros */
declare dcl literally 'declare',
lit literally 'literally',
word lit 'address',
true literally '1',
false literally '0',
boolean literally 'byte',
cr literally '13',
lf literally '10';
print$char: procedure (char) external;
declare char byte;
end print$char;
terminate: procedure external;
end terminate;
declare tod$adr address;
declare tod based tod$adr structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (21) byte );
declare string$adr address;
declare string based string$adr (1) byte;
declare index byte;
emitchar: procedure(c);
declare c byte;
string(index := index + 1) = c;
end emitchar;
emitn: procedure(a);
declare a address;
declare c based a byte;
do while c <> '$';
string(index := index + 1) = c;
a = a + 1;
end;
end emitn;
emit$bcd: procedure(b);
declare b byte;
call emitchar('0'+b);
end emit$bcd;
emit$bcd$pair: procedure(b);
declare b byte;
call emit$bcd(shr(b,4));
call emit$bcd(b and 0fh);
end emit$bcd$pair;
emit$colon: procedure(b);
declare b byte;
call emit$bcd$pair(b);
call emitchar(':');
end emit$colon;
emit$bin$pair: procedure(b);
declare b byte;
call emit$bcd(b/10); /* makes garbage if not < 10 */
call emit$bcd(b mod 10);
end emit$bin$pair;
emit$slant: procedure(b);
declare b byte;
call emit$bin$pair(b);
call emitchar('/');
end emit$slant;
declare
base$year lit '78', /* base year for computations */
base$day lit '0', /* starting day for base$year 0..6 */
month$days (*) word data
/* jan feb mar apr may jun jul aug sep oct nov dec */
( 000,031,059,090,120,151,181,212,243,273,304,334);
leap$days: procedure(y,m) byte;
declare (y,m) byte;
/* compute days accumulated by leap years */
declare yp byte;
yp = shr(y,2); /* yp = y/4 */
if (y and 11b) = 0 and month$days(m) < 59 then
/* y not 00, y mod 4 = 0, before march, so not leap yr */
return yp - 1;
/* otherwise, yp is the number of accumulated leap days */
return yp;
end leap$days;
declare word$value word;
get$next$digit: procedure byte;
/* get next lsd from word$value */
declare lsd byte;
lsd = word$value mod 10;
word$value = word$value / 10;
return lsd;
end get$next$digit;
bcd:
procedure (val) byte;
declare val byte;
return shl((val/10),4) + val mod 10;
end bcd;
declare (month, day, year, hrs, min, sec) byte;
bcd$pair: procedure(a,b) byte;
declare (a,b) byte;
return shl(a,4) or b;
end bcd$pair;
compute$year: procedure;
/* compute year from number of days in word$value */
declare year$length word;
year = base$year;
do while true;
year$length = 365;
if (year and 11b) = 0 then /* leap year */
year$length = 366;
if word$value <= year$length then
return;
word$value = word$value - year$length;
year = year + 1;
end;
end compute$year;
declare
week$day byte, /* day of week 0 ... 6 */
day$list (*) byte data
('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
leap$bias byte; /* bias for feb 29 */
compute$month: procedure;
month = 12;
do while month > 0;
if (month := month - 1) < 2 then /* jan or feb */
leapbias = 0;
if month$days(month) + leap$bias < word$value then return;
end;
end compute$month;
declare
date$test byte, /* true if testing date */
test$value word; /* sequential date value under test */
get$date$time: procedure;
/* get date and time */
hrs = tod.hrs;
min = tod.min;
sec = tod.sec;
word$value = tod.date;
/* word$value contains total number of days */
week$day = (word$value + base$day - 1) mod 7;
call compute$year;
/* year has been set, word$value is remainder */
leap$bias = 0;
if (year and 11b) = 0 and word$value > 59 then
/* after feb 29 on leap year */ leap$bias = 1;
call compute$month;
day = word$value - (month$days(month) + leap$bias);
month = month + 1;
end get$date$time;
emit$date$time: procedure;
if tod.opcode = 0 then
do;
call emitn(.day$list(shl(week$day,2)));
call emitchar(' ');
end;
call emit$slant(month);
call emit$slant(day);
call emit$bin$pair(year);
call emitchar(' ');
call emit$colon(hrs);
call emit$colon(min);
if tod.opcode = 0 then
call emit$bcd$pair(sec);
end emit$date$time;
tod$ASCII:
procedure (parameter);
declare parameter address;
declare ret address;
ret = 0;
tod$adr = parameter;
string$adr = .tod.ASCII;
if (tod.opcode = 0) or (tod.opcode = 3) then
do;
call get$date$time;
index = -1;
call emit$date$time;
end;
else
call terminate; /* error */
end tod$ASCII;
declare lcltod structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (21) byte );
display$time$stamp: procedure (tsadr) public;
dcl tsadr address,
i byte;
lcltod.opcode = 3; /* display time and date stamp, no seconds */
call move (4,tsadr,.lcltod.date); /* don't copy seconds */
call tod$ASCII (.lcltod);
do i = 0 to 13;
call printchar (lcltod.ASCII(i));
end;
end display$time$stamp;
dcl last$data$byte byte initial(0);
end dtimestamp;


BIN
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/SDIR.PRL Normal file
View File

Binary file not shown.

67
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/SDIR.SUB Normal file
View File

@@ -0,0 +1,67 @@
pip a:=e:dm.plm
seteof dm.plm
pip a:=e:sn.plm
seteof sn.plm
pip a:=e:dse.plm
seteof dse.plm
pip a:=e:dsh.plm
seteof dsh.plm
pip a:=e:dso.plm
seteof dso.plm
pip a:=e:da.plm
seteof da.plm
pip a:=e:dp.plm
seteof dp.plm
pip a:=e:dts.plm
seteof dts.plm
isx
plm80 dm.plm object(dm) debug pagewidth(130)
plm80 sn.plm object(sn) debug pagewidth(130)
plm80 dse.plm object(dse) debug pagewidth(130)
plm80 dsh.plm object(dsh) debug pagewidth(130)
plm80 dso.plm object(dso) debug pagewidth(130)
plm80 dp.plm object(dp) debug pagewidth(130)
plm80 da.plm object(da) debug pagewidth(130)
plm80 dts.plm object(dts) debug pagewidth(130)
link x0100,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d1.lnk
locate d1.lnk code(0100H) stacksize(50)
era d1.lnk
objhex d1 to d1.hex
link x0200,dm,sn,dse,dso,dsh,dp,da,dts,plm80.lib to d2.lnk
locate d2.lnk code(0200H) stacksize(50)
era d2.lnk
objhex d2 to d2.hex
cpm
objcpm d1
ren sdir1.lst=dm.lst
ren sdir2.lst=sn.lst
ren sdir3.lst=dse.lst
ren sdir4.lst=dsh.lst
ren sdir5.lst=dso.lst
ren sdir6.lst=dp.lst
ren sdir7.lst=da.lst
ren sdir8.lst=dts.lst
ren sdir.sym=d1.sym
ren sdir.lin=d1.lin
vax sdir1.lst $$stan
vax sdir2.lst $$stan
vax sdir3.lst $$stan
vax sdir4.lst $$stan
vax sdir5.lst $$stan
vax sdir6.lst $$stan
vax sdir7.lst $$stan
vax sdir8.lst $$stan
vax sdir.sym $$stan
vax sdir.lin $$stan
pip d.hex=d1.hex,d2.hex
genmod d.hex xsdir.prl
pip e:sdir.prl=a:xsdir.prl
pip b:sdir.prl=a:xsdir.prl
era xsdir.*
era *.hex
era *.obj
era *.lst
era *.lin
era *.sym
;end sdir submit


773
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/SN.PLM Normal file
View File

@@ -0,0 +1,773 @@
$title ('SDIR - Scanner')
scanner:
do;
/*
Copyright (C) 1981
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
Revised:
14 Sept 81 by Danny Horovitz
*/
declare lit literally 'literally',
dcl lit 'declare',
tab lit '09',
cr lit '13',
lf lit '10',
boolean lit 'byte',
true lit '0ffffh',
false lit '0',
f$namelen lit '8',
f$typelen lit '3';
dcl debug boolean initial (false);
dcl buff(128) byte external;
dcl fcb (35) byte external;
dcl eob lit '0'; /* end of buffer */
mon1: procedure(func,adr) external;
dcl func byte,
adr address;
end mon1;
printchar: procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
printb: procedure;
call printchar(' ');
end printb;
crlf: procedure;
call printchar(cr);
call printchar(lf);
end crlf;
pdecimal: procedure(v,prec,zerosup);
/* print value v with precision prec (1,10,100,1000,10000)
with leading zero suppression if zerosup = true */
declare
v address, /* value to print */
prec address, /* precision */
zerosup byte, /* zero suppression flag */
d byte; /* current decimal digit */
zerosup = true;
do while prec <> 0;
d = v / prec ; /* get next digit */
v = v mod prec;/* get remainder back to v */
prec = prec / 10; /* ready for next digit */
if prec <> 0 and zerosup and d = 0 then call printb;
else
do;
zerosup = false;
call printchar('0'+d);
end;
end;
end pdecimal;
show$buf: procedure;
dcl i byte;
i = 1;
call crlf;
call mon1(9,.('buff = $'));
do while buff(i) <> 0;
i = i + 1;
end;
buff(i) = '$';
call mon1(9,.buff(1));
buff(i) = 0;
end show$buf;
white$space: procedure (str$adr) byte;
dcl str$adr address,
str based str$adr (1) byte,
i byte;
i = 0;
do while (str(i) = ' ') or (str(i) = tab);
i = i + 1;
end;
return(i);
end white$space;
delimiter: procedure(char) boolean;
dcl char byte;
if char = '[' or char = ']' or char = '(' or char = ')' or
char = '=' or char = ',' or char = 0 then
return (true);
return(false);
end delimiter;
dcl string$marker lit '05ch';
deblank: procedure(buf$adr);
dcl (buf$adr,dest) address,
buf based buf$adr (128) byte,
(i,numspaces) byte,
string boolean;
string = false;
if (numspaces := white$space(.buf(1))) > 0 then
call move(buf(0) - numspaces + 1,.buf(numspaces+1),.buf(1));
i = 1;
do while buf(i) <> 0;
/* call show$buf;*/
do while ((numspaces := white$space(.buf(i))) = 0 and (buf(i) <> 0))
and not string;
/* call mon1(9,.(cr,lf,'2numspaces = $'));
call pdecimal(numspaces,100,false);*/
/* call show$buf;*/
if buf(i) = '"' then
do;
string = true;
buf(i) = string$marker;
end;
i = i + 1;
end;
do while string and buf(i) <> 0;
if buf(i) = '"' then
if buf(i+1) = '"' then
call move(buf(0) - i + 1,.buf(i+1), .buf(i));
else
do;
buf(i) = string$marker;
string = false;
end;
i = i + 1;
end;
if (numspaces := white$space(.buf(i))) > 0 then
do;
/* call mon1(9,.(cr,lf,'1numspaces = $'));
call pdecimal(numspaces,100,false);*/
buf(i) = ' ';
dest = .buf(i+1); /* save space for ',' */
if i > 1 then
if delimiter(buf(i-1)) or delimiter(buf(i+numspaces)) then
/* write over ' ' with */
dest = dest - 1; /* a = [ ] ( ) */
call move(((buf(0)+1)-(i+numspaces-1)),
.buf(i+numspaces),dest);
if buf(i) = '"' then
string = true;
i = i + 1;
end;
end;
if buf(i - 1) = ' ' then /* no trailing blanks */
buf(i - 1) = 0;
if debug then
call show$buf;
end deblank;
upper$case: procedure (buf$adr);
dcl buf$adr address,
buf based buf$adr (1) byte,
i byte;
i = 0;
do while buf(i) <> eob;
if buf(i) >= 'a' and buf(i) <= 'z' then
buf(i) = buf(i) - ('a' - 'A');
i = i + 1;
end;
end upper$case;
dcl option$max lit '11';
dcl done$scan lit '0ffffh';
dcl ident$max lit '11';
dcl token$max lit '11';
dcl t$null lit '0',
t$param lit '1',
t$option lit '2',
t$modifier lit '4',
t$identifier lit '8',
t$string lit '16',
t$numeric lit '32',
t$filespec lit '64',
t$error lit '128';
dcl pcb$base address;
dcl pcb based pcb$base structure (
state address,
scan$adr address,
token$adr address,
token$type byte,
token$len byte,
p$level byte,
nxt$token byte);
dcl scan$adr address,
inbuf based scan$adr (1) byte,
in$ptr byte,
token$adr address,
token based token$adr (1) byte,
t$ptr byte,
(char, nxtchar, tcount) byte;
digit<EFBFBD> procedur<75> (char) boolean;
dcl char byte;
return (char >= '0' and char <= '9');
end digit;
letter: procedure (char) boolean;
dcl char byte;
return (char >= 'A' and char <= 'Z');
end letter;
eat$char: procedure;
char = inbuf(in$ptr := inptr + 1);
nxtchar = inbuf(in$ptr + 1);
end eat$char;
put$char: procedure(charx);
dcl charx byte;
if pcb.token$adr <> 0ffffh then
token(t$ptr := t$ptr + 1) = charx;
end put$char;
get$identifier: procedure (max) byte;
dcl max byte;
tcount = 0;
/* call mon1(9,.(cr,lf,'getindentifier$'));*/
if not letter(char) and char <> '$' then
return(tcount);
do while (letter(char) or digit(char) or char = '_' or
char = '$' ) and tcount <= max;
call put$char(char);
call eat$char;
tcount = tcount + 1;
end;
do while letter(char) or digit(char) or char = '_'
or char = '$' ;
call eat$char;
tcount = tcount + 1;
end;
pcb.token$type = t$identifier;
/* call mon1(9,.(cr,lf,'end of getident$')); */
pcb.token$len = tcount;
return(tcount);
end get$identifier;
file$char: procedure (x) boolean;
dcl x byte;
return(letter(x) or digit(x) or x = '*' or x = '?'
or x = '_' or x = '$');
end file$char;
expand$wild$cards: procedure(field$size) boolean;
dcl (i,leftover,field$size) byte,
save$inptr address;
field$size = field$size + t$ptr;
do while filechar(char) and t$ptr < field$size;
if char = '*' then
do; leftover = t$ptr;
save$inptr = inptr;
call eatchar;
do while filechar(char);
leftover = leftover + 1;
call eatchar;
end;
if leftover >= field$size then /* too many chars */
do; inptr = save$inptr;
return(false);
end;
do i = 1 to field$size - leftover;
call putchar('?');
end;
inptr = save$inptr;
end;
else
call putchar(char);
call eatchar;
end;
return(true);
end expand$wild$cards;
get$file$spec: procedure boolean;
dcl i byte;
do i = 1 to fname$len + ftype$len;
token(i) = ' ';
end;
if nxtchar = ':' then
if char >= 'A' and char <= 'P' then
do;
call putchar(char - 'A' + 1);
call eat$char; /* skip ':' */
call eat$char; /* 1st char of file name */
/* if delimiter(char) or char = ' ' then
do i = 1 to fname$len + ftype$len;
token(i) = '?';
end;*/
end;
else
return(false);
else
call putchar(0); /* use default drive */
if not (letter(char) or char = '$' or char = '_' or char = '*'
or char = '?' ) then
if token(0) = 0 then
return(false);
if not expand$wild$cards(f$namelen) then
return(false); /* blank name is illegal */
if char = '.' then
do; call eat$char;
if filechar(char) then
do; t$ptr = f$namelen;
if not expand$wild$cards(f$typelen) then
return(false);
end;
end;
pcb.token$len = f$name$len + f$type$len + 1;
pcb.token$type = t$file$spec;
return(true);
end get$file$spec;
get$numeric: procedure(max) boolean;
dcl max byte;
if not digit(char) then
return(false);
do while digit(char) and pcb.token$len <= max and
char <> eob;
call putchar(char);
call eat$char;
pcb.token$len = pcb.token$len + 1;
end;
if char = 'H' or char = 'D' or char = 'B' then
if pcb.token$len < max then
do;
call putchar(char);
call eat$char;
pcb.token$len = pcb.token$len + 1;
end;
else
return(false);
pcb.token$type = t$numeric;
return(true);
end get$numeric;
get$string: procedure(max) boolean;
dcl max byte;
if char <> string$marker then
return(false);
call eatchar;
do while char <> string$marker and char <> eob
and pcb.token$len < token$max;
call putchar(char);
call eatchar;
pcb.token$len = pcb.token$len + 1;
end;
do while char <> string$marker and char <> eob;
call eat$char;
end;
if char <> string$marker then
return(false);
pcb.token$type = t$string;
call eat$char;
return(true);
end get$string;
get$token$all: procedure boolean;
dcl save$inptr byte;
/* call mon1(9,.(cr,lf,'gettokenall$'));*/
save$inptr = in$ptr;
if get$file$spec then
return(true);
/* call mon1(9,.(cr,lf,'gettokenall - no file$')); */
in$ptr = save$inptr - 1; /* need to re-scan, reset buffer pointers */
call eat$char;
t$ptr = 255;
call putchar(0); /* zero drive byte */
if get$identifier(token$max) = 0 then
if not get$string(token$max) then
if not get$numeric(token$max) then
return(false);
/* call mon1(9,.(cr,lf,'end gettokenall$'));*/
return(true);
end get$token$all;
get$modifier: procedure boolean;
if char = ',' or char = ')' or char = 0 then
do;
pcb.token$type = t$modifier or t$null;
return(true);
end;
if get$token$all then
do;
pcb.token$type = pcb.token$type or t$modifier;
return(true);
end;
return(false);
end get$modifier;
get$option: procedure boolean;
call putchar(0);
if get$identifier(token$max) > 0 then
do;
pcb.token$type = pcb.token$type or t$option;
if pcb.token$len > token$max then
pcb.token$len = token$max;
return(true);
end;
return(false);
end get$option;
get$param: procedure boolean;
if char = ',' or char = ')' or char = 0 then
do;
pcb.token$type = t$param or t$null;
return(true);
end;
if get$token$all then
do;
pcb.token$type = pcb.token$type or t$param;
return(true);
end;
return(false);
end get$param;
dcl gotatoken boolean;
dcl parens byte initial (0);
end$state: procedure boolean;
if gotatoken then
do;
pcb.state = .end$state;
return(true);
end;
pcb.token$type = t$null;
pcb.scan$adr = 0ffffh;
return(true);
end end$state;
state8: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state8, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
if char = ']' then
do;
call eatchar;
if char = ',' or nxtchar = '(' or nxtchar = ')' then
return(state2);
else if char = 0 then
return(end$state);
else
return(state1);
end;
else if char = ' ' or char = ',' then
do;
call eatchar;
return(state3);
end;
return(state3);
end state8;
state7:procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state7, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
if char = ' ' or char = ',' then
do;
call eat$char;
return(state6);
end;
else
if char = ')' then
do;
call eat$char;
return(state8);
end;
return(false);
end state7;
state6: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state6, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.state = .state6;
pcb.nxt$token = t$modifier;
return(true);
end;
if (gotatoken := get$modifier) then
return(state7);
return(false);
end state6;
state5:procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state5, nxtchar = $'));
call printchar(nxtchar); end;
if char = '(' then
do;
call eat$char;
return(state6);
end;
if gotatoken then
do;
pcb.state = .state5;
pcb.nxt$token = t$modifier;
return(true);
end;
if (gotatoken := get$modifier) then
return(state8);
return(false);
end state5;
state4: procedure boolean reentrant;
dcl temp byte;
if debug then do;
call mon1(9,.(cr,lf,'state4, char = $'));
call printchar(char); end;
if char = 0 then
return(end$state);
temp = char;
call eatchar;
if temp = ',' or temp = ' ' then
return(state3);
if temp = ']' then
if char = '(' or char = ',' or char = ')' then
return(state2);
else if char = 0 then
return(end$state);
else
return(state1);
if temp = '=' then
return(state5);
return(false);
end state4;
state3: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state3, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.state = .state3;
pcb.nxt$token = t$option;
return(true);
end;
if (pcb.plevel := parens ) > 128 then
return(false);
if (gotatoken := get$option) then
return(state4);
return(false);
end state3;
state2: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state2, char = $'));
call printchar(char); end;
do while char = ')' or char = 0;
if char = 0 then
return(end$state);
call eat$char;
parens = parens - 1;
end;
if char = '[' then
do;
call eat$char;
return(state3);
end;
if char = ' ' or char = ',' or char = '(' then
do;
if char = '(' then
parens = parens + 1;
call eat$char;
return(state1);
end;
return(state1);
end state$2;
state1: procedure boolean reentrant;
if debug then do;
call mon1(9,.(cr,lf,'state1, char = $'));
call printchar(char); end;
if gotatoken then
do;
pcb.nxt$token = t$param;
pcb.state = .state1;
return(true);
end;
do while char = '(' ;
parens = parens + 1;
call eat$char;
end;
if (pcb.plevel := parens) > 128 then
return(false);
if (gotatoken := get$param) then
return(state2);
return(false);
end state1;
start$state: procedure boolean;
/*if char = '@' then do;
debug = true;
call eat$char;
call mon1(9,.(cr,lf,'startstate, char = $'));
call printchar(char); end; */
if char = 0 then
return(end$state);
if char = ')' then
return(false);
if char = '(' then
do;
parens = parens + 1;
call eat$char;
return(state1);
end;
if char = '[' then
do;
call eat$char;
return(state3);
end;
if (gotatoken := get$param) then
return(state2);
return(false);
end start$state;
/* display$all: procedure; /* called if debug set */
/* call mon1(9,.(cr,lf,'scanadr=$'));
call pdecimal(pcb.scanadr,10000,false);
call mon1(9,.(', tadr=$'));
call pdecimal(pcb.token$adr,10000, false);
call mon1(9,.(', tlen=$'));
call pdecimal(double(pcb.token$len),100, false);
call mon1(9,.(', ttype=$'));
call pdecimal(double(pcb.token$type),100,false);
call mon1(9,.(', plevel=$'));
call pdecimal(double(pcb.plevel),100,false);
call mon1(9,.(', ntok=$'));
call pdecimal(double(pcb.nxt$token),100,false);
if (pcb.token$type and t$option) <> 0 then
call mon1(9,.(cr,lf,'option =$'));
if (pcb.token$type and t$param) <> 0 then
call mon1(9,.(cr,lf,'parm =$'));
if (pcb.token$type and t$modifier) <> 0 then
call mon1(9,.(cr,lf,'modifier=$'));
if (pcb.token$type and t$filespec) <> 0 then
do;
if fcb(0) =0 then
call print$char('0');
else call print$char(fcb(0) + 'A');
call print$char(':');
fcb(12) = '$';
call mon1(9,.fcb(1));
call mon1(9,.(' (filespec)$'));
end;
if ((pcb.token$type and t$string) or (pcb.token$type and
t$identifier) or (pcb.token$type and t$numeric)) <> 0 then
do;
fcb(pcb.token$len + 1) = '$';
call mon1(9,.fcb(1));
end;
if pcb.token$type = t$error then
do;
call mon1(9,.(cr,lf,'scanner error$'));
return;
end;
if (pcb.token$type and t$identifier) <> 0 then
call mon1(9,.(' (identifier)$'));
if (pcb.token$type and t$string) <> 0 then
call mon1(9,.(' (string)$'));
if (pcb.token$type and t$numeric) <> 0 then
call mon1(9,.(' (numeric)$'));
if (pcb.nxt$token and t$option) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = option $'));
if (pcb.nxt$token and t$param) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = parm $'));
if (pcb.nxt$token and t$modifier) <> 0 then
call mon1(9,.(cr,lf,'nxt tok = modifier$'));
call crlf;
end display$all; */
scan: procedure (pcb$adr) public;
dcl status boolean,
pcb$adr address;
pcb$base = pcb$adr;
scan$adr = pcb.scan$adr;
token$adr = pcb.token$adr;
in$ptr, t$ptr = 255;
call eatchar;
gotatoken = false;
pcb.nxt$token = t$null;
pcb.token$len = 0;
if pcb.token$type = t$error then /* after one error, return */
return; /* on any following calls */
else if pcb.state = .start$state then
status = start$state;
else if pcb.state = .state$1 then
status = state$1;
else if pcb.state = .state$3 then
status = state$3;
else if pcb.state = .state$5 then
status = state$5;
else if pcb.state = .state$6 then
status = state$6;
else if pcb.state = .end$state then /* repeated calls go here */
status = end$state; /* after first end$state */
else
status = false;
if not status then
pcb.token$type = t$error;
if pcb.scan$adr <> 0ffffh then
pcb.scan$adr = pcb.scan$adr + inptr;
/* if debug then
call display$all;*/
end scan;
scan$init: procedure(pcb$adr) public;
dcl pcb$adr address;
pcb$base = pcb$adr;
call deblank(pcb.scan$adr);
call upper$case(pcb.scan$adr := pcb.scan$adr + 1);
pcb.state = .start$state;
end scan$init;
end scanner;