mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-27 10:24:19 +00:00
Upload
Digital Research
This commit is contained in:
@@ -0,0 +1,18 @@
|
||||
|
||||
declare
|
||||
lit literally 'literally',
|
||||
dcl lit 'declare',
|
||||
true lit '0ffh',
|
||||
false lit '0',
|
||||
no lit 'not',
|
||||
boolean lit 'byte',
|
||||
forever lit 'while true',
|
||||
cr lit '13',
|
||||
lf lit '10',
|
||||
tab lit '9',
|
||||
ctrlc lit '3',
|
||||
ff lit '12',
|
||||
page$len$offset lit '1ch',
|
||||
nopage$mode$offset lit '2Ch',
|
||||
sectorlen lit '128';
|
||||
|
||||
@@ -0,0 +1,9 @@
|
||||
|
||||
/*
|
||||
Copyright (C) 1983
|
||||
Digital Research
|
||||
P.O. Box 579
|
||||
Pacific Grove, CA 93950
|
||||
*/
|
||||
|
||||
|
||||
@@ -0,0 +1,529 @@
|
||||
$title ('SDIR - Display Files')
|
||||
display:
|
||||
do;
|
||||
/* Display Module for SDIR */
|
||||
|
||||
$include(comlit.lit)
|
||||
|
||||
$include(mon.plm)
|
||||
|
||||
dcl (cur$drv, cur$usr) byte external;
|
||||
|
||||
dcl (os,bdos) byte external;
|
||||
$include(vers.lit)
|
||||
|
||||
dcl used$de address external; /* number of used directory entries */
|
||||
dcl date$opt boolean external; /* date option flag */
|
||||
dcl display$attributes boolean external; /* attributes display flag */
|
||||
dcl sorted boolean external;
|
||||
dcl filesfound address external;
|
||||
|
||||
$include (search.lit)
|
||||
dcl find find$structure external;
|
||||
|
||||
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 */
|
||||
|
||||
$include(format.lit)
|
||||
|
||||
dcl file$displayed boolean public initial (false);
|
||||
/* true if we ever display a file, from any drive or user */
|
||||
/* used by main.plm for file not found message */
|
||||
|
||||
dcl dir$label byte external;
|
||||
|
||||
$include(fcb.lit)
|
||||
$include(xfcb.lit)
|
||||
|
||||
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,first$f$i$adr) address external,
|
||||
cur$file address; /* number of file currently */
|
||||
/* being displayed */
|
||||
|
||||
$include(finfo.lit)
|
||||
/* structure of file info */
|
||||
dcl file$info based f$i$adr f$info$structure;
|
||||
|
||||
dcl x$i$adr address external,
|
||||
xfcb$info based x$i$adr x$info$structure;
|
||||
|
||||
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 */
|
||||
|
||||
|
||||
/* -------- Routines in util.plm -------- */
|
||||
|
||||
printchar: procedure (char) external;
|
||||
dcl char byte;
|
||||
end printchar;
|
||||
|
||||
print: procedure (string$adr) external; /* BDOS call # 9 */
|
||||
dcl string$adr address;
|
||||
end print;
|
||||
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
|
||||
/* -------- Routines in search.plm -------- */
|
||||
|
||||
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;*/
|
||||
|
||||
match: procedure boolean external;
|
||||
dcl fcb$adr address;
|
||||
end match;
|
||||
|
||||
|
||||
/* -------- Other external routines -------- */
|
||||
|
||||
display$time$stamp: procedure (ts$adr) external; /* in dts.plm */
|
||||
dcl ts$adr address;
|
||||
end display$time$stamp;
|
||||
|
||||
terminate: procedure external; /* in main.plm */
|
||||
end terminate;
|
||||
|
||||
mult23: procedure(index) address external; /* in sort.plm */
|
||||
dcl index address;
|
||||
end mult23;
|
||||
|
||||
|
||||
/* -------- From dpb86.plm or dpb80.plm -------- */
|
||||
|
||||
$include(dpb.lit)
|
||||
|
||||
dpb$byte: procedure (dpb$index) byte external;
|
||||
dcl dpb$index byte;
|
||||
end dpb$byte;
|
||||
|
||||
dpb$word: procedure (dpb$index) address external;
|
||||
dcl dpb$index byte;
|
||||
end dpb$word;
|
||||
|
||||
|
||||
/* -------- routines and data structures local to this module -------- */
|
||||
|
||||
direct$console$io: procedure byte;
|
||||
return mon2(6,0ffh); /* ff to stay downward compatable */
|
||||
end direct$console$io;
|
||||
|
||||
wait$keypress: procedure;
|
||||
declare char byte;
|
||||
char = direct$console$io;
|
||||
do while char = 0;
|
||||
char = direct$console$io;
|
||||
end;
|
||||
if char = ctrlc then
|
||||
call terminate;
|
||||
end wait$keypress;
|
||||
|
||||
declare global$line$count byte initial(1);
|
||||
|
||||
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;
|
||||
|
||||
call add3byte(.total$kbytes,file$info.kbytes);
|
||||
call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */
|
||||
call add3byte(.total$1k$blocks,file$info.onekblocks);
|
||||
|
||||
end add$totals;
|
||||
|
||||
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);
|
||||
call printchar('k'); /* up to 32 Meg - Bytes */
|
||||
/* 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 not display$attributes then do;
|
||||
if rol(file$info.name(f$arc-1),1) then
|
||||
call print(.('Arcv $'));
|
||||
else
|
||||
call print(.(' $'));
|
||||
end;
|
||||
else do;
|
||||
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;
|
||||
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);
|
||||
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 then
|
||||
return(true);
|
||||
if (80h and char) = 80h and on 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),find.rw,find.ro) and
|
||||
test$att(name(f$dirsys-1),find.dir,find.sys);
|
||||
end right$attributes;
|
||||
|
||||
short$dir: procedure; /* looks like "DIR" command */
|
||||
dcl dcnt byte;
|
||||
fcb(f$drvusr) = '?';
|
||||
files$per$line = 4;
|
||||
dcnt = search$first(.fcb);
|
||||
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) = 0 and
|
||||
buf$fcb(f$ex)<= dpb$byte(extmsk$b) 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 (last$plus$one,index) address;
|
||||
|
||||
getnxt$file$info: procedure; /* set f$i$adr to base file$info on file */
|
||||
dcl right$usr boolean; /* to be displayed, f$i$adr = 0ffffh if end */
|
||||
right$usr = false;
|
||||
if sorted then do;
|
||||
index = index + 1;
|
||||
if index < filesfound then do;
|
||||
f$i$adr = mult23(f$i$indices(index));
|
||||
do while (file$info.usr <> cur$usr) and (index < filesfound);
|
||||
index = index + 1;
|
||||
if index < filesfound then
|
||||
f$i$adr = mult23(f$i$indices(index));
|
||||
end;
|
||||
end;
|
||||
if index = files$found then
|
||||
f$i$adr = last$plus$one; /* no more files */
|
||||
end;
|
||||
else /* not sorted display in order found in directory */
|
||||
do; /* use last$plus$one to avoid wrap around problems */
|
||||
f$i$adr = f$i$adr + size(file$info);
|
||||
do while file$info.usr <> cur$usr and f$i$adr <> last$plus$one;
|
||||
f$i$adr = f$i$adr + size(file$info);
|
||||
end;
|
||||
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 <> last$plus$one;
|
||||
if ((file$info.x$i$adr <> 0 and find.xfcb) or
|
||||
file$info.x$i$adr = 0 and find.nonxfcb) and
|
||||
right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
call 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 <> last$plus$one; /* Do all valid files */
|
||||
if ((file$info.x$i$adr <> 0 and find.xfcb) or
|
||||
(file$info.x$i$adr = 0 and find.nonxfcb)) and
|
||||
right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
if cur$file mod files$per$line <> 0 then call printb;
|
||||
else do; /* need a new line */
|
||||
if cur$line mod page$len <> 0 then do; /* just crlf */
|
||||
call crlf;
|
||||
cur$line = cur$line + 1;
|
||||
end;
|
||||
else do; /* print header */
|
||||
call crlf;
|
||||
call display$title; call crlf;
|
||||
call print(.hdr); call printb; call print(.hdr);
|
||||
call crlf;
|
||||
call print(.hdr$bars); call printb; call print(.hdr$bars);
|
||||
call crlf;
|
||||
cur$line = cur$line + 3;
|
||||
end;
|
||||
end;
|
||||
call display$file$info;
|
||||
cur$file = cur$file + 1;
|
||||
call add$totals;
|
||||
end;
|
||||
call getnxt$file$info;
|
||||
end;/* do loop */
|
||||
end display$no$dirlabel;
|
||||
|
||||
display$with$dirlabel: procedure;
|
||||
files$per$line = 1;
|
||||
do while f$i$adr <> last$plus$one; /* Display the file info */
|
||||
if ((file$info.x$i$adr <> 0 and find.xfcb) or
|
||||
(file$info.x$i$adr = 0 and find.nonxfcb)) and
|
||||
right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
if cur$line mod page$len = 0 then do; /* display the header */
|
||||
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; /* header display */
|
||||
call crlf;
|
||||
call display$file$info; /* display non bdos 3.0 file info */
|
||||
call display$xfcb$info;
|
||||
cur$file = cur$file+1; cur$line = cur$line+1;
|
||||
call add$totals;
|
||||
end;
|
||||
call getnxt$file$info;
|
||||
end;
|
||||
end display$with$dirlabel;
|
||||
|
||||
|
||||
display$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 = first$f$i$adr - size(file$info); /* initial if no sort */
|
||||
last$plus$one = last$f$i$adr + size(file$info);
|
||||
index = 0ffffh; /* initial if sorted */
|
||||
call getnxt$file$info; /* base file info record */
|
||||
|
||||
if format > 2 then
|
||||
do;
|
||||
call print(.('Illegal Format Value$'));
|
||||
call terminate; /* default could be patched - watch it */
|
||||
end;
|
||||
|
||||
do case format; /* format = */
|
||||
call short$dir; /* form$short */
|
||||
call size$display; /* form$size */
|
||||
/* form = full */
|
||||
if date$opt then do;
|
||||
if ((( dir$label and dl$exists) <> 0 ) and
|
||||
((( dir$label and dl$access) <> 0 ) or
|
||||
(( dir$label and dl$update) <> 0 ) or
|
||||
(( dir$label and dl$makexfcb) <> 0 ))) then
|
||||
call display$with$dirlabel; /* Timestamping is active! */
|
||||
else do;
|
||||
call print(.('Date and Time Stamping Inactive$'));
|
||||
call terminate;
|
||||
end;
|
||||
end;
|
||||
else do; /* No date option; Regular Full display */
|
||||
if (dir$label and dl$exists) <> 0 then
|
||||
call display$with$dirlabel;
|
||||
else
|
||||
call display$no$dirlabel;
|
||||
end;
|
||||
end; /* end of case */
|
||||
if format <> form$short and cur$file > 0 then /* print totals */
|
||||
do;
|
||||
if 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$word(dirmax$w) + 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;
|
||||
end;
|
||||
else do;
|
||||
file$displayed = true;
|
||||
if not formfeeds then
|
||||
call crlf;
|
||||
end;
|
||||
|
||||
end display$files;
|
||||
|
||||
end display;
|
||||
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
|
||||
/* indices into disk parameter block, used as parameters to dpb procedure */
|
||||
|
||||
dcl spt$w lit '0',
|
||||
blkshf$b lit '2',
|
||||
blkmsk$b lit '3',
|
||||
extmsk$b lit '4',
|
||||
blkmax$w lit '5',
|
||||
dirmax$w lit '7',
|
||||
dirblk$w lit '9',
|
||||
chksiz lit '11',
|
||||
offset$w lit '13';
|
||||
|
||||
|
||||
@@ -0,0 +1,51 @@
|
||||
$compact
|
||||
$title ('SDIR 8086 - Get Disk Parameters')
|
||||
dpb86:
|
||||
do;
|
||||
/* the purpose of this module is to allow independence */
|
||||
/* of processor, i.e., 8080 or 8086 */
|
||||
|
||||
$include (comlit.lit)
|
||||
|
||||
/* 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) block size = shl(double(128),blkshf)
|
||||
blkmsk (1 byte) sector# and blkmsk = block number
|
||||
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
|
||||
*/
|
||||
|
||||
$include(dpb.lit)
|
||||
|
||||
declare k$per$block byte public;
|
||||
declare dpb$base pointer;
|
||||
declare dpb$array based dpb$base (15) byte;
|
||||
|
||||
mon4: procedure (f,a) pointer external;
|
||||
dcl f byte, a address;
|
||||
end mon4;
|
||||
|
||||
dcl get$dpb lit '31';
|
||||
|
||||
dpb$byte: procedure(param) byte public;
|
||||
dcl param byte;
|
||||
return(dpb$array(param));
|
||||
end dpb$byte;
|
||||
|
||||
dpb$word: procedure(param) address public;
|
||||
dcl param byte;
|
||||
return(dpb$array(param) + shl(double(dpb$array(param+1)),8));
|
||||
end dpb$word;
|
||||
|
||||
base$dpb: procedure public;
|
||||
dpb$base = mon4(get$dpb,0);
|
||||
k$per$block = shr(dpb$byte(blkmsk$b)+1 ,3);
|
||||
end base$dpb;
|
||||
|
||||
end dpb86;
|
||||
|
||||
@@ -0,0 +1,361 @@
|
||||
title 'Disk Boot for CompuPro DISK1'
|
||||
;*******************************************************
|
||||
; Last Modification: 10/14/83
|
||||
;
|
||||
; D i s k B O O T
|
||||
;
|
||||
; The following code is written onto track 0 sector
|
||||
; 0 -3 of the disk. This routine is read into memory
|
||||
; at location 0000:0100h by the CompuPro PROM. This
|
||||
; routine then loads the system loader into memory.
|
||||
;
|
||||
; The format of the CompuPro Floppy Disk Boot sectors
|
||||
; are as follows:
|
||||
;
|
||||
; Trk Sectors Description
|
||||
; --- ------- -----------
|
||||
; 0 1 thru 4 Disk Boot program (this routine)
|
||||
;
|
||||
; 5 Loader Group Header
|
||||
; 6 thru 26 Loader Part 1
|
||||
;
|
||||
; 1 1 thru ? Loader Part 2 (remainder not on track 0)
|
||||
; Number of sectors is determined by
|
||||
; disk density and format.
|
||||
;
|
||||
; The following commands are used to generate DSKBOOT.CMD
|
||||
; as an 8080 model routine
|
||||
; RASM86 DSKBOOT
|
||||
; LINK86 DSKBOOT.SYS = DSKBOOT [DATA[ORIGIN[0]]]
|
||||
;
|
||||
; The following commands are used to generate the
|
||||
; boot tracks image in the file BOOTTRKS
|
||||
; SID86
|
||||
; #RDSKBOOT.SYS ;strips header and
|
||||
; #WBOOT,180,37F ;default base page
|
||||
; PIP BOOTTRKS = BOOT[O],CPMLDR.SYS[O]
|
||||
;
|
||||
;*******************************************************
|
||||
|
||||
N_TRK equ 26 ;sectors in Track 0
|
||||
N_BOOT equ 4 ;sectors for Boot
|
||||
|
||||
; Assembly Constants
|
||||
FDPORT equ 0C0H ;base port address for DISK1 Controller
|
||||
FDC_S equ FDPORT ;8272 status register
|
||||
FDC_D equ FDPORT+1 ;8272 data register
|
||||
D1_DMA equ FDPORT+2 ;DISK1 DMA address (when write)
|
||||
D1_INTS equ FDPORT+2 ;DISK1 status Register (when read)
|
||||
|
||||
DELCNT equ 5*1000 ;delay count for 5 MHz processor
|
||||
RQM_DELAY equ 5 ;12us delay count for master status
|
||||
|
||||
; Intel 8272 controller function definitions
|
||||
; Specify (00) command
|
||||
F_SPEC equ 03 ;specify
|
||||
F_DSTS equ 04 ;drive status
|
||||
F_RDAT equ 06 ;read data
|
||||
F_RECA equ 07 ;recalibrate
|
||||
F_RSTS equ 08 ;read status
|
||||
F_RID equ 0Ah ;read ID
|
||||
F_SEEK equ 0Fh ;seek
|
||||
|
||||
SRT equ 16-8 ;shuggart 800s
|
||||
HUT equ 240/16 ;head unload = 240 ms
|
||||
HLT equ (35+1)/2 ;head load = 35 ms
|
||||
ND equ 00 ;set DMA mode
|
||||
|
||||
cgroup group code,data ;force code and data into 8080 model
|
||||
|
||||
;-------------------------------------------------------
|
||||
; Bootstrap load.
|
||||
; Do not change any addresses from here to START:
|
||||
; Entry CL= Board switches from CompuPro PROM (0 .. 3)
|
||||
|
||||
CSEG
|
||||
org 0100H ;origin for 8080 model
|
||||
|
||||
nop! nop! nop ;these instructions have already
|
||||
nop! nop! nop ; been prefetched from the
|
||||
nop ; CompuPro boot PROM
|
||||
|
||||
; Start of Boot code.
|
||||
; Save board option value.
|
||||
; Load bios.
|
||||
start:
|
||||
;=====
|
||||
cli
|
||||
mov ax,cs
|
||||
mov es,ax
|
||||
mov ss,ax ;switch to local stack in base page
|
||||
mov sp,offset stack ;area from 0080h down
|
||||
xor bx,bx! mov ds,bx
|
||||
mov opts,cl ;save DISK1 board options switch
|
||||
mov ds,ax ;DS = CS, 8080 model
|
||||
retry:
|
||||
mov si,offset spec ;specify controller parameters
|
||||
mov cl,LSPEC ;length of specify command
|
||||
call send_command ;send command to 8272
|
||||
;SI = offset of recal command
|
||||
mov cl,LRECAL ;length of recal command
|
||||
call send_command ;Recalibrate drive
|
||||
end_rcal:
|
||||
in al,D1_INTS ;interrupts are disabled, so we
|
||||
or al,al! jns end_rcal ;poll for command completion
|
||||
|
||||
mov al,F_RSTS ;send sense interrupt status to 8272
|
||||
out FDC_D,al ;required after recal command
|
||||
mov cx,250 ;Leave lite on for 1/4 second
|
||||
call delay
|
||||
call wait_rqm ;wait for drive ready
|
||||
in al,FDC_D ;get status 0 from 8272
|
||||
sub al,020h ;remove seek end bit
|
||||
mov cl,al
|
||||
call wait_rqm ;wait for drive ready
|
||||
in al,FDC_D ;get present cylinder number
|
||||
or al,cl! jnz error ;error if not on track 0 after recal
|
||||
|
||||
mov ax,ds ;setup AX to segment address of CMD
|
||||
add ax,offset header_buf/16 ; header buffer in base page for DMA
|
||||
mov si,offset read_ghdr ;command to read loader group header
|
||||
call disk_read ;read loader group header
|
||||
jnz error ;if error
|
||||
|
||||
mov word ptr header_buf+1,0 ;setup offset for jump far to loader
|
||||
mov ax,word ptr header_buf+3 ;AX = segment address of DMA
|
||||
mov si,offset read ;command to read remainder of track 0
|
||||
call disk_read ;read remainder of track 0
|
||||
jz read_c1 ;if no errors
|
||||
|
||||
error: ; Disk error handler.
|
||||
;-----
|
||||
mov cx,2000 ;wait 2 seconds
|
||||
call delay ; and start all over again
|
||||
jmps retry
|
||||
|
||||
read_c1:
|
||||
mov si,offset seek ;seek to cylinder 1
|
||||
mov cl,LSEEK ;length of seek command
|
||||
call send_command ;send command to 8272
|
||||
end_seek:
|
||||
in al,D1_INTS ;interrupts are disabled, so we
|
||||
or al,al! jns end_seek ;poll for command completion
|
||||
|
||||
mov al,F_RSTS ;send sense interrupt status to 8272
|
||||
out FDC_D,al ;required after seek command
|
||||
call wait_rqm ;wait for drive ready
|
||||
in al,FDC_D ;get status 0 from 8272
|
||||
sub al,020h ;remove seek end bit
|
||||
mov cl,al
|
||||
call wait_rqm ;wait for drive ready
|
||||
in al,FDC_D ;get present cylinder number
|
||||
sub al,1 ;should be cylinder 1
|
||||
or al,cl! jnz error ;if error then delay and try again
|
||||
|
||||
;determine density and sector
|
||||
;size of cylinder 1
|
||||
mov al,F_RID + 040h ;setup to try double density first
|
||||
try_fm:
|
||||
mov si,offset readid ;read id to determine density
|
||||
mov [si],al ;set read command for desired density
|
||||
mov cl,LREADID ;length of read id command
|
||||
call execute ;execute command and read result bytes
|
||||
mov al,status ;get status 0 of result bytes
|
||||
or al,al! jz dens_ok
|
||||
mov al,readid
|
||||
xor al,040h ;toggle MFM flag
|
||||
test al,040h! jnz error ;tried FM and MFM then error
|
||||
jmps try_fm
|
||||
dens_ok:
|
||||
mov bl,status+6 ;get N field from result bytes
|
||||
and bx,3! shl bx,1 ; to determine sector size
|
||||
mov si,read1[bx] ;SI -> command to read side 0 of cyl 1
|
||||
|
||||
mov ax,word ptr header_buf+3
|
||||
add ax,(128*(26-5))/16 ;AX = DMA segment address for cyl 1
|
||||
call disk_read ;read cylinder 1
|
||||
jnz error ;if error delay and try again
|
||||
|
||||
jmpf dword ptr header_buf+1 ;the group header has been setup
|
||||
;to point to loader entry
|
||||
|
||||
wait_rqm: ;wait for drive ready
|
||||
;--------
|
||||
mov al,RQM_DELAY ;must delay 12us before polling
|
||||
w_rqm1: ;FDC status to insure valid results
|
||||
dec al ! jnz w_rqm1
|
||||
w_rqm2:
|
||||
in al,FDC_S ;get master status from 8272
|
||||
or al,al! jns w_rqm2 ;if no master ready bit
|
||||
ret
|
||||
|
||||
send_command: ; Send Function to Drive.
|
||||
;------------
|
||||
; Entry: SI -> command bytes
|
||||
; CL = length of command.
|
||||
; Exit: SI -> end of command + 1.
|
||||
|
||||
call wait_rqm ;wait for drive ready
|
||||
lodsb ;load command byte
|
||||
out FDC_D,al ;send to 8272 controller
|
||||
dec cl! jnz send_command ;if more bytes
|
||||
ret
|
||||
|
||||
disk_read: ; Disk Read.
|
||||
;---------
|
||||
; Entry: AX = segment address of DMA
|
||||
; SI -> Command (9 bytes)
|
||||
; Exit: SI -> End of Command + 1.
|
||||
; Z flag set if successful read
|
||||
|
||||
push ax ;compute 24 bit DMA address
|
||||
mov cl,4 ;for DISK1 DMA port
|
||||
shr ax,cl ;AX = most significant 16 bits
|
||||
xchg al,ah
|
||||
out D1_DMA,al ;send highest address byte
|
||||
xchg al,ah
|
||||
out D1_DMA,al ;send middle address byte
|
||||
pop ax
|
||||
shl ax,cl
|
||||
out D1_DMA,al ;send low address byte
|
||||
|
||||
mov cl,LREAD ;length of read command
|
||||
execute:
|
||||
call send_command ;send command to controller
|
||||
wait_int_1:
|
||||
in al,D1_INTS ;interrupts are disabled, so we
|
||||
or al,al! jns wait_int_1 ;poll for command completion
|
||||
|
||||
mov di,offset status ;SI -> to buffer to save result bytes
|
||||
mov cl,7 ;number of bytes to save
|
||||
get_status:
|
||||
call wait_rqm ;wait for drive ready
|
||||
in al,FDC_D ;read result byte
|
||||
stosb ;save in buffer
|
||||
dec cl! jnz get_status ;wait until all done
|
||||
|
||||
mov ax,word ptr status ;get status 0 and 1
|
||||
sub ax,8040h ;40h - zeros abnormal termination bit
|
||||
;80h - zeros end of cylinder status bit
|
||||
ret
|
||||
|
||||
delay: ;Delay process.
|
||||
;-----
|
||||
; Entry: CX = delay count (nominal milliseconds).
|
||||
; Exit: AL modified
|
||||
|
||||
mov al,DELCNT/26
|
||||
dely1:
|
||||
inc cx! dec cx
|
||||
dec al! jnz dely1 ;if not one millisecond
|
||||
|
||||
dec cx
|
||||
mov al,ch
|
||||
or al,cl! jnz delay ;if not requested time
|
||||
|
||||
ret
|
||||
|
||||
;-------------------------------------------------------
|
||||
DSEG
|
||||
|
||||
opts equ byte ptr .0040h
|
||||
stack equ word ptr .0080h
|
||||
header_buf equ byte ptr .0080h
|
||||
|
||||
; Disk setup command strings.
|
||||
spec db F_SPEC
|
||||
db SRT shl 4 + HUT
|
||||
db HLT shl 1 + ND
|
||||
LSPEC equ offset $ - offset spec
|
||||
|
||||
recal db F_RECA
|
||||
db 0
|
||||
LRECAL equ offset $ - offset recal
|
||||
|
||||
; Read Loader Group Header.
|
||||
read_ghdr db F_RDAT
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 0 ;Cylinder
|
||||
db 0 ;Head
|
||||
db N_BOOT+1 ;Record (sector) of Group
|
||||
db 0 ;Number of data bytes in sector
|
||||
db N_BOOT+1 ;EOT
|
||||
db 7 ;GPL
|
||||
db 128 ;DTL
|
||||
LRGHDR equ offset $ - offset read_ghdr
|
||||
|
||||
; Read remainder of track 0, sectors 6-26
|
||||
read db F_RDAT
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 0 ;Cylinder
|
||||
db 0 ;Head
|
||||
db N_BOOT+2 ;Record (sector) of BIOS
|
||||
db 0 ;Number of data bytes in sector
|
||||
db N_TRK ;Read to end of track
|
||||
db 7 ;GPL
|
||||
db 128 ;DTL
|
||||
LREAD equ offset $ - offset read
|
||||
|
||||
; Disk Seek command for controller
|
||||
seek db F_SEEK
|
||||
db 0
|
||||
db 1
|
||||
LSEEK equ offset $ - offset seek
|
||||
|
||||
readid db F_RID + 040h
|
||||
db 0
|
||||
LREADID equ offset $ - offset readid
|
||||
|
||||
status rb 7 ;buffer for status result bytes
|
||||
|
||||
read1 dw read_128
|
||||
dw read_256
|
||||
dw read_512
|
||||
dw read_1024
|
||||
|
||||
; Read function for single density (128 bytes/sec)
|
||||
read_128 db F_RDAT
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 1 ;Cylinder
|
||||
db 0 ;Head
|
||||
db 1 ;Record (sector) of BIOS
|
||||
db 0 ;Number of data bytes in sector
|
||||
db 26 ;Read to end of track
|
||||
db 007h ;GPL
|
||||
db 128 ;DTL
|
||||
|
||||
; Read function for double density (256 bytes/sec)
|
||||
read_256 db F_RDAT + 040h
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 1 ;Cylinder
|
||||
db 0 ;Head
|
||||
db 1 ;Record (sector) of BIOS
|
||||
db 1 ;Number of data bytes in sector
|
||||
db 26 ;Read to end of track
|
||||
db 00Eh ;GPL
|
||||
db 255 ;DTL
|
||||
|
||||
; Read function for double density (512 bytes/sec)
|
||||
read_512 db F_RDAT + 040h
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 1 ;Cylinder
|
||||
db 0 ;Head
|
||||
db 1 ;Record (sector) of BIOS
|
||||
db 2 ;Number of data bytes in sector
|
||||
db 15 ;Read to end of track
|
||||
db 01Bh ;GPL
|
||||
db 255 ;DTL
|
||||
|
||||
; Read function for double density (1024 bytes/sec)
|
||||
read_1024 db F_RDAT + 040h
|
||||
db 0 ;hds,ds1,ds0
|
||||
db 1 ;Cylinder
|
||||
db 0 ;Head
|
||||
db 1 ;Record (sector) of BIOS
|
||||
db 3 ;Number of data bytes in sector
|
||||
db 8 ;Read to end of track
|
||||
db 035h ;GPL
|
||||
db 255 ;DTL
|
||||
|
||||
END
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
|
||||
declare
|
||||
f$drvusr lit '0', /* drive/user byte */
|
||||
f$name lit '1', /* file name */
|
||||
f$namelen 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$cr lit '32', /* current record */
|
||||
f$rrec lit '33', /* random record */
|
||||
f$rreco lit '35'; /* " " overflow */
|
||||
|
||||
|
||||
@@ -0,0 +1,16 @@
|
||||
|
||||
/* file info record for SDIR - note if this structure changes in size */
|
||||
/* the multXX: routine in the sort.plm module must also change */
|
||||
|
||||
declare
|
||||
f$info$structure lit 'structure(
|
||||
usr byte, name (8) byte, type (3) byte, onekblocks address,
|
||||
kbytes address, recs$lword address, recs$hbyte byte,
|
||||
hash$link address, x$i$adr address)';
|
||||
declare
|
||||
x$info$structure lit 'structure (
|
||||
create (4) byte,
|
||||
update (4) byte,
|
||||
passmode byte)';
|
||||
|
||||
|
||||
@@ -0,0 +1,6 @@
|
||||
|
||||
dcl form$short lit '0', /* format values for SDIR */
|
||||
form$size lit '1',
|
||||
form$full lit '2';
|
||||
|
||||
|
||||
@@ -0,0 +1,822 @@
|
||||
$title('Concurrent CP/M System Loader Generation')
|
||||
genldr:
|
||||
do;
|
||||
|
||||
/*
|
||||
Copyright (C) 1983,1984
|
||||
Digital Research, Inc.
|
||||
P.O. Box 579
|
||||
Pacific Grove, CA 93950
|
||||
*/
|
||||
|
||||
/*
|
||||
Revised:
|
||||
03 October 83 by Bruce Skidmore
|
||||
16 February 84 by GLP
|
||||
*/
|
||||
|
||||
declare true literally '0FFH';
|
||||
declare false literally '0';
|
||||
declare forever literally 'while true';
|
||||
declare boolean literally 'byte';
|
||||
declare cr literally '0dh';
|
||||
declare lf literally '0ah';
|
||||
declare tab literally '09h';
|
||||
declare esc literally '1bh';
|
||||
declare bs literally '08h';
|
||||
declare bios$data$off literally '0180h';
|
||||
|
||||
declare reset label external;
|
||||
|
||||
declare fcb (1) byte external;
|
||||
declare fcb16 (1) byte external;
|
||||
declare tbuff (1) byte external;
|
||||
declare maxb address external;
|
||||
|
||||
declare bios$fcb (36) byte public initial (
|
||||
0,'LBIOS3 ','SYS',0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
||||
|
||||
declare bdos$fcb (36) byte public initial (
|
||||
0,'LBDOS3 ','SYS',0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
||||
|
||||
declare FCBout (36) byte public initial (
|
||||
0,'CPMLDR ','SYS',0,0,0,0,0,0,0,0,
|
||||
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
|
||||
|
||||
/*------------------------------------------------------------------------
|
||||
External Messages
|
||||
------------------------------------------------------------------------*/
|
||||
declare
|
||||
msg9120(16) byte external,
|
||||
msg9125 byte external,
|
||||
msg9135 byte external,
|
||||
msg9140 byte external,
|
||||
msg9145 byte external,
|
||||
msg9155 byte external,
|
||||
msg9160 byte external,
|
||||
msg9190 byte external,
|
||||
msg9195 byte external,
|
||||
msg9250 byte external,
|
||||
msg9255 byte external,
|
||||
msg9485 byte external,
|
||||
msg9490 byte external,
|
||||
msg9495 byte external,
|
||||
msg9500 byte external,
|
||||
msg9505 byte external;
|
||||
|
||||
declare sctbfr (1) structure (
|
||||
record (128) byte) public at (.memory);
|
||||
|
||||
declare fcb$msg (13) byte public initial (' . $');
|
||||
|
||||
declare display boolean public;
|
||||
|
||||
declare dma address public;
|
||||
|
||||
declare osbase address public;
|
||||
|
||||
declare buff$base address public;
|
||||
|
||||
mon1:
|
||||
procedure (func,info) external;
|
||||
declare func byte;
|
||||
declare info address;
|
||||
end mon1;
|
||||
|
||||
mon2:
|
||||
procedure (func,info) byte external;
|
||||
declare func byte;
|
||||
declare info address;
|
||||
end mon2;
|
||||
|
||||
/*
|
||||
B D O S P r o c e d u r e & F u n c t i o n C a l l s
|
||||
*/
|
||||
|
||||
system$reset:
|
||||
procedure public;
|
||||
call mon1 (0,0);
|
||||
end system$reset;
|
||||
|
||||
write$console:
|
||||
procedure (char) public;
|
||||
declare char byte;
|
||||
if display then
|
||||
call mon1 (2,char);
|
||||
end write$console;
|
||||
|
||||
print$buf:
|
||||
procedure (buffer$address) public;
|
||||
declare buffer$address address;
|
||||
if display then
|
||||
call mon1 (9,buffer$address);
|
||||
end print$buf;
|
||||
|
||||
crlf:
|
||||
procedure public;
|
||||
call write$console (cr);
|
||||
call write$console (lf);
|
||||
end crlf;
|
||||
|
||||
error:
|
||||
procedure(term$code,err$type,err$msg$adr) public;
|
||||
declare (term$code,err$type) byte;
|
||||
declare err$msg$adr address;
|
||||
declare (i,temp) byte;
|
||||
|
||||
temp = display;
|
||||
display = true;
|
||||
call crlf;
|
||||
call print$buf (.msg9125);
|
||||
call print$buf (err$msg$adr);
|
||||
if err$type = 1 then
|
||||
call print$buf(.fcb$msg);
|
||||
if term$code then
|
||||
call system$reset;
|
||||
call crlf;
|
||||
display = temp;
|
||||
|
||||
end error;
|
||||
|
||||
open$file:
|
||||
procedure (fcb$address) byte public;
|
||||
declare fcb$address address;
|
||||
declare fcb based fcb$address (1) byte;
|
||||
fcb(12), /* ex = 0 */
|
||||
fcb(32) = 0; /* cr = 0 */
|
||||
return mon2 (15,fcb$address);
|
||||
end open$file;
|
||||
|
||||
close$file:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
call mon1 (16,fcb$address);
|
||||
end close$file;
|
||||
|
||||
delete$file:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
call mon1 (19,fcb$address);
|
||||
end delete$file;
|
||||
|
||||
read$record:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
if mon2 (20,fcb$address) <> 0 then
|
||||
do;
|
||||
call error(true,1,.msg9135);
|
||||
end;
|
||||
end read$record;
|
||||
|
||||
write$record:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
if mon2 (21,fcb$address) <> 0 then
|
||||
do;
|
||||
call error(true,1,.msg9140);
|
||||
end;
|
||||
end write$record;
|
||||
|
||||
create$file:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
declare fcb based fcb$address (1) byte;
|
||||
if mon2 (22,fcb$address) = 255 then
|
||||
do;
|
||||
call error(true,0,.msg9145);
|
||||
end;
|
||||
fcb(32) = 0; /* set cr = 0 */
|
||||
end create$file;
|
||||
|
||||
set$DMA$address:
|
||||
procedure (DMA$address) public;
|
||||
declare DMA$address address;
|
||||
call mon1 (26,DMA$address);
|
||||
end set$DMA$address;
|
||||
|
||||
read$random$record:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
if mon2 (33,fcb$address) <> 0 then
|
||||
do;
|
||||
call error(true,1,.msg9135);
|
||||
end;
|
||||
end read$random$record;
|
||||
|
||||
write$random$record:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
if mon2 (34,fcb$address) <> 0 then
|
||||
do;
|
||||
call error(true,1,.msg9140);
|
||||
end;
|
||||
end write$random$record;
|
||||
|
||||
set$random$record:
|
||||
procedure (fcb$address) public;
|
||||
declare fcb$address address;
|
||||
call mon1 (36,fcb$address);
|
||||
end set$random$record;
|
||||
|
||||
setbuf:
|
||||
procedure external;
|
||||
end setbuf;
|
||||
|
||||
|
||||
/*
|
||||
D a t a S t r u c t u r e s
|
||||
*/
|
||||
|
||||
declare data$base address public;
|
||||
declare data$end address public;
|
||||
declare act$data$end address public;
|
||||
declare act$buf$end address public;
|
||||
|
||||
declare bdos$atts(4) address public;
|
||||
declare bios$atts(4) address public;
|
||||
declare (sys$clen,sys$cbase,sys$dlen,sys$dbase) address public;
|
||||
declare (dblk$last,dblk$next) address public;
|
||||
|
||||
declare add$buf$adr address public;
|
||||
declare add$buf based add$buf$adr structure (
|
||||
base address,
|
||||
len address);
|
||||
|
||||
declare drvtbl$adr address public;
|
||||
declare drvtbl based drvtbl$adr (16) address;
|
||||
|
||||
declare dph$adr address public;
|
||||
declare dph based dph$adr structure (
|
||||
xlt address,
|
||||
scratch1 address,
|
||||
scratch2 byte,
|
||||
mf byte,
|
||||
scratch3 address,
|
||||
dpb address,
|
||||
csv address,
|
||||
alv address,
|
||||
dirbcb address,
|
||||
dtabcb address,
|
||||
hash address,
|
||||
init address,
|
||||
login address,
|
||||
read address,
|
||||
write address,
|
||||
unit byte,
|
||||
chnnl byte,
|
||||
fcnt byte);
|
||||
|
||||
declare dpb$adr address public;
|
||||
declare dpb based dpb$adr structure (
|
||||
spt address,
|
||||
bsh byte,
|
||||
blm byte,
|
||||
exm byte,
|
||||
dsm address,
|
||||
drm address,
|
||||
al0 byte,
|
||||
al1 byte,
|
||||
cks address,
|
||||
off address,
|
||||
psh byte,
|
||||
phm byte);
|
||||
|
||||
declare header$adr address;
|
||||
declare header$rec based header$adr structure (
|
||||
gtype byte,
|
||||
len address,
|
||||
base address,
|
||||
min address,
|
||||
max address);
|
||||
|
||||
declare base$pg$adr address public;
|
||||
declare base$pg based base$pg$adr structure(
|
||||
clenw address,
|
||||
clenb byte,
|
||||
cbase address,
|
||||
m80 byte,
|
||||
dlenw address,
|
||||
dlenb byte,
|
||||
dbase address,
|
||||
res1 byte,
|
||||
elenw address,
|
||||
elenb byte,
|
||||
ebase address,
|
||||
res2 byte,
|
||||
slenw address,
|
||||
slenb byte,
|
||||
sbase address,
|
||||
res3 byte);
|
||||
|
||||
declare temp$fcb$adr address public;
|
||||
declare temp$fcb based temp$fcb$adr structure(
|
||||
drv byte,
|
||||
name(8) byte,
|
||||
type(3) byte,
|
||||
ex byte,
|
||||
s1 byte,
|
||||
s2 byte,
|
||||
rc byte,
|
||||
dm(16) byte,
|
||||
cur$rec byte,
|
||||
rr address,
|
||||
r2 byte);
|
||||
|
||||
/*
|
||||
L o c a l P r o c e d u r e s
|
||||
*/
|
||||
|
||||
movef:
|
||||
procedure (count,source$adr,dest$adr) public;
|
||||
declare count address;
|
||||
declare (source$adr,dest$adr) address;
|
||||
|
||||
if count = 0
|
||||
then return;
|
||||
else call move (count,source$adr,dest$adr);
|
||||
|
||||
end movef;
|
||||
|
||||
upper:
|
||||
procedure(b) byte public;
|
||||
declare b byte;
|
||||
|
||||
if b < ' ' then return cr; /* all non-graphics */
|
||||
/* translate alpha to upper case */
|
||||
if b >= msg9155 and b <= msg9160 then
|
||||
b = b and 101$1111b; /* upper case */
|
||||
return b;
|
||||
end upper;
|
||||
|
||||
dsply$hex:
|
||||
procedure (val) public;
|
||||
declare val byte;
|
||||
call write$console (msg9120(shr (val,4)));
|
||||
call write$console (msg9120(val and 0fh));
|
||||
end dsply$hex;
|
||||
|
||||
dsply$hex$adr:
|
||||
procedure (val) public;
|
||||
declare val address;
|
||||
call dsply$hex (high (val));
|
||||
call dsply$hex (low (val));
|
||||
call write$console (msg9195);
|
||||
end dsply$hex$adr;
|
||||
|
||||
get$param:
|
||||
procedure (val$adr) public;
|
||||
declare (val$adr) address;
|
||||
declare word$val based val$adr address;
|
||||
declare base byte;
|
||||
declare (char) byte;
|
||||
declare (lbindx) byte;
|
||||
|
||||
lbindx = 0;
|
||||
word$val = 0;
|
||||
base = 16;
|
||||
do while (char := upper(tbuff(lbindx:=lbindx+1))) <> cr;
|
||||
if char = msg9190 then
|
||||
do;
|
||||
base = 10;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
char = char - '0';
|
||||
if (base = 16) and (char > 9) then
|
||||
do;
|
||||
if char > 16
|
||||
then char = char - 7;
|
||||
else char = 255;
|
||||
end;
|
||||
if char < base then
|
||||
do;
|
||||
word$val = word$val*base + char;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
call error (true,0,.msg9250);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end get$param;
|
||||
|
||||
get$atts:
|
||||
procedure (fcb$adr,atts$adr);
|
||||
declare fcb$adr address;
|
||||
declare atts$adr address;
|
||||
declare atts based atts$adr (4) address;
|
||||
declare i byte;
|
||||
|
||||
call movef(8,fcb$adr+1,.fcb$msg);
|
||||
call movef(3,fcb$adr+9,.fcb$msg+9);
|
||||
|
||||
if openfile(fcb$adr) = 0ffh then
|
||||
call error(true,1,.msg9255);
|
||||
|
||||
header$adr = .sctbfr(0);
|
||||
call set$DMA$address(header$adr);
|
||||
|
||||
call read$record(fcb$adr);
|
||||
|
||||
do i = 0 to 3;
|
||||
atts(i) = 0;
|
||||
end;
|
||||
|
||||
do i = 0 to 3;
|
||||
if (header$rec.gtype <> 0) and (header$rec.gtype < 5) then
|
||||
atts(header$rec.gtype-1) = header$rec.len;
|
||||
header$adr = header$adr + 9;
|
||||
end;
|
||||
|
||||
end get$atts;
|
||||
|
||||
buf$seg$blk:
|
||||
procedure(space,fcb$adr) public;
|
||||
declare space address;
|
||||
declare fcb$adr address;
|
||||
declare i byte;
|
||||
|
||||
if (dma+space) > (buff$base+1000H) then
|
||||
do;
|
||||
call movef(8,.FCBout+1,.fcb$msg);
|
||||
call movef(3,.FCBout+9,.fcb$msg+9);
|
||||
|
||||
do i = 0 to 30;
|
||||
call set$DMA$address(buff$base + (128 * i));
|
||||
call write$record(.FCBout);
|
||||
end;
|
||||
call movef(double(128),buff$base+0f80h,buff$base);
|
||||
dma = dma - 0f80H;
|
||||
call set$DMA$address(dma);
|
||||
|
||||
call movef(8,fcb$adr+1,.fcb$msg);
|
||||
call movef(3,fcb$adr+9,.fcb$msg+9);
|
||||
|
||||
end;
|
||||
end buf$seg$blk;
|
||||
|
||||
|
||||
read$write$seg:
|
||||
procedure (fcb$adr,seg$len) public;
|
||||
declare fcb$adr address;
|
||||
declare seg$len address;
|
||||
declare seg$rec$len address;
|
||||
declare i address;
|
||||
|
||||
call movef(8,fcb$adr+1,.fcb$msg);
|
||||
call movef(3,fcb$adr+9,.fcb$msg+9);
|
||||
|
||||
if seg$len = 0 then return;
|
||||
seg$rec$len = (seg$len-1) / 8; /* convert para length to records */
|
||||
|
||||
call set$DMA$address(dma);
|
||||
do i = 0 to seg$rec$len;
|
||||
call buf$seg$blk(double(128),fcb$adr);
|
||||
call read$record(fcb$adr);
|
||||
call set$DMA$address(dma := dma + 128);
|
||||
end;
|
||||
|
||||
end read$write$seg;
|
||||
|
||||
read$seg:
|
||||
procedure (fcb$adr,seg$len) public;
|
||||
declare fcb$adr address;
|
||||
declare seg$len address;
|
||||
declare seg$rec$len address;
|
||||
declare i address;
|
||||
|
||||
call movef(8,fcb$adr+1,.fcb$msg);
|
||||
call movef(3,fcb$adr+9,.fcb$msg+9);
|
||||
|
||||
if seg$len = 0 then return;
|
||||
seg$rec$len = (seg$len-1) / 8; /* convert para length to records */
|
||||
|
||||
call set$DMA$address(dma);
|
||||
do i = 0 to seg$rec$len;
|
||||
call read$record(fcb$adr);
|
||||
call set$DMA$address(dma := dma + 128);
|
||||
end;
|
||||
|
||||
end read$seg;
|
||||
|
||||
write$seg:
|
||||
procedure (fcb$adr,seg$len) public;
|
||||
declare fcb$adr address;
|
||||
declare seg$len address;
|
||||
declare seg$rec$len address;
|
||||
declare i address;
|
||||
|
||||
call movef(8,fcb$adr+1,.fcb$msg);
|
||||
call movef(3,fcb$adr+9,.fcb$msg+9);
|
||||
|
||||
if seg$len = 0 then return;
|
||||
seg$rec$len = (seg$len-1) / 8; /* convert para length to records */
|
||||
|
||||
call set$DMA$address(dma);
|
||||
do i = 0 to seg$rec$len;
|
||||
call write$record(fcb$adr);
|
||||
call set$DMA$address(dma := dma + 128);
|
||||
end;
|
||||
|
||||
end write$seg;
|
||||
|
||||
setup$sysdat:
|
||||
procedure public;
|
||||
declare sysdat$adr address;
|
||||
declare sysdat based sysdat$adr structure(
|
||||
iosentry$off address,
|
||||
iosentry$seg address,
|
||||
iosinit$off address,
|
||||
iosinit$seg address,
|
||||
ldrentry$off address,
|
||||
ldrentry$seg address);
|
||||
|
||||
sysdat$adr = data$base; /* Point to SYSTEM Data Area */
|
||||
|
||||
/* Setup the pointer to the BIOS entry point */
|
||||
sysdat.iosentry$off = 3; /* Should be 3 */
|
||||
sysdat.iosentry$seg = sys$cbase + bdos$atts(0); /* BIOS code segment */
|
||||
|
||||
/* Setup the pointer to the BIOS init point */
|
||||
sysdat.iosinit$off = 0; /* Should be 0 but the Linker adds 5 */
|
||||
sysdat.iosinit$seg = sys$cbase + bdos$atts(0); /* BIOS code segment */
|
||||
|
||||
/* Setup the Loader entry point */
|
||||
sysdat.ldrentry$off = 6;
|
||||
sysdat.ldrentry$seg = sys$cbase + bdos$atts(0);
|
||||
|
||||
return;
|
||||
end setup$sysdat;
|
||||
|
||||
set$value:
|
||||
procedure (seg,byteoff,value) public;
|
||||
declare (seg,value) address;
|
||||
declare byteoff byte;
|
||||
declare setword$adr address;
|
||||
declare setword based setword$adr address;
|
||||
|
||||
if temp$fcb.rr <> seg/8 then
|
||||
do;
|
||||
temp$fcb.rr = seg/8;
|
||||
temp$fcb.r2 = 0;
|
||||
call read$random$record(temp$fcb$adr);
|
||||
end;
|
||||
setword$adr = buff$base + ((seg and 7)*16) + byteoff;
|
||||
setword = value;
|
||||
call write$random$record(temp$fcb$adr);
|
||||
|
||||
end set$value;
|
||||
|
||||
fixup$segs:
|
||||
procedure public;
|
||||
|
||||
call set$DMA$address(buff$base);
|
||||
temp$fcb$adr = .FCBout;
|
||||
temp$fcb.rr = 0FFFFh;
|
||||
temp$fcb.r2 = 0FFh;
|
||||
|
||||
call set$value(8,6,sys$dbase);
|
||||
call set$value(bdos$atts(0)+8,9,sys$dbase);
|
||||
|
||||
return;
|
||||
end fixup$segs;
|
||||
|
||||
|
||||
initialization:
|
||||
procedure public;
|
||||
declare (first,next,bracket) byte;
|
||||
|
||||
first = 1;
|
||||
next = 1;
|
||||
bracket = false;
|
||||
if tbuff(0) <> 0 then
|
||||
do;
|
||||
do while(next <= tbuff(0)+1);
|
||||
if (tbuff(next) = ' ') or (tbuff(next) = tab) or (tbuff(next) = msg9485)
|
||||
or (tbuff(next) = msg9490) then
|
||||
do;
|
||||
if tbuff(next) = msg9485 then
|
||||
bracket = true;
|
||||
tbuff(next) = 0;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
tbuff(first) = tbuff(next);
|
||||
first = first + 1;
|
||||
end;
|
||||
next = next + 1;
|
||||
end;
|
||||
tbuff(0) = first - 2;
|
||||
|
||||
if bracket = true then
|
||||
do;
|
||||
call get$param(.osbase);
|
||||
end;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
call error(true,0,.msg9495);
|
||||
end;
|
||||
|
||||
end initialization;
|
||||
|
||||
setup$sys$file:
|
||||
procedure public;
|
||||
declare i byte;
|
||||
|
||||
call movef(8,.FCBout+1,.fcb$msg);
|
||||
call movef(3,.FCBout+9,.fcb$msg+9);
|
||||
|
||||
call delete$file (.FCBout);
|
||||
|
||||
call create$file (.FCBout);
|
||||
|
||||
call movef(8,.FCBout+1,.fcb$msg);
|
||||
call movef(3,.FCBout+9,.fcb$msg+9);
|
||||
|
||||
dma = .sctbfr(0);
|
||||
buff$base = dma;
|
||||
|
||||
do i = 0 to 127;
|
||||
sctbfr(0).record(i) = 0;
|
||||
end;
|
||||
|
||||
call set$DMA$address (dma);
|
||||
call write$record (.FCBout);
|
||||
end setup$sys$file;
|
||||
|
||||
read$write$code:
|
||||
procedure public;
|
||||
declare i byte;
|
||||
declare flush$cnt address;
|
||||
|
||||
dma = buff$base;
|
||||
call read$write$seg(.bdos$fcb,bdos$atts(0));
|
||||
|
||||
dblk$last = (7 - ((bdos$atts(0)-1) and 7)) * 16;
|
||||
dma = dma - dblk$last;
|
||||
call read$write$seg(.bios$fcb,bios$atts(0));
|
||||
|
||||
dblk$last = (7 - ((bios$atts(0)-1) and 7)) * 16;
|
||||
|
||||
call movef(8,.FCBout+1,.fcb$msg);
|
||||
call movef(3,.FCBout+9,.fcb$msg+9);
|
||||
|
||||
dma = dma - dblk$last;
|
||||
flush$cnt = (dma-buff$base+127)/128 - 1;
|
||||
dma = buff$base;
|
||||
call set$DMA$address(dma);
|
||||
do i = 0 to flush$cnt;
|
||||
call write$record(.FCBout);
|
||||
call set$DMA$address(dma:=dma + 128);
|
||||
end;
|
||||
|
||||
call set$random$record(.bdos$fcb);
|
||||
call set$random$record(.bios$fcb);
|
||||
call set$random$record(.FCBout);
|
||||
temp$fcb$adr = .FCBout;
|
||||
temp$fcb.rr = temp$fcb.rr - 1;
|
||||
temp$fcb$adr = .bdos$fcb;
|
||||
temp$fcb.rr = temp$fcb.rr - 1;
|
||||
temp$fcb$adr = .bios$fcb;
|
||||
temp$fcb.rr = temp$fcb.rr - 1;
|
||||
|
||||
/* the following adjustments are to take care */
|
||||
/* of BIOS data ORG'ed at BIOS$DATA$OFF. */
|
||||
|
||||
temp$fcb.rr = temp$fcb.rr + bios$data$off/128;
|
||||
bios$atts(0) = bios$atts(0) + bios$data$off/16;
|
||||
bios$atts(1) = bios$atts(1) - bios$data$off/16;
|
||||
|
||||
end read$write$code;
|
||||
|
||||
|
||||
read$data:
|
||||
procedure public;
|
||||
|
||||
dma = buff$base + 128;
|
||||
call set$DMA$address(dma);
|
||||
call read$random$record(.FCBout);
|
||||
|
||||
call set$DMA$address(buff$base);
|
||||
call read$random$record(.bdos$fcb);
|
||||
call read$record(.bdos$fcb);
|
||||
dblk$next = (7 - ((bdos$atts(0)-1) and 7)) * 16;
|
||||
dblk$last = (7 - ((sys$clen-1) and 7)) * 16;
|
||||
call movef(dblk$next,(buff$base+128-dblk$next),(dma+128-dblk$last));
|
||||
dma = dma + (128 - dblk$last) + dblk$next;
|
||||
call read$seg(.bdos$fcb,bdos$atts(1) - (dblk$next/16));
|
||||
dma = dma - (7 - ((bdos$atts(1)-(dblk$next/16)-1) and 7)) * 16;
|
||||
|
||||
call set$DMA$address(buff$base);
|
||||
call read$random$record(.bios$fcb);
|
||||
call read$record(.bios$fcb);
|
||||
dblk$next = (7 - ((bios$atts(0) - 1) and 7)) * 16;
|
||||
dma = dma + bios$data$off - (bdos$atts(1)*16);
|
||||
call movef(dblk$next,(buff$base+128-dblk$next),dma);
|
||||
dma = dma + dblk$next;
|
||||
call read$seg(.bios$fcb,bios$atts(1) - (dblk$next/16));
|
||||
|
||||
end read$data;
|
||||
|
||||
write$bdos$bios$data:
|
||||
procedure public;
|
||||
|
||||
dma = buff$base;
|
||||
call write$seg(.FCBout,(bios$data$off/16)+bios$atts(1)+dblk$last/16);
|
||||
|
||||
end write$bdos$bios$data;
|
||||
|
||||
clean$up:
|
||||
procedure public;
|
||||
|
||||
header$adr = .sctbfr(0);
|
||||
call set$DMA$address(header$adr);
|
||||
FCBout(33), FCBout(34), FCBout(35) = 0;
|
||||
call read$random$record(.FCBout);
|
||||
|
||||
header$rec.gtype = 1;
|
||||
header$rec.len = sys$clen + sys$dlen;
|
||||
header$rec.base = sys$cbase;
|
||||
header$rec.min = sys$clen + sys$dlen;
|
||||
|
||||
header$adr = header$adr + 9;
|
||||
header$rec.base = sys$dbase;
|
||||
|
||||
call write$random$record(.FCBout);
|
||||
|
||||
call close$file(.FCBout);
|
||||
call close$file(.bios$fcb);
|
||||
call close$file(.bdos$fcb);
|
||||
|
||||
end clean$up;
|
||||
|
||||
print$epilog:
|
||||
procedure public;
|
||||
display = true;
|
||||
call print$buf (.msg9500);
|
||||
end print$epilog;
|
||||
|
||||
plm:
|
||||
procedure public;
|
||||
|
||||
/*
|
||||
G E N C P M M a i n P r o g r a m
|
||||
*/
|
||||
|
||||
call initialization;
|
||||
|
||||
call get$atts(.bdos$fcb,.bdos$atts);
|
||||
call get$atts(.bios$fcb,.bios$atts);
|
||||
|
||||
sys$clen = bdos$atts(0) + bios$atts(0);
|
||||
sys$cbase = osbase;
|
||||
sys$dlen = bios$atts(1);
|
||||
sys$dbase = sys$clen + osbase;
|
||||
|
||||
call setup$sys$file; /* Take care of creating the */
|
||||
/* system file. */
|
||||
|
||||
call read$write$code; /* Read the system code segments */
|
||||
/* and concatenate them. */
|
||||
call read$data; /* Read the system data segments */
|
||||
/* and concat. them. */
|
||||
dblk$last = 128 - dblk$last;
|
||||
dma = buff$base + 128;
|
||||
|
||||
buff$base = .sctbfr(0);
|
||||
call movef(dblk$last+(bios$atts(1)*16)+bios$data$off,dma,buff$base);
|
||||
data$base = buff$base + dblk$last;
|
||||
data$end = data$base + (bios$atts(1)*16)+bios$data$off;
|
||||
drvtbl$adr = data$base + bios$data$off; /* position the DRVTBL array */
|
||||
if drvtbl(0) = 0 then
|
||||
call error(true,0,.msg9505);
|
||||
|
||||
sys$dbase = sys$clen + osbase;
|
||||
act$data$end = data$end - data$base;
|
||||
|
||||
call setbuf; /* Set up all buffers */
|
||||
|
||||
bios$atts(1) = shr((data$end-data$base-bios$data$off+15),4);
|
||||
sys$dlen = act$buf$end - sys$dbase;
|
||||
|
||||
call setup$sysdat; /* Setup the system data. */
|
||||
|
||||
call write$bdos$bios$data; /* Write the combined and updated */
|
||||
/* data to the SYS file. */
|
||||
|
||||
call fixup$segs; /* Fixup the segment values */
|
||||
/* that were not known on the 1st */
|
||||
/* pass. */
|
||||
|
||||
call clean$up; /* Fix up the SYS file header and */
|
||||
/* close the file. */
|
||||
|
||||
call print$epilog;
|
||||
|
||||
end plm;
|
||||
end genldr;
|
||||
EOF
|
||||
|
||||
@@ -0,0 +1,8 @@
|
||||
rasm86 scd2
|
||||
rasm86 genmsg
|
||||
;
|
||||
udi plm86 genldr.plm optimize(3) xref
|
||||
udi plm86 ldrbuf.plm optimize(3) xref
|
||||
;
|
||||
link86 genldr=scd2,genldr,ldrbuf,genmsg[dat[ori[0],add[400],max[0]]]
|
||||
;
|
||||
@@ -0,0 +1,39 @@
|
||||
DSEG
|
||||
|
||||
public msg9120,msg9125,msg9135,msg9140,msg9145,msg9155,msg9160,msg9190
|
||||
public msg9195,msg9250,msg9255,msg9485,msg9490,msg9495,msg9500,msg9505
|
||||
|
||||
;;
|
||||
msg9120 db '0123456789ABCDEF'
|
||||
;;
|
||||
msg9125 db 'ERROR: $',0
|
||||
;;
|
||||
msg9135 db 'Reading file: $'
|
||||
;;
|
||||
msg9140 db 'Writing file: $'
|
||||
;;
|
||||
msg9145 db 'Directory full$',0
|
||||
;;
|
||||
msg9155 db 'a',0
|
||||
;;
|
||||
msg9160 db 'z',0
|
||||
;;
|
||||
msg9190 db '#',0
|
||||
;;
|
||||
msg9195 db 'H',0
|
||||
;;
|
||||
msg9250 db 'Must be a Hex or Decimal number$'
|
||||
;;
|
||||
msg9255 db 'Unable to open file $',0
|
||||
;;
|
||||
msg9485 db '[',0
|
||||
;;
|
||||
msg9490 db ']',0
|
||||
;;
|
||||
msg9495 db 'Loader base must be specified.$',0
|
||||
;;
|
||||
msg9500 db 0dh,0ah,'*** CCP/M SYSTEM LOADER GENERATION DONE ***',0dh,0ah,'$',0
|
||||
db 'DRI$',0
|
||||
;;
|
||||
msg9505 db 'Drive Table must contain at least 1 DPH address.$'
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,3 @@
|
||||
rasm86 lbdos3.a86
|
||||
link86 lbdos3.sys=lbdos3[data[ori[0],max[0]]]
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,200 @@
|
||||
$title ('GENLDR - Buffer allocation module')
|
||||
setup$buffers:
|
||||
do;
|
||||
|
||||
/*
|
||||
Copyright (C) 1982,1983,1984
|
||||
Digital Research
|
||||
P.O. Box 579
|
||||
Pacific Grove, CA 93950
|
||||
*/
|
||||
|
||||
/*
|
||||
Revised:
|
||||
03 October 83 by Bruce Skidmore
|
||||
*/
|
||||
|
||||
declare true literally '0FFH';
|
||||
declare false literally '0';
|
||||
declare forever literally 'while true';
|
||||
declare boolean literally 'byte';
|
||||
declare cr literally '0dh';
|
||||
declare lf literally '0ah';
|
||||
declare bcbsize literally '10h';
|
||||
declare bcbhsize literally '4';
|
||||
|
||||
/*
|
||||
D a t a S t r u c t u r e s
|
||||
*/
|
||||
|
||||
declare osbase address external;
|
||||
declare sys$dbase address external;
|
||||
declare sys$dlen address external;
|
||||
declare data$base address external;
|
||||
declare data$end address external;
|
||||
declare act$data$end address external;
|
||||
declare act$buf$end address external; /* paragraph value */
|
||||
|
||||
declare drvtbl$adr address external;
|
||||
declare drvtbl based drvtbl$adr (16) address;
|
||||
|
||||
declare dph$adr address external;
|
||||
declare dph based dph$adr structure (
|
||||
xlt address,
|
||||
scratch1 address,
|
||||
scratch2 byte,
|
||||
mf byte,
|
||||
scratch3 address,
|
||||
dpb address,
|
||||
csv address,
|
||||
alv address,
|
||||
dirbcb address,
|
||||
dtabcb address,
|
||||
hash address,
|
||||
unit byte,
|
||||
type byte,
|
||||
init address,
|
||||
login address,
|
||||
read address,
|
||||
write address);
|
||||
|
||||
declare dpb$adr address external;
|
||||
declare dpb based dpb$adr structure (
|
||||
spt address,
|
||||
bsh byte,
|
||||
blm byte,
|
||||
exm byte,
|
||||
dsm address,
|
||||
drm address,
|
||||
al0 byte,
|
||||
al1 byte,
|
||||
cks address,
|
||||
off address,
|
||||
psh byte,
|
||||
phm byte);
|
||||
|
||||
declare bcb$end address public;
|
||||
declare bcb$header based bcb$end structure(
|
||||
link address,
|
||||
bufmax byte);
|
||||
|
||||
declare bcb$adr address public;
|
||||
declare bcb based bcb$adr structure (
|
||||
drv byte,
|
||||
rec(3) byte,
|
||||
wflg byte,
|
||||
zero byte,
|
||||
track address,
|
||||
sector address,
|
||||
bufoff address,
|
||||
link address,
|
||||
resv address);
|
||||
|
||||
declare act$bcb$end address public;
|
||||
|
||||
declare rec$size address public;
|
||||
|
||||
/*
|
||||
L o c a l P r o c e d u r e s
|
||||
*/
|
||||
|
||||
zero$buf:
|
||||
procedure public;
|
||||
declare w$index address;
|
||||
declare mem$ptr address;
|
||||
declare bcb$buf$byte based mem$ptr byte;
|
||||
|
||||
mem$ptr = data$end; /* Zero memory where BCB's will be created */
|
||||
do w$index = 0 to 255;
|
||||
bcb$buf$byte = 0;
|
||||
mem$ptr = mem$ptr + 1;
|
||||
end;
|
||||
end zero$buf;
|
||||
|
||||
/* Setup Allocation Vectors and Checksum vectors as requested */
|
||||
setup$alv$csv:
|
||||
procedure public;
|
||||
|
||||
if dph.csv = 0ffffh then /* Setup Checksum vector */
|
||||
do;
|
||||
dph.csv = 0;
|
||||
end;
|
||||
if dph.alv = 0ffffh then /* Setup Allocation vector */
|
||||
do;
|
||||
dph.alv = 0;
|
||||
end;
|
||||
end setup$alv$csv;
|
||||
|
||||
setup$dirbufs: /* Setup Directory buffers and BCB's */
|
||||
procedure public;
|
||||
|
||||
if dph.dirbcb = 0ffffH then
|
||||
do;
|
||||
dph.dirbcb = act$bcb$end; /* Point dph to bcb header */
|
||||
act$bcb$end = act$bcb$end + bcbhsize;/* increment past bcb header */
|
||||
bcb$header.link = act$bcb$end;
|
||||
bcb$header.bufmax = 0ffh;
|
||||
bcb$end = bcb$end + bcbhsize;
|
||||
bcb$adr = bcb$end;
|
||||
bcb$end = bcb$end + bcbsize;
|
||||
act$bcb$end = act$bcb$end + bcbsize;
|
||||
bcb.drv = 0ffh;
|
||||
bcb.bufoff = act$data$end;
|
||||
bcb.link = 0;
|
||||
act$data$end = act$data$end + rec$size;
|
||||
end;
|
||||
end setup$dirbufs;
|
||||
|
||||
setup$databufs: /* Setup Data buffers and BCB's */
|
||||
procedure public;
|
||||
|
||||
if dph.dtabcb = 0ffffH then
|
||||
do;
|
||||
dph.dtabcb = act$bcb$end; /* Point dph to bcb header */
|
||||
act$bcb$end = act$bcb$end + bcbhsize;/* increment past bcb header */
|
||||
bcb$header.link = act$bcb$end;
|
||||
bcb$header.bufmax = 0ffh;
|
||||
bcb$end = bcb$end + bcbhsize;
|
||||
bcb$adr = bcb$end;
|
||||
bcb$end = bcb$end + bcbsize;
|
||||
act$bcb$end = act$bcb$end + bcbsize;
|
||||
bcb.drv = 0ffh;
|
||||
bcb.bufoff = act$buf$end;
|
||||
bcb.link = 0;
|
||||
act$buf$end = act$buf$end + rec$size/16;
|
||||
end;
|
||||
end setup$databufs;
|
||||
|
||||
|
||||
setbuf:
|
||||
procedure public;
|
||||
|
||||
act$data$end = (act$data$end+1) and 0FFFEH;/* make even */
|
||||
|
||||
if drvtbl(0) = 0 then /* one entry required */
|
||||
return;
|
||||
|
||||
call zero$buf;
|
||||
|
||||
dph$adr = drvtbl(0) + data$base;
|
||||
dpb$adr = dph.dpb + data$base;
|
||||
rec$size = shl(double(128),dpb.psh);
|
||||
|
||||
bcb$end = data$end; /* Maintain a ptr. to the current end of BCB's */
|
||||
act$bcb$end = act$data$end;/* BCB table base in gen'ed system */
|
||||
act$data$end = act$bcb$end + (bcbhsize+bcbsize)*2;
|
||||
|
||||
call setup$alv$csv; /* Setup Allocation and Checksum Vectors */
|
||||
call setup$dirbufs; /* Setup Directory buffers and BCB's */
|
||||
act$buf$end = sys$dbase + shr(act$data$end+15,4);
|
||||
call setup$databufs; /* Setup Data buffers and BCB's */
|
||||
|
||||
data$end = bcb$end;
|
||||
if dph.hash = 0ffffh then
|
||||
dph.hash = 0; /* Indicate no hash table for this drive */
|
||||
|
||||
end setbuf;
|
||||
|
||||
end setup$buffers;
|
||||
EOF
|
||||
|
||||
@@ -0,0 +1,109 @@
|
||||
|
||||
BOOT TRACKS CONSTRUCTION FOR THE COMPUPRO
|
||||
|
||||
The loader, which resides on the system tracks, is created with
|
||||
the following sequence of commands:
|
||||
|
||||
;; The following sequence of commands may be executed from
|
||||
;; a SUBMIT file.
|
||||
;
|
||||
RASM86 DSKBOOT
|
||||
;
|
||||
LINK86 DSKBOOT.SYS=DSKBOOT[DATA[ORIGIN[0]]]
|
||||
;
|
||||
RASM86 LBIOS
|
||||
;
|
||||
RASM86 LPROG
|
||||
;
|
||||
LINK86 LBIOS3.SYS=LBIOS,LPROG[DATA[ORIGIN[180]]]
|
||||
;
|
||||
;; GENLDR will create the CPMLDR.SYS
|
||||
;
|
||||
GENLDR [NNNN]
|
||||
;
|
||||
;; NNNN:0000 is where cpmldr will be loaded at boot time, so be careful that
|
||||
;; CCPM.SYS will not be loaded over your cpmldr.
|
||||
;;
|
||||
;; End of the SUBMIT file
|
||||
|
||||
Now read in the file DSKBOOT.SYS with DDT86 (this can't be done under
|
||||
SUBMIT) and remove the header and base page. This will allow you to
|
||||
merge this into the CPMLDR file.
|
||||
|
||||
A>DDT86
|
||||
-RDSKBOOT.SYS
|
||||
START END
|
||||
aaaa:0000 aaaa:37f
|
||||
-WBOOT,180,37F
|
||||
-^C
|
||||
|
||||
Now merge the two files with the following command line:
|
||||
|
||||
A>PIP BOOTTRKS=BOOT[O],CPMLDR.SYS[O]
|
||||
|
||||
Assemble and link the track copy utility with the following commands:
|
||||
|
||||
A>RASM86 TCOPY
|
||||
|
||||
A>LINK86 TCOPY
|
||||
|
||||
The final step is to execute TCOPY under a version of CP/M-86 1.X.
|
||||
|
||||
****************************************************************
|
||||
**** | Because TCOPY does direct BIOS calls, it will not | ****
|
||||
**** | execute under any other operating system. | ****
|
||||
****************************************************************
|
||||
|
||||
|
||||
A>TCOPY BOOTTRKS
|
||||
|
||||
You should now have a system loader on the boot tracks that will
|
||||
load a file called CCPM.SYS into memory and begin system ececution.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,251 @@
|
||||
title 'Concurrent CP/M Loader Program'
|
||||
;*******************************************************
|
||||
;
|
||||
; The Loader Program opens the file 'CCPM.SYS'
|
||||
; using the LBDOS and LBIOS and then reads it into
|
||||
; memory. The DS register is set to the start of
|
||||
; the Concurrent CP/M DATA area, and a JMPF to the first
|
||||
; byte of the Concurrent CP/M code is executed.
|
||||
;
|
||||
; The first 128 byte record of the CCPM.SYS file is
|
||||
; a header with the following format:
|
||||
;
|
||||
; +----+----+----+----+----+----+----+----+----+
|
||||
; |TYPE| LEN | ABS | MIN | MAX |
|
||||
; +----+----+----+----+----+----+----+----+----+
|
||||
;
|
||||
; type rb 1 ;seg type
|
||||
; len rw 1 ;length
|
||||
; abs dw 1 ;absolute segment address for LOADER
|
||||
; min rw 1 ;minimum mem
|
||||
; max rw 1 ;max mem needed
|
||||
;
|
||||
; The code is expected first and then the data
|
||||
; within the CCPM.SYS File. This header record
|
||||
; is constructed automatically by the system
|
||||
; generation utility GENCCPM. See the variables
|
||||
; declared at 'SEC1:' where the first sector of
|
||||
; the CCPM.SYS will be read.
|
||||
;
|
||||
; The following commands are used to generate CPMLDR.SYS
|
||||
; RASM86 LBIOS
|
||||
; RASM86 LPROG
|
||||
; LINK86 LBIOS3.SYS = LBIOS,LPROG [DATA[ORIGIN[0180]]]
|
||||
; GENLDR [nnnn]
|
||||
;
|
||||
; The following commands are used to generate the
|
||||
; boot tracks image BOOTTRKS
|
||||
; SID86
|
||||
; #RDSKBOOT.SYS ;strips header and
|
||||
; #WBOOT,180,37F ;default base page
|
||||
; PIP BOOTTRKS = BOOT[O],CPMLDR.SYS[O]
|
||||
;
|
||||
;*******************************************************
|
||||
|
||||
CR equ 13
|
||||
LF equ 10
|
||||
|
||||
CTYPE equ byte ptr 00h
|
||||
CLEN equ word ptr 01h
|
||||
CLDSEG equ word ptr 03h
|
||||
DTYPE equ byte ptr 09h
|
||||
DLEN equ word ptr 0Ah
|
||||
DLDSEG equ word ptr 0Ch
|
||||
|
||||
CODETYPE equ 1 ;code type CMD header
|
||||
DATATYPE equ 2 ;data type CMD header
|
||||
|
||||
; bdos function numbers
|
||||
|
||||
DRV_SET equ 14
|
||||
F_OPEN equ 15
|
||||
F_READ equ 20
|
||||
F_DMASET equ 26
|
||||
F_USERNUM equ 32
|
||||
F_MULTISEC equ 44
|
||||
F_DMA equ 51
|
||||
|
||||
|
||||
;*******************************************************
|
||||
;
|
||||
; LOADER starts here
|
||||
;
|
||||
;*******************************************************
|
||||
|
||||
CSEG
|
||||
org 0000h
|
||||
|
||||
public ?start
|
||||
extrn ?conout:near, ?pmsg:near
|
||||
|
||||
?start: ; loader entry from BDOS init
|
||||
;------
|
||||
mov si,offset signon ;print signon message
|
||||
call ?pmsg
|
||||
|
||||
mov dl,0
|
||||
mov cl,DRV_SET ! int 224 ;select boot drive
|
||||
|
||||
mov dl,0
|
||||
mov cl,F_USERNUM ! int 224 ;set user number
|
||||
|
||||
mov dx,offset ccpm_fcb
|
||||
mov cl,F_OPEN ! int 224 ;open CCPM.SYS file
|
||||
cmp al,255 ! jne perr ;insure no error on open
|
||||
mov si,offset nofile
|
||||
error:
|
||||
call ?pmsg ;print no SYSTEM file message
|
||||
halt:
|
||||
sti
|
||||
hlt ;then halt the machine
|
||||
jmps halt
|
||||
perr:
|
||||
mov dx,offset sec1
|
||||
mov cl,F_DMASET ! int 224 ;set DMA offset address
|
||||
|
||||
mov dl,1 ;set Multi-sector count to 1
|
||||
mov si,ds ;SI = DMA segment address
|
||||
call read_rec ;read first record
|
||||
|
||||
mov bx,offset sec1
|
||||
cmp CTYPE[bx],CODETYPE ;code type must = 1
|
||||
je chk_data
|
||||
badhdr:
|
||||
mov si,offset hdrerr
|
||||
jmp error
|
||||
chk_data:
|
||||
cmp DTYPE[bx],DATATYPE ;data type must = 2
|
||||
jne badhdr
|
||||
mov ax,CLDSEG[bx] ;code abs + code length
|
||||
add ax,CLEN[bx] ;should be = to data abs
|
||||
cmp ax,DLDSEG[bx] ! jne badhdr
|
||||
add ax,DLEN[bx]
|
||||
cmp ax,CLDSEG[bx] ;check for wrap around
|
||||
jbe badhdr
|
||||
mov ccpm_init,0000h ;set O.S. entry offset to 0000h
|
||||
mov ax,CLDSEG[bx]
|
||||
mov ccpm_init+2,ax ;set O.S. entry segment
|
||||
hdrok:
|
||||
mov si,offset csegmsg ;print out starting code and data
|
||||
call ?pmsg ; on console
|
||||
mov ax,word ptr sec1+CLDSEG
|
||||
call phex ;print base code segment
|
||||
mov si,offset dsegmsg
|
||||
call ?pmsg ;print base data segment
|
||||
mov ax,word ptr sec1+DLDSEG
|
||||
call phex
|
||||
|
||||
mov dx,0
|
||||
mov cl,F_DMASET ! int 224 ;set DMA offset to 0
|
||||
;set multi_sector count to 127
|
||||
mov dl,127 ;to align reads with physical sectors
|
||||
mov si,word ptr sec1+CLDSEG ;initial DMA segment
|
||||
call read_rec ;read next 127 sectors
|
||||
jz done ;Z flag set -> EOF
|
||||
add si,8*127 ;increment dma segment
|
||||
mov dl,128 ;set multi-sector count to 128
|
||||
call read_rec ;read next 128 sectors
|
||||
jz done ;Z flag set -> EOF
|
||||
readit1:
|
||||
add si,8*128 ;increment dma segment
|
||||
call read_data ;read next 128 sectors
|
||||
jnz readit1 ;Z flag set -> EOF
|
||||
done:
|
||||
mov si,offset crlf ;print carriage return, line feed
|
||||
call ?pmsg
|
||||
|
||||
mov ds,word ptr sec1+DLDSEG ;CCP/M data segment
|
||||
|
||||
jmpf cs:dword ptr ccpm_init ;leap to CCP/M initialization
|
||||
|
||||
;-------------------------------------------------------
|
||||
; subroutines
|
||||
;-------------------------------------------------------
|
||||
read_rec:
|
||||
;--------
|
||||
; Entry: DL = multisector count
|
||||
; SI = dma segment
|
||||
|
||||
mov cl,F_MULTISEC ! int 224 ;set multi-sector count to 128
|
||||
|
||||
read_data:
|
||||
;---------
|
||||
; Entry: SI = dma segment
|
||||
; Exit: Z flag set if EOF
|
||||
; Z flag reset if no error
|
||||
|
||||
mov dx,si
|
||||
mov cl,F_DMA ! int 224 ;set DMA segment for disk IO
|
||||
mov dx,offset ccpm_fcb
|
||||
mov cl,F_READ ! int 224 ;next 128 sector read
|
||||
cmp al,1! jnbe read_error
|
||||
ret
|
||||
read_error:
|
||||
mov si,offset rerr ;print READ ERROR message
|
||||
jmp error
|
||||
|
||||
phex: ;print 4 hex characters from ax
|
||||
;----
|
||||
; Entry: AX = hex value to print
|
||||
|
||||
mov cx,0404h ;4 in both CH and CL
|
||||
lhex:
|
||||
rol ax,cl ;rotate left 4
|
||||
push cx ! push ax ;save crucial registers
|
||||
call pnib ;print hex nibble
|
||||
pop ax ! pop cx ;restore registers
|
||||
dec ch ! jnz lhex ;and loop four times
|
||||
ret
|
||||
pnib: ;print low nibble in AL as hex char
|
||||
;----
|
||||
; Entry: AL = hex character to print
|
||||
|
||||
and al,0fh
|
||||
cmp al,9 ! ja p10 ;above 9 ?
|
||||
add al,'0' ;digit
|
||||
jmps prn
|
||||
p10:
|
||||
add al,'A'-10 ;hex digit A-F
|
||||
prn:
|
||||
mov dl,al
|
||||
|
||||
putchar:
|
||||
;-------
|
||||
; Entry: DL = character to send to console
|
||||
|
||||
mov cl,dl
|
||||
jmp ?conout
|
||||
|
||||
; code segment variable
|
||||
|
||||
ccpm_init rw 2 ;double word entry to Concurrent CP/M
|
||||
|
||||
;*******************************************************
|
||||
;
|
||||
; DATA AREA
|
||||
;
|
||||
;*******************************************************
|
||||
DSEG
|
||||
|
||||
signon db 'Concurrent CP/M System Loader V1.0 (02/16/84)',0
|
||||
nofile db CR,LF,'CCPM.SYS Not Found On Boot Disk',0
|
||||
rerr db CR,LF,'Error Reading CCPM.SYS',0
|
||||
hdrerr db CR,LF,'Bad Header Record in CCPM.SYS',0
|
||||
csegmsg db CR,LF,'Code Paragraph Address = ',0
|
||||
dsegmsg db CR,LF,'Data Paragraph Address = ',0
|
||||
crlf db CR,LF,0
|
||||
|
||||
ccpm_fcb db 0,'CCPM ','SYS',0,0,0,0
|
||||
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
|
||||
|
||||
db 0
|
||||
|
||||
;-------------------------------------------------------
|
||||
|
||||
sec1 rb 128 ;read first sector of CCPM.SYS
|
||||
;here (header record)
|
||||
|
||||
;*******************************************************
|
||||
|
||||
END
|
||||
|
||||
@@ -0,0 +1,602 @@
|
||||
|
||||
/* C P / M - M P / M D I R E C T O R Y C O M M O N (SDIR) */
|
||||
|
||||
/* B E G I N N I N G O F C O M M O N M A I N M O D U L E */
|
||||
|
||||
|
||||
/* This module is included in main80.plm or main86.plm. */
|
||||
/* The differences between 8080 and 8086 versions are */
|
||||
/* contained in the modules main80.plm, main86.plm and */
|
||||
/* dpb80.plm, dpb86.plm and the submit files showing */
|
||||
/* the different link and location addresses. */
|
||||
|
||||
/* REVISION history:
|
||||
/* Nov 82 Bill Fitler: convert from CP/M Plus to Concurrent CP/M-86 */
|
||||
/* Feb 83 F.Borda: Took out paging and breaking to allow type-ahead. */
|
||||
|
||||
$include (comlit.lit)
|
||||
$include (mon.plm)
|
||||
|
||||
|
||||
|
||||
/* Scanner Entry Points in scan.plm */
|
||||
|
||||
scan: procedure(pcb$adr) external;
|
||||
declare pcb$adr address;
|
||||
end scan;
|
||||
|
||||
scan$init: procedure(pcb$adr) external;
|
||||
declare pcb$adr address;
|
||||
end scan$init;
|
||||
|
||||
/* -------- Routines in other modules -------- */
|
||||
|
||||
search$init: procedure external; /* initialization of search.plm */
|
||||
end search$init;
|
||||
|
||||
get$files: procedure external; /* entry to search.plm */
|
||||
end get$files;
|
||||
|
||||
sort: procedure external; /* entry to sort.plm */
|
||||
end sort;
|
||||
|
||||
mult23: procedure (num) address external; /* in sort.plm */
|
||||
dcl num address;
|
||||
end mult23;
|
||||
|
||||
display$files: procedure external; /* entry to disp.plm */
|
||||
end display$files;
|
||||
|
||||
/* -------- Routines in util.plm -------- */
|
||||
|
||||
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 plmstart label public;
|
||||
|
||||
dcl (os,bdos) byte public;
|
||||
$include (vers.lit)
|
||||
|
||||
$include (fcb.lit)
|
||||
|
||||
$include(search.lit)
|
||||
|
||||
dcl find find$structure public initial
|
||||
(false,false,false,false, false,false,false,false);
|
||||
|
||||
dcl
|
||||
num$search$files byte public initial(0),
|
||||
no$page$mode byte public initial(0),
|
||||
search (max$search$files) search$structure public;
|
||||
|
||||
dcl first$f$i$adr address external;
|
||||
dcl get$all$dir$entries boolean public;
|
||||
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 */
|
||||
|
||||
$include (format.lit)
|
||||
|
||||
dcl format byte public initial (form$full),
|
||||
page$len address public initial (0ffffh),
|
||||
/* 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 */
|
||||
date$opt boolean public initial(false), /* dates display */
|
||||
display$attributes boolean public initial(false); /* attributes display */
|
||||
|
||||
dcl file$displayed boolean external;
|
||||
/* true if 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 */
|
||||
|
||||
|
||||
dcl cur$usr byte public, /* current user being searched */
|
||||
cur$drv byte public; /* current drive " " */
|
||||
|
||||
/* -------- BDOS calls --------- */
|
||||
|
||||
get$version: procedure address; /* returns current version information */
|
||||
return mon3(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;
|
||||
|
||||
/**************************************************** commented out whf
|
||||
getscbbyte: procedure (offset) byte;
|
||||
declare offset byte;
|
||||
declare scbpb structure
|
||||
(offset byte,
|
||||
set byte,
|
||||
value address);
|
||||
scbpb.offset = offset;
|
||||
scbpb.set = 0;
|
||||
return mon2(49,.scbpb);
|
||||
end getscbbyte;
|
||||
******************************************************/
|
||||
|
||||
set$console$mode: procedure;
|
||||
/* set console mode to control-c only */
|
||||
/********* call mon1(109,1); ********whf************/
|
||||
;
|
||||
end set$console$mode;
|
||||
|
||||
terminate: procedure public;
|
||||
call mon1 (0,0);
|
||||
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 */
|
||||
|
||||
/* help: procedure; COMMENTED OUT - HELP PROGRAM REPLACE DISPLAY
|
||||
|
||||
call print(.(cr,lf,
|
||||
tab,tab,tab,'DIR EXAMPLES',cr,lf,lf,
|
||||
'dir file.one',tab,tab,tab,
|
||||
'(find a file on current user and default drive)',cr,lf,
|
||||
'dir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)',
|
||||
cr,lf,
|
||||
'dir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf,
|
||||
'dir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf,
|
||||
'dir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf,
|
||||
'dir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf,
|
||||
'dir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf,
|
||||
'dir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf,
|
||||
'dir [full]',tab,tab,tab,'(show all file information)',cr,lf,
|
||||
'dir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf,
|
||||
'dir [short]',tab,tab,tab,'(show just the file names)',cr,lf,
|
||||
'dir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf,
|
||||
'dir [drive = (a,b,p)]',tab,tab,
|
||||
'(search specified drives, ''disk'' is synonym)',cr,lf,
|
||||
'dir [user = all]',tab,tab,'(find files with any user number)',cr,lf,
|
||||
'dir [user = (0,1,15), G12]',tab,'(find files with specified user number)',
|
||||
cr,lf,
|
||||
'dir [length = n]',tab,tab,'(print headers every n lines)',cr,lf,
|
||||
'dir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf,
|
||||
'dir [message user=all]',tab,tab,'(show user/drive areas with no files)',
|
||||
cr,lf,
|
||||
'dir [help]',tab,tab,tab,'(show this message)',cr,lf,
|
||||
'dir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$'));
|
||||
|
||||
call terminate;
|
||||
end help; */
|
||||
|
||||
|
||||
/* -------- Scanner Info -------- */
|
||||
|
||||
$include (scan.lit)
|
||||
|
||||
dcl pcb pcb$structure
|
||||
initial (0,.buff(0),.fcb,0,0,0,0) ;
|
||||
|
||||
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) = 'A' then
|
||||
display$attributes = true;
|
||||
else if token(1) = 'D' and token(2) = 'I' then
|
||||
find.dir = true;
|
||||
else if token(1) = 'D' and token(2) = 'A' then do;
|
||||
format = form$full;
|
||||
date$opt = true;
|
||||
end;
|
||||
/* else if token(1) = 'D' and token(2) = 'E' then
|
||||
debug = true; */
|
||||
else if token(1) = 'E' then
|
||||
find.exclude = true;
|
||||
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) = 'G' then
|
||||
do;
|
||||
if pcb.token$len < 3 then
|
||||
temp = token(2) - '0';
|
||||
else
|
||||
temp = (token(2) - '0') * 10 + (token(3) - '0');
|
||||
if temp >= 0 and temp <= 15 then
|
||||
call set$vec(.usr$vector,temp);
|
||||
else goto op$err;
|
||||
end;
|
||||
/* 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
|
||||
find.nonxfcb = true;
|
||||
else if token(3) = 'P' then
|
||||
no$page$mode = 0FFh;
|
||||
else if token(3) = 'S' then
|
||||
sort$op = false;
|
||||
else goto op$err;
|
||||
/* else if token(1) = 'P' then
|
||||
find.pass = true; */
|
||||
else if token(1) = 'R' and token(2) = 'O' then
|
||||
find.ro = true;
|
||||
else if token(1) = 'R' and token(2) = 'W' then
|
||||
find.rw = true;
|
||||
else if token(1) = 'S' then
|
||||
if token(2) = 'Y' then
|
||||
find.sys = true;
|
||||
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) = 'X' then
|
||||
find.xfcb = true;
|
||||
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(.('ERROR: Illegal Option or Modifier.',
|
||||
cr,lf,'$'));
|
||||
call terminate;
|
||||
end get$options;
|
||||
|
||||
get$file$spec: procedure;
|
||||
dcl i byte;
|
||||
if num$search$files < max$search$files then
|
||||
do;
|
||||
call move(f$namelen + f$typelen,.token(1),
|
||||
.search(num$search$files).name(0));
|
||||
|
||||
if search(num$search$files).name(f$name - 1) = ' ' and
|
||||
search(num$search$files).name(f$type - 1) = ' ' then
|
||||
search(num$search$files).anyfile = true; /* match on any file */
|
||||
else search(num$search$files).anyfile = false;/* speedier compare */
|
||||
|
||||
if token(0) = 0 then
|
||||
search(num$search$files).drv = 0ffh; /* no drive letter with */
|
||||
else /* file spec */
|
||||
search(num$search$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 */
|
||||
/* search.plm module */
|
||||
|
||||
num$search$files = num$search$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 explicitly set by user */
|
||||
if not (find.dir or find.sys) then
|
||||
find.dir, find.sys = true;
|
||||
if not(find.ro or find.rw) then
|
||||
find.rw, find.ro = true;
|
||||
|
||||
if find.xfcb or find.nonxfcb then
|
||||
do; if format = form$short then
|
||||
format = form$full;
|
||||
end;
|
||||
else /* both xfcb and nonxfcb are off */
|
||||
find.nonxfcb, find.xfcb = true;
|
||||
|
||||
if num$search$files = 0 then
|
||||
do;
|
||||
search(num$search$files).anyfile = true;
|
||||
search(num$search$files).drv = 0ffh;
|
||||
num$search$files = 1;
|
||||
end;
|
||||
|
||||
if drv$vector = 0 then
|
||||
do i = 0 to num$search$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$search$files - 1;
|
||||
if search(i).drv <> 0ffh and search(i).drv <> cur$drv then
|
||||
do; call print(.('ERROR: Illegal Global/Local ',
|
||||
'Drive Spec Mixing.',cr,lf,'$'));
|
||||
call terminate;
|
||||
end;
|
||||
end;
|
||||
if usr$vector = 0 then
|
||||
call set$vec(.usr$vector,get$usr);
|
||||
|
||||
/* set up default page size for display */
|
||||
/**** page$len = 23; /* number lines per screen page */
|
||||
|
||||
end set$defaults;
|
||||
|
||||
|
||||
dcl (save$uvec,temp) address;
|
||||
dcl i byte;
|
||||
declare last$dseg$byte byte
|
||||
initial (0);
|
||||
|
||||
plmstart:
|
||||
do;
|
||||
os = high(get$version);
|
||||
bdos = low(get$version);
|
||||
|
||||
if bdos < bdos22 /* or os <> ccpm86 */
|
||||
then do;
|
||||
/*call print(.('Requires Concurrent CP/M-86',cr,lf,'$'));*/
|
||||
call print(.('Requires BDOS 2.2 or greater.',cr,lf,'$'));
|
||||
call terminate; /* check to make sure function call is valid */
|
||||
end;
|
||||
else
|
||||
call set$console$mode;
|
||||
|
||||
/* note - initialized declarations set defaults */
|
||||
cur$drv = get$cur$drv;
|
||||
call scan$init(.pcb);
|
||||
call scan(.pcb);
|
||||
no$page$mode = false; /******** getscbbyte(nopage$mode$offset); ***whf***/
|
||||
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(.('ERROR: Options not grouped together.',
|
||||
cr,lf,'$'));
|
||||
call terminate;
|
||||
end;
|
||||
else if (pcb.tok$typ and t$filespec) <> 0 then
|
||||
call get$file$spec;
|
||||
else
|
||||
do;
|
||||
call print(.('ERROR: Illegal command tail.',cr,lf,'$'));
|
||||
call terminate;
|
||||
end;
|
||||
end;
|
||||
|
||||
call set$defaults;
|
||||
|
||||
/* main control loop */
|
||||
|
||||
call search$init; /* set up memory pointers for subsequent storage */
|
||||
|
||||
do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh;
|
||||
call select$drive(cur$drv);
|
||||
save$uvec = 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 and format <> form$short 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) + 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 display$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(.(cr,lf,cr,lf,'No File',cr,lf,'$'));
|
||||
call terminate;
|
||||
|
||||
end;
|
||||
end sdir;
|
||||
|
||||
@@ -0,0 +1,36 @@
|
||||
$title ('SDIR 8086 - Main Module')
|
||||
sdir:
|
||||
do;
|
||||
|
||||
$include (copyrt.lit)
|
||||
|
||||
/* commands used to generate */
|
||||
/*
|
||||
asm86 scd.a86
|
||||
plm86 main86.plm debug object(main86) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 scan.plm debug object(scan) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 search.plm debug object(search) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 sort.plm debug object(sort) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 disp.plm debug object(disp) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 dpb86.plm debug object(dpb86) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 util.plm debug object(util) optimize(3) 'p2' 'p3' 'p4'
|
||||
plm86 timest.plm debug object(timest) optimize(3) 'p2' 'p3' 'p4'
|
||||
link86 scd.obj,main86,scan,search,sort,disp,util,dpb86,timest to sdir86.lnk
|
||||
loc86 sdir86.lnk od(sm(code,dats,data,const,stack)) -
|
||||
ad(sm(code(0),dats(10000h))) ss(stack(+32))
|
||||
h86 sdir86
|
||||
|
||||
(on a micro)
|
||||
vax sdir86.h86 $fans
|
||||
gencmd sdir86 data[b1000 m3c5 x800]
|
||||
|
||||
* constants are last to force hex generation.
|
||||
* a minimum data of 3c5h paragraphs is 12K plus the data space
|
||||
* of SDIR, enough for 512 directory entries
|
||||
* the max is lowered from 0fffh to 800h
|
||||
(Aug 12, 1982 for CCP/M-86 IBM PC)
|
||||
*/
|
||||
|
||||
$include (main.plm)
|
||||
|
||||
|
||||
@@ -0,0 +1,20 @@
|
||||
|
||||
/* 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;
|
||||
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
|
||||
declare
|
||||
pcb$structure literally 'structure (
|
||||
state address,
|
||||
scan$adr address,
|
||||
token$adr address,
|
||||
tok$typ byte,
|
||||
token$len byte,
|
||||
p$level byte,
|
||||
nxt$token byte)';
|
||||
|
||||
declare
|
||||
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';
|
||||
|
||||
|
||||
@@ -0,0 +1,732 @@
|
||||
$title ('Utility Command Line Scanner')
|
||||
scanner:
|
||||
do;
|
||||
|
||||
$include(comlit.lit)
|
||||
$include(mon.plm)
|
||||
|
||||
dcl debug boolean initial (false);
|
||||
|
||||
dcl eob lit '0'; /* end of buffer */
|
||||
|
||||
$include(fcb.lit)
|
||||
|
||||
|
||||
/* -------- Some routines used for diagnostics if debug mode is on -------- */
|
||||
|
||||
printchar: procedure(char) external;
|
||||
declare char byte;
|
||||
end printchar;
|
||||
|
||||
printb: procedure external;
|
||||
end printb;
|
||||
|
||||
crlf: procedure external;
|
||||
end crlf;
|
||||
|
||||
pdecimal: procedure(v,prec,zerosup) external;
|
||||
/* 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 */
|
||||
|
||||
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: procedure (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 f$name$len + f$type$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 */
|
||||
end;
|
||||
else
|
||||
return(false);
|
||||
else
|
||||
call putchar(0); /* use default drive */
|
||||
|
||||
if not (letter(char) or char = '$' or char = '_'
|
||||
or char = '*' or char = '?' ) then /* no leading numerics */
|
||||
if token(0) = 0 then /* ambiguous with numeric token */
|
||||
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' - 1);
|
||||
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;
|
||||
|
||||
@@ -0,0 +1,105 @@
|
||||
;
|
||||
; Concurrent CP/M-86 v2.0 with BDOS version 3.1
|
||||
; Interface for PLM-86 with separate code and data
|
||||
; Code org'd at 0
|
||||
; Created:
|
||||
; October 5, 1981 by Danny Horovitz
|
||||
; Revised:
|
||||
; 28 Mar 83 by Bill Fitler
|
||||
|
||||
name scd
|
||||
|
||||
dgroup group dats,stack
|
||||
cgroup group code
|
||||
|
||||
assume cs:cgroup, ds:dgroup, ss:dgroup
|
||||
|
||||
stack segment word stack 'STACK'
|
||||
stack_base label byte
|
||||
stack ends
|
||||
|
||||
dats segment para public 'DATA' ;CP/M page 0 - LOC86'd at 0H
|
||||
|
||||
org 4
|
||||
bdisk db ?
|
||||
org 6
|
||||
maxb dw ?
|
||||
org 50h
|
||||
cmdrv db ?
|
||||
pass0 dw ?
|
||||
len0 db ?
|
||||
pass1 dw ?
|
||||
len1 db ?
|
||||
org 5ch
|
||||
fcb db 16 dup (?)
|
||||
fcb16 db 16 dup (?)
|
||||
cr db ?
|
||||
rr dw ?
|
||||
ro db ?
|
||||
buff db 128 dup (?)
|
||||
tbuff equ buff
|
||||
buffa equ buff
|
||||
fcba equ fcb
|
||||
|
||||
org 100h ;past CPM data space
|
||||
saveax dw 0 ;save registers for mon functions
|
||||
savebx dw 0
|
||||
savecx dw 0
|
||||
savedx dw 0
|
||||
public bdisk,maxb,cmdrv,pass0,len0
|
||||
public pass1,len1,fcb,fcb16,cr,rr
|
||||
public ro,buff,tbuff,buffa,fcba
|
||||
public saveax,savebx,savecx,savedx
|
||||
|
||||
dats ends
|
||||
|
||||
|
||||
code segment public 'CODE'
|
||||
public xdos,mon1,mon2,mon3,mon4
|
||||
extrn plmstart:near
|
||||
|
||||
org 0h ; for separate code and data
|
||||
jmp pastserial ; skip copyright
|
||||
jmp patch ; store address of patch routine at start
|
||||
db 'COPYRIGHT (C) 1983, DIGITAL RESEARCH '
|
||||
db ' CONCURRENT CP/M-86 2.0, 03/31/83 ' ; db ' MP/M-86 2.0, 10/5/81 '
|
||||
pastserial:
|
||||
pushf
|
||||
pop ax
|
||||
cli
|
||||
mov cx,ds
|
||||
mov ss,cx
|
||||
lea sp,stack_base
|
||||
push ax
|
||||
popf
|
||||
jmp plmstart
|
||||
|
||||
xdos proc
|
||||
push bp
|
||||
mov bp,sp
|
||||
mov dx,[bp+4]
|
||||
mov cx,[bp+6]
|
||||
int 224
|
||||
mov saveax,ax
|
||||
mov savebx,bx
|
||||
mov savecx,cx
|
||||
mov savedx,dx
|
||||
pop bp
|
||||
ret 4
|
||||
xdos endp
|
||||
|
||||
mon1 equ xdos ; no returned value
|
||||
mon2 equ xdos ; returns byte in AL
|
||||
mon3 equ xdos ; returns address or word BX
|
||||
mon4 equ xdos ; returns pointer in BX and ES
|
||||
|
||||
patch:
|
||||
nop
|
||||
nop
|
||||
nop
|
||||
nop
|
||||
org 0100h ; leave room for patch area
|
||||
|
||||
code ends
|
||||
end
|
||||
|
||||
@@ -0,0 +1,99 @@
|
||||
name 'SCD2'
|
||||
;
|
||||
; CCP/M 3.1
|
||||
; Interface for PLM-86 with separate code and data
|
||||
; Code org'd at 0
|
||||
; December 18, 1981
|
||||
|
||||
|
||||
dgroup group data,stack
|
||||
cgroup group code
|
||||
|
||||
code cseg
|
||||
public reset,xdos,mon1,mon2,mon3,mon4
|
||||
extrn plm:near
|
||||
|
||||
org 0h ; for separate code and data
|
||||
reset:
|
||||
pushf
|
||||
pop ax
|
||||
cli
|
||||
mov cx,ds
|
||||
mov ss,cx
|
||||
lea sp,stack_base
|
||||
push ax
|
||||
popf
|
||||
call plm
|
||||
xor cx,cx
|
||||
mov dx,cx
|
||||
int 224
|
||||
|
||||
|
||||
xdos:
|
||||
push bp
|
||||
mov bp,sp
|
||||
mov dx,4[bp]
|
||||
mov cx,6[bp]
|
||||
int 224
|
||||
pop bp
|
||||
ret 4
|
||||
|
||||
mon1 equ xdos ; no returned value
|
||||
mon2 equ xdos ; returns byte in AL
|
||||
mon3 equ xdos ; returns address or word BX
|
||||
mon4 equ xdos ; returns pointer in BX and ES
|
||||
|
||||
|
||||
|
||||
org 03Ah ; reserve patch area biased by
|
||||
; the 5 bytes the linker inserts
|
||||
|
||||
db '161183' ;day, month, year
|
||||
db 'CCP/M '
|
||||
db 0,0,0,0 ;patch bits
|
||||
db 'COPYRT 1983,1984'
|
||||
db 'DIGITAL RESEARCH'
|
||||
db 'XXXX-0000-654321' ;serial field
|
||||
|
||||
rb 113 ; patch area, 128 total bytes
|
||||
db 'CSEG patch area'
|
||||
|
||||
|
||||
stack sseg word
|
||||
rw 64
|
||||
stack_base rw 0
|
||||
|
||||
data dseg ;CP/M page 0 - LOC86'd at 0H
|
||||
|
||||
org 4
|
||||
bdisk rb 1
|
||||
org 6
|
||||
maxb rw 1
|
||||
org 50h
|
||||
cmdrv rb 1
|
||||
pass0 rw 1
|
||||
len0 rb 1
|
||||
pass1 rw 1
|
||||
len1 rb 1
|
||||
org 5ch
|
||||
fcb rb 16
|
||||
org 6ch
|
||||
fcb16 rb 16
|
||||
org 7ch
|
||||
cr rb 1
|
||||
rr rw 1
|
||||
ro rb 1
|
||||
org 80h
|
||||
buff rb 80h
|
||||
tbuff equ buff
|
||||
|
||||
|
||||
db ' DSEG patch area'
|
||||
|
||||
public bdisk,maxb,cmdrv,pass0,len0
|
||||
public pass1,len1,fcb,fcb16,cr,rr
|
||||
public ro,buff,tbuff
|
||||
|
||||
|
||||
end
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
|
||||
declare /* what kind of file user wants to find */
|
||||
find$structure lit 'structure (
|
||||
dir byte,
|
||||
sys byte,
|
||||
ro byte,
|
||||
rw byte,
|
||||
pass byte,
|
||||
xfcb byte,
|
||||
nonxfcb byte,
|
||||
exclude byte)';
|
||||
|
||||
declare
|
||||
max$search$files literally '10';
|
||||
|
||||
declare
|
||||
search$structure lit 'structure(
|
||||
drv byte,
|
||||
name(8) byte,
|
||||
type(3) byte,
|
||||
anyfile boolean)'; /* match on any drive if true */
|
||||
|
||||
|
||||
@@ -0,0 +1,503 @@
|
||||
$title ('SDIR - Search For Files')
|
||||
/* modified 12/12/83 for PC-MODE by G. Edmonds */
|
||||
|
||||
|
||||
search:
|
||||
do;
|
||||
/* search module for extended dir */
|
||||
|
||||
$include (comlit.lit)
|
||||
$include (mon.plm)
|
||||
|
||||
dcl debug boolean external;
|
||||
|
||||
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 */
|
||||
|
||||
$include(fcb.lit)
|
||||
$include(xfcb.lit)
|
||||
|
||||
declare
|
||||
sfcb$type lit '21H',
|
||||
deleted$type lit '0E5H';
|
||||
|
||||
$include (search.lit)
|
||||
dcl find find$structure external; /* what kind of files to look for */
|
||||
dcl num$search$files byte external;
|
||||
dcl search (max$search$files) search$structure external;
|
||||
/* file specs to match on */
|
||||
|
||||
/* other globals */
|
||||
|
||||
dcl cur$usr byte external,
|
||||
cur$drv byte external, /* current drive " " */
|
||||
dir$label byte public; /* directory label for BDOS 3.0 */
|
||||
|
||||
|
||||
/* -------- BDOS calls -------- */
|
||||
|
||||
read$char: procedure byte;
|
||||
return mon2 (1,0);
|
||||
end read$char;
|
||||
|
||||
|
||||
/* -------- in sort.plm -------- */
|
||||
|
||||
mult23: procedure(f$info$index) address external;
|
||||
dcl f$info$index address;
|
||||
end mult23;
|
||||
|
||||
|
||||
/* -------- in util.plm -------- */
|
||||
|
||||
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;
|
||||
|
||||
crlf: procedure external; /* print carriage return, linefeed */
|
||||
end crlf;
|
||||
|
||||
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;
|
||||
|
||||
/* -------- In dpb86.plm -------- */
|
||||
|
||||
$include(dpb.lit)
|
||||
|
||||
dcl k$per$block byte external; /* set in dpb module */
|
||||
|
||||
base$dpb: procedure external;
|
||||
end base$dpb;
|
||||
|
||||
dpb$byte: procedure(param) byte external;
|
||||
dcl param byte;
|
||||
end dpb$byte;
|
||||
|
||||
dpb$word: procedure(param) address external;
|
||||
dcl param byte;
|
||||
end dpb$word;
|
||||
|
||||
|
||||
/* -------- Some Utility Routines -------- */
|
||||
|
||||
check$console$status: procedure byte;
|
||||
return mon2 (11,0);
|
||||
end check$console$status;
|
||||
|
||||
search$first: procedure (fcb$address) byte public;
|
||||
declare fcb$address address; /* shared with disp.plm */
|
||||
return mon2 (17,fcb$address); /* for short display */
|
||||
end search$first;
|
||||
|
||||
search$next: procedure byte public; /* shared with disp.plm */
|
||||
return mon2 (18,0);
|
||||
end search$next;
|
||||
|
||||
terminate: procedure external; /* in main.plm */
|
||||
end terminate;
|
||||
|
||||
set$vec: procedure(vector,value) external; /* in main.plm */
|
||||
dcl vector address,
|
||||
value byte;
|
||||
end set$vec;
|
||||
|
||||
/*break: procedure public; shared with disp.plm */
|
||||
/* dcl x byte;
|
||||
if check$console$status then
|
||||
do;
|
||||
x = read$char;
|
||||
call terminate;
|
||||
end;
|
||||
end break;*/
|
||||
|
||||
|
||||
/* -------- file information record declaration -------- */
|
||||
|
||||
$include(finfo.lit)
|
||||
|
||||
declare
|
||||
buf$fcb$adr address public, /* index into directory buffer */
|
||||
buf$fcb based buf$fcb$adr (32) byte,
|
||||
/* fcb template for dir */
|
||||
(first$f$i$adr, f$i$adr, last$f$i$adr) address public,
|
||||
/* indices into file$info array */
|
||||
file$info based f$i$adr f$info$structure,
|
||||
sfcb$adr address,
|
||||
dir$type based sfcb$adr byte,
|
||||
sfcbs$present byte,
|
||||
x$i$adr address public,
|
||||
xfcb$info based x$i$adr x$info$structure;
|
||||
|
||||
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;
|
||||
/* str2 is the possibly wildcarded filename we are looking for */
|
||||
|
||||
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 address;
|
||||
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 and i <> 0 and first$pass <> 0 then
|
||||
call set$vec(.active$usr$vector,i); /* skip cur$usr files */
|
||||
/* build active usr vector for this drive */
|
||||
|
||||
do i = 0 to num$search$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(not find.exclude); /* file found */
|
||||
else if compare(11,.buf$fcb(f$name),.search(i).name(0)) then
|
||||
return(not find.exclude); /* file found */
|
||||
end;
|
||||
return(find.exclude); /* file not found */
|
||||
end match; /* find.exclude = the exclude option value */
|
||||
|
||||
dcl hash$table$size lit '128', /* must be power of 2 */
|
||||
hash$table (hash$table$size) address 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;
|
||||
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); /* put new entry in table if */
|
||||
f$i$adr = hash$table(hash$index); /* unused ( = 0) */
|
||||
|
||||
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 /* table entry used - collison */
|
||||
do; hash$entry$adr = .file$info.hash$link; /* resolve by linked */
|
||||
f$i$adr = file$info.hash$link; /* list */
|
||||
end;
|
||||
end;
|
||||
if f$i$adr = 0 then
|
||||
return(false); /* didn't find it, used hash$entry to keep new info */
|
||||
else return(true); /* found it, file$info at matched entry */
|
||||
end hash$look$up;
|
||||
|
||||
$eject
|
||||
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 ------------------------- <-- first$f$i$adr |
|
||||
| file$info entry | |
|
||||
(hash) -----<--| . | <----------------------|
|
||||
(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, d$map$cnt) byte,
|
||||
temp address,
|
||||
temp2 address,
|
||||
incr address,
|
||||
(s1,s4,s7,s8) byte,
|
||||
tadd1 address,
|
||||
tadd2 address;
|
||||
|
||||
store$file: procedure;
|
||||
|
||||
|
||||
tadd1=.temp;
|
||||
tadd2=.temp2;
|
||||
|
||||
call move(f$namelen + f$typelen, .buf$fcb(f$name),.file$info.name);
|
||||
/* attributes are not in XFCBs to copy again in case */
|
||||
/* XFCB came first in directory */
|
||||
|
||||
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 for current dir entry */
|
||||
/* 1 or 2 byte block numbers ? */
|
||||
|
||||
if ((buf$fcb(f$diskmap) = buf$fcb(f$diskmap+1)) and
|
||||
((buf$fcb(f$diskmap) and 80h) = 80h)) and
|
||||
((buf$fcb(f$drvusr) and 10h) = 0) then do;
|
||||
|
||||
dcl s2 based tadd1 (2) byte, /* high middle filesize byte */
|
||||
s5 based tadd2 (2) byte;
|
||||
|
||||
/* must be dos media ... */
|
||||
/* file size is in the last 4 bytes */
|
||||
|
||||
s1 = buf$fcb(f$diskmap+15);
|
||||
s2(1) = buf$fcb(f$diskmap+14);
|
||||
s2(0) = buf$fcb(f$diskmap+13);
|
||||
s4 = buf$fcb(f$diskmap+12);
|
||||
|
||||
s5(0) = shr(s4,7) + shl(s2(0),1);
|
||||
s5(1) = shr(s2(0),7) + shl(s2(1),1); /*calculate # of recs */
|
||||
s7 = shr(s2(1),7) + shl(s1,1);
|
||||
|
||||
file$info.recs$lword=temp2;
|
||||
file$info.recs$hbyte=s7;
|
||||
|
||||
if (shl(s4,1) <> 0) then
|
||||
call add3byte(.file$info.recs$lword,1);
|
||||
|
||||
if ((s4=0) and (shl(s2(0),6)=0)) then
|
||||
incr = 0;
|
||||
else incr = 1;
|
||||
|
||||
s8 = shr(s2(1),2) + shl(s1,6); /*calculate # of 1k blocks */
|
||||
s2(0) = shr(s2(0),2) + shl(s2(1),6);
|
||||
s2(1) = s8;
|
||||
|
||||
temp=temp+incr;
|
||||
|
||||
file$info.onekblocks=temp;
|
||||
file$info.kbytes=temp;
|
||||
|
||||
end;
|
||||
else do;
|
||||
d$map$cnt=0;
|
||||
i=1;
|
||||
if dpb$word(blk$max$w) > 255 then
|
||||
i = 2;
|
||||
do j = f$diskmap to f$diskmap + diskmaplen - 1 by i;
|
||||
temp = buf$fcb(j);
|
||||
if i = 2 then /* word block numbers */
|
||||
temp = temp or buf$fcb(j+1);
|
||||
if temp <> 0 then /* allocated */
|
||||
d$map$cnt = d$map$cnt + 1;
|
||||
end;
|
||||
if d$map$cnt > 0 then
|
||||
do;
|
||||
call add3byte
|
||||
(.file$info.recs$lword,
|
||||
d$map$cnt * (dpb$byte(blkmsk$b) + 1) -
|
||||
( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b) )
|
||||
);
|
||||
file$info.onekblocks = file$info.onekblocks +
|
||||
d$map$cnt * k$per$block -
|
||||
shr( (128 - buf$fcb(f$rc)) and dpb$byte(blkmsk$b), 3 );
|
||||
/* treat each directory entry separately for sparse files */
|
||||
/* if copied to single density diskette, the number of 1kblocks */
|
||||
file$info.kbytes = file$info.kbytes + d$map$cnt * k$per$block;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if buf$fcb(f$drvusr) <> sfcb$type then do; /* don't put SFCB's in table */
|
||||
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 (temp := mult23(files$found + 1)) > x$i$adr then
|
||||
return(false); /* out of memory */
|
||||
if (temp < first$f$i$adr) then
|
||||
return(false); /* wrap around - 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.onekblocks,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 */
|
||||
end;
|
||||
|
||||
/* else hash$lookup has set f$i$adr to the file entry already in the */
|
||||
/* hash table */
|
||||
|
||||
if sfcbs$present then do; /* save sfcb,xfcb or fcb type info */
|
||||
if (buf$fcb(f$drvusr) and xfcb$type) = 0 then do;
|
||||
if buf$fcb(f$drvusr) <> sfcb$type then do;
|
||||
if buf$fcb(f$ex) <= dpb$byte(extmsk$b) then do;
|
||||
/* first extent? then store sfcb info into xfcb table */
|
||||
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(9,sfcb$adr,.xfcb$info.create);
|
||||
file$info.x$i$adr = x$i$adr;
|
||||
end;
|
||||
call store$file;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
else do; /* no SFCB's present */
|
||||
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 call store$file; /* must be a regular fcb then */
|
||||
end;
|
||||
return(true); /* success */
|
||||
end store$file$info;
|
||||
|
||||
|
||||
/* Module Entry Point */
|
||||
|
||||
get$files: procedure public; /* with one scan through directory get */
|
||||
dcl dcnt byte; /* files from currently selected drive */
|
||||
|
||||
last$f$i$adr = first$f$i$adr - size(file$info);
|
||||
/* after hash table */
|
||||
/* 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 base$dpb;
|
||||
dir$label,filesfound = 0;
|
||||
used$de = 0;
|
||||
fcb(f$drvusr) = '?'; /* match all dir entries */
|
||||
dcnt = search$first(.fcb);
|
||||
sfcb$adr = 96 + .buff; /* determine if SFCB's are present */
|
||||
if dir$type = sfcb$type then
|
||||
do;
|
||||
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* initialize buf$fcb */
|
||||
if ((buf$fcb(f$diskmap) = buf$fcb(f$diskmap+1)) and
|
||||
((buf$fcb(f$diskmap) and 80h) = 80h)) and
|
||||
((buf$fcb(f$drvusr) and 10h) = 0) then
|
||||
used$de=0;
|
||||
else used$de=shr(1+dpb$word(dirmax$w),2);
|
||||
sfcbs$present = true;
|
||||
end;
|
||||
else
|
||||
do;
|
||||
sfcbs$present = false;
|
||||
used$de=0;
|
||||
end;
|
||||
do while dcnt <> 255;
|
||||
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
|
||||
if sfcbs$present then
|
||||
sfcb$adr = 97 + (dcnt * 10) + .buff; /* SFCB time & date stamp adr */
|
||||
|
||||
if (buf$fcb(f$drvusr) <> deleted$type) then
|
||||
do;
|
||||
if buf$fcb(f$drvusr) = dirlabel$type then /* dir label ? */
|
||||
do;
|
||||
used$de = used$de + 1;
|
||||
dir$label = buf$fcb(f$ex); /* save label info */
|
||||
end;
|
||||
else
|
||||
do;
|
||||
if ((buf$fcb(f$diskmap) = buf$fcb(f$diskmap+1)) and
|
||||
((buf$fcb(f$diskmap) and 80h) = 80h)) and
|
||||
((buf$fcb(f$drvusr) and 10h) = 0) then
|
||||
if (buf$fcb(f$ex) = 0) and (buf$fcb(14)=0) then
|
||||
used$de=used$de+1;
|
||||
else ;
|
||||
else if (buf$fcb(f$drvusr) <> sfcb$type) then
|
||||
used$de=used$de + 1;
|
||||
if match then
|
||||
do;
|
||||
if not store$file$info then /* store fcb or xfcb info */
|
||||
do; /* out of space */
|
||||
call print (.('Out of Memory',cr,lf,'$'));
|
||||
return;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
/*call break;*/
|
||||
dcnt = search$next; /* to next entry in directory */
|
||||
end; /* of do while dcnt <> 255 */
|
||||
|
||||
end get$files;
|
||||
|
||||
search$init: procedure public; /* called once from main.plm */
|
||||
if (first$f$i$adr := (.hash$table + size(hash$table))) + size(file$info)
|
||||
> maxb then
|
||||
do;
|
||||
call print(.('Not Enough Memory',cr,lf,'$'));
|
||||
call terminate;
|
||||
end;
|
||||
end search$init;
|
||||
|
||||
end search;
|
||||
|
||||
@@ -0,0 +1,119 @@
|
||||
$title ('SDIR - Sort Module')
|
||||
sort:
|
||||
do;
|
||||
/* sort module for extended dir */
|
||||
|
||||
$include(comlit.lit)
|
||||
|
||||
print: procedure(str$adr) external; /* in util.plm */
|
||||
dcl str$adr address;
|
||||
end print;
|
||||
|
||||
dcl sorted boolean public; /* set by this module if successful sort */
|
||||
|
||||
$include(finfo.lit)
|
||||
|
||||
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, first$f$i$adr, last$f$i$adr, x$i$adr, filesfound)
|
||||
address external,
|
||||
/* indices into file$info array */
|
||||
file$info based f$i$adr f$info$structure,
|
||||
|
||||
mid$adr address,
|
||||
mid$file$info based mid$adr f$info$structure;
|
||||
|
||||
|
||||
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 + first$f$i$adr;
|
||||
/* 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 = 1 to 11;
|
||||
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); /* no recursive quick sort, sorting largest */
|
||||
dcl (l,r,i,j,temp) address,/* partition first */
|
||||
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;
|
||||
mid$adr = mult23(f$i$indices(shr(l+r,1)));
|
||||
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 /* which partition is larger */
|
||||
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(.('Not Enough Memory for Sort',cr,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 sort;
|
||||
|
||||
@@ -0,0 +1,274 @@
|
||||
;*******************************************************
|
||||
;
|
||||
; TCOPY - Example program to write the system tracks
|
||||
; for a Concurrent CP/M Boot Disk on a
|
||||
; CompuPro Computer System.
|
||||
;
|
||||
;*******************************************************
|
||||
|
||||
; This program is used to read a binary image file
|
||||
; which will be loaded on the disk boot tracks. This
|
||||
; binary image is used to bootstrap the Concurrent CP/M
|
||||
; system file. The binary image file which TCOPY reads
|
||||
; has no CMD header and must be fit within the size of
|
||||
; the boot tracks we are going to write.
|
||||
|
||||
; This program is intended to serve as an example
|
||||
; to be modified by the OEM for differently sized loaders,
|
||||
; and differently sized system track(s).
|
||||
|
||||
; Note: TCOPY must be run under CP/M-86 1.1 and not under
|
||||
; Concurrent CP/M since TCOPY performs direct BIOS calls to
|
||||
; write to the disk.
|
||||
|
||||
; The following commands are used to generate TCOPY.CMD
|
||||
; RASM86 TCOPY
|
||||
; LINK86 TCOPY
|
||||
;
|
||||
;*******************************************************
|
||||
|
||||
title 'TCOPY - Copy Track 0'
|
||||
|
||||
; CP/M-86 function names
|
||||
|
||||
; console functions
|
||||
c_read equ 1
|
||||
c_writebuf equ 9
|
||||
|
||||
; file functions
|
||||
f_open equ 15
|
||||
f_readrand equ 33
|
||||
f_setdma equ 26
|
||||
f_setdmaseg equ 51
|
||||
|
||||
; drive functions
|
||||
drv_get equ 25
|
||||
|
||||
dph_dpb equ 10
|
||||
dpb_spt equ 0
|
||||
dpb_off equ 13
|
||||
|
||||
; system functions
|
||||
s_termcpm equ 0
|
||||
s_bdosver equ 12
|
||||
s_dirbios equ 50
|
||||
|
||||
bdos_version equ 0022h
|
||||
|
||||
; direct Bios Parameter Block
|
||||
bpb_func equ byte ptr 0
|
||||
bpb_cx equ word ptr 1
|
||||
bpb_dx equ word ptr 3
|
||||
|
||||
; ASCII linefeed and carriage return
|
||||
lf equ 10
|
||||
cr equ 13
|
||||
|
||||
;-------------------------------------------------------
|
||||
CSEG
|
||||
org 0000h
|
||||
;use CCP stack
|
||||
mov cl,c_writebuf ;display sign on message
|
||||
mov dx,offset sign_on_msg
|
||||
int 224
|
||||
mov cl,s_bdosver
|
||||
int 224
|
||||
cmp ax,bdos_version! je version_ok
|
||||
mov dx,offset version_msg
|
||||
jmp error
|
||||
version_ok:
|
||||
mov cl,drv_get ;get default drive number
|
||||
int 224
|
||||
mov default_drive,al
|
||||
add al,'A'
|
||||
mov dest_drive,al ;set drive letter in message
|
||||
|
||||
mov cl,f_open ;open the file given as
|
||||
mov dx,offset fcb ;the 1st command parameter,
|
||||
int 224 ;it is put at 05CH by
|
||||
cmp al,0ffh! jne file_ok ;the program load
|
||||
mov dx,offset open_msg
|
||||
jmp error
|
||||
file_ok:
|
||||
mov current_dma,offset image_buffer
|
||||
mov r0,0 ;start with sector 0, assume
|
||||
mov cx,buf_siz/128 ;no CMD header in the file
|
||||
file_read:
|
||||
push cx
|
||||
mov cl,f_setdma
|
||||
mov dx,current_dma
|
||||
int 224
|
||||
mov cl,f_readrand ;user r0,r1,r2 for random
|
||||
mov dx,offset fcb ;reads
|
||||
int 224
|
||||
pop cx
|
||||
test al,al! jz read_ok
|
||||
cmp al,1! je track_write
|
||||
mov dx,offset read_msg
|
||||
jmp error
|
||||
read_ok:
|
||||
add current_dma,128 ;set the DMA for the next sector
|
||||
inc r0 ;add one to the random record field
|
||||
loop file_read
|
||||
|
||||
mov dx,offset length_msg ;file is larger than the number
|
||||
jmp error ; of available sectors to write
|
||||
|
||||
; We have the binary image in RAM
|
||||
; Ask for destination diskette
|
||||
|
||||
track_write:
|
||||
inc r0 ;r0 = number of sectors read
|
||||
next_diskette:
|
||||
mov cl,c_writebuf
|
||||
mov dx,offset new_disk_msg
|
||||
int 224
|
||||
|
||||
mov cl,c_read ;wait for a keystroke
|
||||
int 224
|
||||
cmp al,3! jne not_ctrlC ;check for control C
|
||||
jmp done
|
||||
not_ctrlC:
|
||||
|
||||
; Using CP/M-86 function 50, Direct bios call,
|
||||
; write the track image in IMAGE_BUFFER to
|
||||
; track 0, on default drive.
|
||||
|
||||
mov cl,default_drive
|
||||
call select_disk ;select default drive
|
||||
mov bx,es:dph_dpb[bx] ;get DPB
|
||||
mov ax,es:dpb_spt[bx] ;get sectors/track
|
||||
add ax,26 ;add in sectors for track 0
|
||||
cmp ax,r0! jae size_ok ;check max # of sectors on boot tracks
|
||||
mov dx,offset length_msg ; file is larger than the number
|
||||
jmp error ; of available sectors to write
|
||||
size_ok:
|
||||
mov ax,es:dpb_off[bx] ;determine sides from OFF value
|
||||
cmp ax,2! je format_ok
|
||||
cmp ax,4! je format_ok
|
||||
mov dx,offset format_msg
|
||||
jmp error
|
||||
format_ok:
|
||||
shr al,1
|
||||
mov second_track,al ;save track # for cylinder 1, head 0
|
||||
|
||||
xor cx,cx
|
||||
call set_track ;set track to 0
|
||||
call set_dmaseg ;set DMA segment = DS
|
||||
|
||||
mov current_sector,0 ;sectors are relative to 0 in BIOS
|
||||
mov current_dma,offset image_buffer
|
||||
mov cx,r0 ;number of 128 byte sectors to write
|
||||
next_sector:
|
||||
push cx ;save sector count
|
||||
call set_dmaoff
|
||||
call set_sector
|
||||
call write_sector
|
||||
add current_dma,128 ;next area of memory to write
|
||||
inc current_sector ;next sector number
|
||||
cmp current_sector,26
|
||||
jb same_track
|
||||
mov cl,second_track ;cylinder 1, head 0
|
||||
call set_track
|
||||
mov current_sector,0
|
||||
same_track:
|
||||
pop cx ;restore sector count
|
||||
loop next_sector
|
||||
|
||||
mov cl,c_writebuf ;does the user want to write
|
||||
mov dx,offset continue_msg ;to another diskette ?
|
||||
int 224
|
||||
mov cl,c_read ;get response
|
||||
int 224
|
||||
and al,05FH ;make upper case
|
||||
cmp al,'Y'
|
||||
jne done
|
||||
jmp next_diskette
|
||||
|
||||
error:
|
||||
push dx
|
||||
call crlf
|
||||
pop dx
|
||||
mov cl,c_writebuf
|
||||
int 224
|
||||
|
||||
done:
|
||||
mov cx,s_termcpm
|
||||
mov dx,cx
|
||||
int 224
|
||||
|
||||
select_disk:
|
||||
mov al,9 ;BIOS function number of seldsk
|
||||
xor dx,dx
|
||||
jmps bios
|
||||
set_track:
|
||||
mov al,10 ;BIOS function number of settrk
|
||||
jmps bios
|
||||
set_dmaseg:
|
||||
mov al,17 ;BIOS function number of setdmab
|
||||
mov cx,ds ;dma segment we want to use
|
||||
jmps bios
|
||||
set_dmaoff:
|
||||
mov al,12 ;BIOS function number of setdma
|
||||
mov cx,current_dma
|
||||
jmps bios
|
||||
set_sector:
|
||||
mov al,11 ;BIOS function number of setsec
|
||||
mov cx,current_sector
|
||||
jmps bios
|
||||
write_sector:
|
||||
mov al,14 ;BIOS function number of write sector
|
||||
jmps bios ;error checking can be added here
|
||||
bios:
|
||||
mov bx,offset bpb ;fill in BIOS Paramenter Block
|
||||
mov bpb_func[bx],al
|
||||
mov bpb_cx[bx],cx
|
||||
mov bpb_dx[bx],dx
|
||||
mov cl,s_dirbios
|
||||
mov dx,bx
|
||||
int 224
|
||||
ret
|
||||
|
||||
crlf:
|
||||
mov dx,offset crlf_msg
|
||||
mov cl,c_writebuf
|
||||
int 224
|
||||
ret
|
||||
|
||||
;-------------------------------------------------------
|
||||
DSEG
|
||||
org 0000h
|
||||
|
||||
fcb equ ds:byte ptr .05Ch
|
||||
r0 equ ds:word ptr .07Dh
|
||||
r3 equ ds:byte ptr .07Fh
|
||||
|
||||
sign_on_msg db cr,lf,'Example TCOPY for CompuPro Computer System'
|
||||
db cr,lf,'Writes track image file on boot tracks$'
|
||||
new_disk_msg db cr,lf,'Put destination diskette in drive '
|
||||
dest_drive db 'A:'
|
||||
db cr,lf,'Strike any key when ready $'
|
||||
continue_msg db cr,lf,'Write another disk (Y/N) ? $'
|
||||
crlf_msg db cr,lf,'$'
|
||||
|
||||
|
||||
version_msg db 'Requires CP/M-86 1.1$'
|
||||
format_msg db 'Unrecognized disk format$'
|
||||
open_msg db 'Give file name containing boot '
|
||||
db 'image, after TCOPY command$'
|
||||
read_msg db 'Error reading track image file$'
|
||||
length_msg db 'File is larger than the the number of boot sectors$'
|
||||
write_msg db 'Error writing on boot tracks$'
|
||||
|
||||
image_buffer rb 26*128+8*8*128 ;area for both tracks
|
||||
buf_siz equ offset $ - offset image_buffer
|
||||
|
||||
bpb rb 5 ;direct Bios Parameter Block
|
||||
|
||||
current_dma dw 0
|
||||
current_sector dw 0
|
||||
default_drive db 0
|
||||
second_track db 0
|
||||
|
||||
END
|
||||
|
||||
@@ -0,0 +1,226 @@
|
||||
$title('SDIR - Display Time Stamps')
|
||||
timestamp:
|
||||
do;
|
||||
/* Display time stamp module for extended directory */
|
||||
/* Time & Date ASCII Conversion Code */
|
||||
/* From MP/M 1.1 TOD program */
|
||||
|
||||
$include(comlit.lit)
|
||||
|
||||
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 (*) address 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 address;
|
||||
|
||||
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 address;
|
||||
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 address; /* 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 timestamp;
|
||||
|
||||
@@ -0,0 +1,149 @@
|
||||
$title('SDIR - Utility Routines')
|
||||
utility:
|
||||
do;
|
||||
|
||||
/* Utility Module for SDIR */
|
||||
|
||||
$include(comlit.lit)
|
||||
|
||||
|
||||
/* -------- arithmetic functions -------- */
|
||||
|
||||
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 based numb structure (
|
||||
lword address,
|
||||
hbyte byte),
|
||||
total based totalb structure (
|
||||
lword address,
|
||||
hbyte byte);
|
||||
|
||||
call 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;
|
||||
|
||||
|
||||
/* ------- print routines -------- */
|
||||
|
||||
mon1: procedure(f,a) external;
|
||||
declare f byte, a address;
|
||||
end mon1;
|
||||
|
||||
/*break: procedure external;
|
||||
end break;*/
|
||||
|
||||
$include(fcb.lit)
|
||||
|
||||
/* 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);
|
||||
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 utility;
|
||||
|
||||
@@ -0,0 +1,9 @@
|
||||
declare
|
||||
bdos20 lit '20h',
|
||||
bdos22 lit '22h',
|
||||
bdos30 lit '30h',
|
||||
mpm lit '01h',
|
||||
cpm86 lit '10h',
|
||||
mpm86 lit '11h',
|
||||
ccpm86 lit '14h';
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
|
||||
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';
|
||||
|
||||
declare /* password mode of xfcb */
|
||||
pm$read lit '80h',
|
||||
pm$write lit '40h',
|
||||
pm$delete lit '20h';
|
||||
|
||||
|
||||
Reference in New Issue
Block a user