seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-24 17:04:19 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

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

16
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/COMLIT.LIT Normal file
View File

@@ -0,0 +1,16 @@
declare
lit literally 'literally',
dcl lit 'declare',
true lit '0ffh',
false lit '0',
boolean lit 'byte',
forever lit 'while true',
cr lit '13',
lf lit '10',
tab lit '9',
ctrlc lit '3',
ff lit '12',
date$flag$offset lit '0ch', /* [JCE] UK dates? */
page$len$offset lit '1ch',
nopage$mode$offset lit '2Ch',
sectorlen lit '128';

32
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/COMMON.LIT Normal file
View File

@@ -0,0 +1,32 @@
/* Some useful defines for the remote program */
declare lit literally 'literally';
declare word lit 'address';
declare pointer lit 'address';
declare connection lit 'address';
declare cr lit '0dh',
lf lit '0ah',
TAB lit '09h',
SOH lit '01h',
STX lit '02h',
ETX lit '03h',
EOT lit '04h',
ACK lit '06h',
NAK lit '15h',
XON lit '11h',
XOF lit '13h',
CAN lit '18h',
SUB lit '1ah',
RUBOUT lit '7fh';
declare forever lit 'while 1';
declare false lit '0',
true lit 'not false';
declare read$only lit '1',
write$only lit '2',
read$write lit '3';
$list

22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/COMPILE.DOC Normal file
View File

@@ -0,0 +1,22 @@
Compiling CP/M-80 (PL/M modules)
================================
The supplied source is (I hope) all that is necessary to build the four
modified CP/M programs.
You will need the PLM80 compiler, the ASM80 assembler, and the ISIS
emulator. These can all be in separate directories.
Edit ENV.BAT to set the four directories:
:F0: source code directory
:F1: PLM80 compiler
:F2: ASM80 assembler
:F3: ISIS emulator and libraries
and the path to ISIS.EXE (if it's on the search path, just SET ISIS=ISIS)
Type MAKEPLM0 to see if you have the paths right for ISIS and ASM80. If so,
follow it up with MAKECOM DATE, which uses the PLM80 paths for ISIS and PLM80.
Finally, type MAKE2000 to build all four modules.

8
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/COPYRT.LIT Normal file
View File

@@ -0,0 +1,8 @@
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/

50
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/CPM2000.DOC Normal file
View File

@@ -0,0 +1,50 @@
CP/M 3: Year 2000 fixes
=======================
The following archive contains all CP/M 3 .COM files that use dates,
updated to operate correctly past the year 2000. They also allow dates to
be in US or UK format.
Operation: SETDEF
=================
To use UK-format dates, type:
SETDEF [UK]
To return to US-format dates, type:
SETDEF [US]
Operation: DATE
===============
The year entered when dates are set can be 0-77 (meaning 2000-2077) or 78-99
(meaning 1978-1999). The problem of what to do in 2078 is deferred to a later
revision of this program.
Dates are now displayed with four-figure years.
The US/UK setting applies to date entry and display.
Operation: DIR and SHOW
=======================
DIR and SHOW display years above 2000 correctly (rather than as ":0") and
obey the US/UK setting.
Technical
=========
The US/UK setting is stored in a previously unused SCB byte. I have checked
all available sources on the SCB (including the BDOS source) to come up with
the following:
SCB + 0Ch (xxA8h) bit 0: 0 for US, 1 for UK.
This address is shown in the BDOS source as the low byte of an unused word
in the "Utilities" section of the SCB. ZPM3 does not use this byte either.
My recommendation is that any other expansions to utilities should use the
remainder of this word to store settings.

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DATE.COM Normal file
View File

Binary file not shown.

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DATE.MAK Normal file
View File

@@ -0,0 +1,5 @@
:F1:plm80 date.plm pagewidth(100) debug optimize
:F3:link mcd80a.obj,date.obj,:F1:plm80.lib to date.mod
:F3:locate date.mod code(0100H) stacksize(100)
:F3:objhex date to date.hex
exit

631
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DATE.PLM Normal file
View File

@@ -0,0 +1,631 @@
$title ('CP/M V3.0 Date and Time')
tod:
do;
/*
Revised:
14 Sept 81 by Thomas Rolander
Modifications:
Date: September 2,1982
Programmer: Thomas J. Mason
Changes:
The 'P' option was changed to the 'C'ontinuous option.
Also added is the 'S'et option to let the user set either
the time or the date.
Date: October 31,1982
Programmer: Bruce K. Skidmore
Changes:
Added Function 50 call to signal Time Set and Time Get.
Date: 17 May 1998
Programmer: John Elliott
Changes:
Year 2000 fixes (flagged [JCE] below)
Patch 17 implemented
*/
declare PLM label 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;
mon2a:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon2a;
declare xdos literally 'mon2a';
declare date$flag$offset literally '0ch'; /* [JCE] Date in UK format? */
declare fcb (1) byte external;
declare fcb16 (1) byte external;
declare tbuff (1) byte external;
RETURN$VERSION$FUNC:
procedure address;
return MON2A(12,0);
end RETURN$VERSION$FUNC;
read$console:
procedure byte;
return mon2 (1,0);
end read$console;
write$console:
procedure (char);
declare char byte;
call mon1 (2,char);
end write$console;
print$buffer:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buffer;
READ$CONSOLE$BUFFER:
procedure (BUFF$ADR);
declare BUFF$ADR address;
call MON1(10,BUFF$ADR);
end READ$CONSOLE$BUFFER;
check$console$status:
procedure byte;
return mon2 (11,0);
end check$console$status;
terminate:
procedure;
call mon1 (0,0);
end terminate;
crlf:
procedure;
call write$console (0dh);
call write$console (0ah);
end crlf;
get$date$flag: procedure byte; /* [JCE] Read the date format flag */
declare scbpb structure
(offset byte,
set byte,
value address);
scbpb.offset = date$flag$offset;
scbpb.set = 0;
return (mon2(49,.scbpb) and 1);
end get$date$flag; /* [JCE] ends */
/*****************************************************
Time & Date ASCII Conversion Code
*****************************************************/
declare BUFFER$ADR structure (
MAX$CHARS byte,
NUMB$OF$CHARS byte,
CONSOLE$BUFFER(23) byte) /* [JCE] size 21 -> 23 throughout */
initial(23,0,0,0,0,0,0,0,0,0,0,0, /* because of printing */
0,0,0,0,0,0,0,0,0,0,0,0,0); /* four-figure year nos. */
declare tod$adr address;
declare tod based tod$adr structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (23) byte );
declare string$adr address;
declare string based string$adr (1) byte;
declare index byte;
declare lit literally 'literally',
forever lit 'while 1',
word lit 'address';
/* - - - - - - - - - - - - - - - - - - - - - - */
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);
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 chr byte;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
gnc:
procedure;
/* get next command byte */
if chr = 0 then return;
if index = 22 then /* [JCE] 20 -> 22 */
do;
chr = 0;
return;
end;
chr = string(index := index + 1);
end gnc;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
deblank:
procedure;
do while chr = ' ';
call gnc;
end;
end deblank;
numeric:
procedure byte;
/* test for numeric */
return (chr - '0') < 10;
end numeric;
scan$numeric:
procedure(lb,ub) byte;
declare (lb,ub) byte;
declare b byte;
b = 0;
call deblank;
if not numeric then go to error;
do while numeric;
if (b and 1110$0000b) <> 0 then go to error;
b = shl(b,3) + shl(b,1); /* b = b * 10 */
if carry then go to error;
b = b + (chr - '0');
if carry then go to error;
call gnc;
end;
if (b < lb) or (b > ub) then go to error;
return b;
end scan$numeric;
scan$delimiter:
procedure(d,lb,ub) byte;
declare (d,lb,ub) byte;
call deblank;
if chr <> d then go to error;
call gnc;
return scan$numeric(lb,ub);
end scan$delimiter;
declare base$year lit '78', /* base year for computations */
base$day lit '0', /* starting day for base$year 0..6 */
month$size (*) byte data
/* jan feb mar apr may jun jul aug sep oct nov dec */
( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
month$days (*) word data
/* jan feb mar apr may jun jul aug sep oct nov dec */
( 000,031,059,090,120,151,181,212,243,273,304,334);
leap$days:
procedure(y,m) byte;
declare (y,m) byte;
/* compute days accumulated by leap years */
declare yp byte;
yp = shr(y,2); /* yp = y/4 */
if (y and 11b) = 0 and month$days(m) < 59 then
/* y not 00, y mod 4 = 0, before march, so not leap yr */
return yp - 1;
/* otherwise, yp is the number of accumulated leap days */
return yp;
end leap$days;
declare word$value word;
get$next$digit:
procedure byte;
/* get next lsd from word$value */
declare lsd byte;
lsd = word$value mod 10;
word$value = word$value / 10;
return lsd;
end get$next$digit;
bcd:
procedure (val) byte;
declare val byte;
return shl((val/10),4) + val mod 10;
end bcd;
declare (month, day, year, hrs, min, sec) byte;
set$date:
procedure;
declare (i, leap$flag) byte; /* temporaries */
if get$date$flag = 1 then /* [JCE] UK format */
do;
day = scan$numeric(1,31);
month = scan$delimiter('/',1,12) - 1;
if (leap$flag := month = 1) then i = 29;
else i = month$size(month);
if day > i then go to error;
end;
else /* US format */
do;
month = scan$numeric(1,12) - 1;
/* may be feb 29 */
if (leap$flag := month = 1) then i = 29;
else i = month$size(month);
day = scan$delimiter('/',1,i);
end;
/* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */
year = scan$delimiter('/',0,99); /* [JCE] */
if year < base$year /* [JCE] */
then year = year + 100; /* [JCE] Dates past 2000 */
/* ensure that feb 29 is in a leap year */
if leap$flag and day = 29 and (year and 11b) <> 0 then
/* feb 29 of non-leap year */ go to error;
/* compute total days */
tod.date = month$days(month)
+ 365 * (year - base$year)
+ day
- leap$days(base$year,0)
+ leap$days(year,month);
end SET$DATE;
SET$TIME:
procedure;
tod.hrs = bcd (scan$numeric(0,23));
tod.min = bcd (scan$delimiter(':',0,59));
if tod.opcode = 2
then
/* date, hours and minutes only */
do;
if chr = ':'
then i = scan$delimiter (':',0,59);
tod.sec = 0;
end;
/* include seconds */
else tod.sec = bcd (scan$delimiter(':',0,59));
end set$time;
bcd$pair:
procedure(a,b) byte;
declare (a,b) byte;
return shl(a,4) or b;
end bcd$pair;
compute$year:
procedure;
/* compute year from number of days in word$value */
declare year$length word;
year = base$year;
do forever;
year$length = 365;
if (year and 11b) = 0 then /* leap year */
year$length = 366;
if word$value <= year$length then
return;
word$value = word$value - year$length;
year = year + 1;
end;
end compute$year;
declare week$day byte, /* day of week 0 ... 6 */
day$list (*) byte data ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
leap$bias byte; /* bias for feb 29 */
compute$month:
procedure;
month = 12;
do while month > 0;
if (month := month - 1) < 2 then /* jan or feb */
leapbias = 0;
if month$days(month) + leap$bias < word$value then return;
end;
end compute$month;
declare date$test byte, /* true if testing date */
test$value word; /* sequential date value under test */
get$date$time:
procedure;
/* get date and time */
hrs = tod.hrs;
min = tod.min;
sec = tod.sec;
word$value = tod.date;
/* word$value contains total number of days */
week$day = (word$value + base$day - 1) mod 7;
call compute$year;
/* year has been set, word$value is remainder */
leap$bias = 0;
if (year and 11b) = 0 and word$value > 59 then
/* after feb 29 on leap year */ leap$bias = 1;
call compute$month;
day = word$value - (month$days(month) + leap$bias);
month = month + 1;
end get$date$time;
emit$date$time:
procedure;
declare century byte; /* [JCE] century */
century = 19; /* [JCE] start in the 1900s */
call emitn(.day$list(shl(week$day,2)));
call emitchar(' ');
if get$date$flag = 0 then /* [JCE] US or UK format for dates? */
do;
call emit$slant(month);
call emit$slant(day);
end;
else
do;
call emit$slant(day);
call emit$slant(month);
end;
century = century + (year / 100); /* [JCE] Y2000 fix for output */
year = year mod 100; /* [JCE] */
call emit$bin$pair(century); /* [JCE] end of Y2000 fix for output */
call emit$bin$pair(year);
call emitchar(' ');
call emit$colon(hrs);
call emit$colon(min);
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 then
do;
call get$date$time;
index = -1;
call emit$date$time;
end;
else
do;
if (tod.opcode = 1) or
(tod.opcode = 2) then
do;
chr = string(index:=0);
call set$date;
call set$time;
ret = .string(index);
end;
else
do;
go to error;
end;
end;
end tod$ASCII;
/********************************************************
********************************************************/
declare lcltod structure (
opcode byte,
date address,
hrs byte,
min byte,
sec byte,
ASCII (23) byte ); /* [JCE] 21 -> 23 */
declare datapgadr address;
declare datapg based datapgadr address;
declare extrnl$todadr address;
declare extrnl$tod based extrnl$todadr structure (
date address,
hrs byte,
min byte,
sec byte );
declare i byte;
declare ret address;
display$tod:
procedure;
lcltod.opcode = 0; /* read tod */
call mon1(50,.(26,0,0,0,0,0,0,0)); /* BIOS TIME GET SIGNAL */
call move (5,.extrnl$tod.date,.lcltod.date);
call tod$ASCII (.lcltod);
call write$console (0dh);
do i = 0 to 22; /* [JCE] 20 -> 22 */
call write$console (lcltod.ASCII(i));
end;
end display$tod;
comp:
procedure (cnt,parmadr1,parmadr2) byte;
declare (i,cnt) byte;
declare (parmadr1,parmadr2) address;
declare parm1 based parmadr1 (5) byte;
declare parm2 based parmadr2 (5) byte;
do i = 0 to cnt-1;
if parm1(i) <> parm2(i)
then return 0;
end;
return 0ffh;
end comp;
/**************************************
Main Program
**************************************/
declare last$dseg$byte byte initial (0);
declare CURRENT$VERSION address initial (0);
declare CPM30 byte initial (030h);
declare MPM byte initial (01h);
PLM:
do;
CURRENT$VERSION = RETURN$VERSION$FUNC;
if (low(CURRENT$VERSION) >= CPM30) and (high(CURRENT$VERSION) <> MPM) then
do;
datapgadr = xdos (49,.(03ah,0));
extrnl$todadr = xdos(49,.(03ah,0)) + 58H;
if (FCB(1) = 'C') then
do while FCB(1) = 'C';
call mon1(105,.(0,0,0,0)); /* [JCE] this implements Patch 17 */
if comp(5,.extrnl$tod.date,.lcltod.date) = 0 then
call display$tod;
if check$console$status then
do;
ret = read$console;
fcb(1) = 0;
end;
end;
else
if (FCB(1) = ' ') then
do;
call display$tod;
end;
else
if (FCB(1) = 'S')
then do;
call crlf;
call print$buffer(.('Enter today''s date (','$')); /* [JCE] UK-format */
if get$date$flag then /* [JCE] */
call print$buffer(.('DD/MM/YY): ','$')); /* [JCE] UK format */
else call print$buffer(.('MM/DD/YY): ','$')); /* [JCE] US format */
call move(23,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(23,.buffer$adr.console$buffer,.lcltod.ASCII);
tod$adr = .lcltod;
string$adr = .tod.ASCII;
chr = string(index := 0);
call set$date;
call move(2,.lcltod.date,.extrnl$tod.date);
end; /* date initialization */
call crlf;
call print$buffer(.('Enter the time (HH:MM:SS): ','$'));
call move(23,.(000000000000000000000),.buffer$adr.console$buffer);
call read$console$buffer(.buffer$adr);
if buffer$adr.numb$of$chars > 0
then do;
call move(23,.buffer$adr.console$buffer,.lcltod.ASCII);
tod$adr = .lcltod;
string$adr = .tod.ASCII;
chr = string(index := 0);
call set$time;
call crlf;
call print$buffer(.('Press any key to set time ','$'));
ret = read$console;
call move(3,.lcltod.hrs,.extrnl$tod.hrs);
call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */
end;
call crlf;
end;
else do;
call move (23,.tbuff(1),.lcltod.ASCII);
lcltod.opcode = 1;
call tod$ASCII (.lcltod);
call crlf;
call print$buffer (.('Strike key to set time','$'));
ret = read$console;
call move (5,.lcltod.date,.extrnl$tod.date);
call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */
call crlf;
end;
call terminate;
end;
else
do;
call CRLF;
call PRINT$BUFFER(.('ERROR: Requires CP/M3.','$'));
call CRLF;
call TERMINATE;
end;
end;
error:
do;
call crlf;
call print$buffer (.('ERROR: Illegal time/date specification.','$'));
call terminate;
end;

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DIR.COM Normal file
View File

Binary file not shown.

12
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DIR.MAK Normal file
View File

@@ -0,0 +1,12 @@
:F1:plm80 main80.plm debug pagewidth(130) optimize object(main80)
:F1:plm80 scan.plm debug pagewidth(130) optimize object(scan)
:F1:plm80 search.plm debug pagewidth(130) optimize object(search)
:F1:plm80 sort.plm debug pagewidth(130) optimize object(sort)
:F1:plm80 disp.plm debug pagewidth(130) optimize object(disp)
:F1:plm80 dpb80.plm debug pagewidth(130) optimize object(dpb80)
:F1:plm80 util.plm debug pagewidth(130) optimize object(util)
:F1:plm80 timest.plm debug pagewidth(130) optimize object(timest)
:F3:link mcd80a.obj,main80,scan,search,sort,disp,util,dpb80,timest,:F1:plm80.lib to dir.mod
:F3:locate dir.mod code(0100H) stacksize(50)
:F3:objhex dir to dir.hex
exit

677
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DISP.PLM Normal file
View File

@@ -0,0 +1,677 @@
$title ('SDIR - Display Files')
display:
do;
/* Display Module for SDIR */
$include(comlit.lit)
$include(mon.plm)
dcl debug boolean external;
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;
dcl no$page$mode byte external;
dcl sfcbs$present byte external; /* sfcb's there/not there indicator */
$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;
dcl first$time address initial (0);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
wait$keypress: procedure;
declare char byte;
/* if debug then
call print(.(cr,lf,'In wait*keypress...',cr,lf,'$'));
*/
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);
/*- - - - - - - - - - - - - - - - - - - - - - -*/
crlf$and$check: procedure;
/*
if debug then
call print(.(cr,lf,'In crlf*and*check...',cr,lf,'$'));
*/
if no$page$mode = 0 then do;
if global$line$count > page$len-1 then do;
call print(.(cr,lf,'Press RETURN to Continue $'));
cur$line = cur$line + 1;
call wait$keypress;
global$line$count = 0;
end; /* global$line$count > page$len */
end; /* no$page$mode = 0 */
call crlf;
global$line$count = global$line$count + 1;
end crlf$and$check;
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;
/*
if debug then
call print(.(cr,lf,'In add*totals...',cr,lf,'$'));
*/
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 */
/*
if debug then
call print(.(cr,lf,'In display*file*info...',cr,lf,'$'));
*/
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 debug then
call print(.(cr,lf,'In display*xfcb*info...',cr,lf,'$'));
*/
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 debug then
call print(.(cr,lf,'In display*title...',cr,lf,'$'));
*/
if formfeeds then
call print$char(ff);
else if not first$title then
call crlf$and$check;
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$and$check;
cur$line = 2;
first$title = false;
end display$title;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
short$display: procedure (fname$adr);
dcl fname$adr address;
/*
if debug then
call print(.(cr,lf,'In short*display...',cr,lf,'$'));
*/
if cur$file mod files$per$line = 0 then
do;
if cur$line mod page$len = 0 and first$time = 0 then
do;
call crlf$and$check;
call display$title;
call crlf$and$check;
end;
else
call crlf$and$check;
cur$line = cur$line + 1;
call printchar(cur$drv + 'A');
end;
else call printb;
call print(.(': $'));
call printfn(fname$adr);
call break;
cur$file = cur$file + 1;
first$time = first$time + 1;
end short$display;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
test$att: procedure(char,off,on) boolean;
dcl (char,off,on) byte;
/*
if debug then
call print(.(cr,lf,'In test*att...',cr,lf,'$'));
*/
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;
/*
if debug then
call print(.(cr,lf,'In short*dir...',cr,lf,'$'));
*/
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 */
/*
if debug then
call print(.(cr,lf,'In getnxt*file*info...',cr,lf,'$'));
*/
right$usr = false;
if sorted then
do; index = index + 1;
f$i$adr = mult23(f$i$indices(index));
do while file$info.usr <> cur$usr and index <> filesfound;
index = index + 1;
f$i$adr = mult23(f$i$indices(index));
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 debug then
call print(.(cr,lf,'In size*display...',cr,lf,'$'));
*/
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;
/*
if debug then
call print(.(cr,lf,'In display*no*dirlabel...',cr,lf,'$'));
*/
files$per$line = 2;
first$time = 0;
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;
if ((cur$file mod files$per$line) = 0) then /* need new line */
do;
if ((cur$line mod page$len) = 0) then
do;
if ((no$page$mode = 0) or (first$time = 0)) then do;
call crlf$and$check;
call display$title;
call crlf$and$check;
call print(.hdr);
call printb; /* two sets of hdrs */
call print(.hdr);
call crlf$and$check;
call print(.hdr$bars);
call printb;
call print(.hdr$bars);
call crlf$and$check;
cur$line = cur$line + 4;
first$time = first$time+1;
end;
else do;
call crlf$and$check;
cur$line = cur$line + 1;
end; /* no$page$mode check */
end;
else
do; call crlf$and$check;
cur$line = cur$line + 1;
end;
end;
else
call printb; /* separate the files */
call display$file$info;
cur$file = cur$file + 1;
call add$totals;
call break;
end;
call getnxt$file$info;
end;
end display$no$dirlabel;
/*- - - - - - - - - - - - - - - - - - - - - - -*/
display$with$dirlabel: procedure;
/*
if debug then
call print(.(cr,lf,'In display*with*dirlabel...',cr,lf,'$'));
*/
files$per$line = 1;
first$time = 0;
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;
if cur$line mod page$len = 0 then
do;
if ((no$page$mode = 0) or (first$time = 0)) then do;
call crlf$and$check;
call display$title;
call crlf$and$check;
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$and$check;
call print(.hdr$bars);
call print(.hdr$xfcb$bars);
call crlf$and$check;
cur$line = cur$line + 4;
first$time = first$time + 1;
end; /* no$page$mode check */
end;
call crlf$and$check;
cur$line = cur$line + 1;
call display$file$info; /* display non bdos 3.0 file info */
call display$xfcb$info;
cur$file = cur$file + 1;
call break;
call add$totals;
end;
call getnxt$file$info;
end;
end display$with$dirlabel;
/*- - - - -MAIN ENTRY POINT - - - - - - - - - -*/
display$files: procedure public; /* MODULE ENTRY POINT */
/* display the collected data */
/*
if debug then
call print(.(cr,lf,'In main display routine...',cr,lf,'$'));
*/
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(.('ERROR: Illegal Format Value.',cr,lf,'$'));
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 )) and (sfcbs$present)) then
call display$with$dirlabel; /* Timestamping is active! */
else do;
call print(.('ERROR: Date and Time Stamping Inactive.',cr,lf,'$'));
call terminate;
end;
end;
else do; /* No date option; Regular Full display */
if (((dir$label and dl$exists) <> 0) and (sfcbs$present)) then
do;
call display$with$dirlabel;
end;
else
do;
call display$no$dirlabel;
end;
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$and$check;
call crlf$and$check;
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$and$check;
call display$title;
call print(.('No File',cr,lf,'$'));
end;
call break;
end;
else do;
file$displayed = true;
if not formfeeds then
call crlf$and$check;
end;
end display$files;
end display;

13
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DPB.LIT Normal file
View File

@@ -0,0 +1,13 @@
/* 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';

45
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/DPB80.PLM Normal file
View File

@@ -0,0 +1,45 @@
$title ('SDIR 8080 - Get Disk Parameters')
dpb80:
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)
$include(mon.plm)
declare k$per$block address public;
declare dpb$base address;
declare dpb$array based dpb$base (15) byte;
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 = mon3(get$dpb,0);
k$per$block = shr(dpb$byte(blkmsk$b)+1,3);
end base$dpb;
end dpb80;

14
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/ENV.BAT Normal file
View File

@@ -0,0 +1,14 @@
rem Setup the ISIS environment
rem :F0: should hold the source code
rem :F1: should hold the PL/M-80 compiler
rem :F2: should hold the ASM-80 assembler
rem :F3: should hold the ISIS libraries and emulator
SET :F0:=D:\TOOLS\PLM\DIR
SET :F1:=D:\TOOLS\PLM\PLM80
SET :F2:=D:\TOOLS\PLM\ASM80
SET :F3:=D:\TOOLS\PLM\UTILS
SET ISIS=D:\TOOLS\PLM\UTILS\ISIS
BREAK ON

21
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/FCB.LIT Normal file
View File

@@ -0,0 +1,21 @@
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$rrec lit '33', /* random record */
f$rreco lit '35'; /* " " overflow */

15
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/FINFO.LIT Normal file
View File

@@ -0,0 +1,15 @@
/* 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)';

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/FORMAT.LIT Normal file
View File

@@ -0,0 +1,5 @@
dcl form$short lit '0', /* format values for SDIR */
form$size lit '1',
form$full lit '2';

103
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/HEXCOM.C Normal file
View File

@@ -0,0 +1,103 @@
/*
* load - convert a hex file to a com file
*/
#include <stdio.h>
#include <stdlib.h>
unsigned char checksum;
FILE *fpout;
unsigned char getbyte () {
register int c;
unsigned char x;
c = getchar ();
if ('0' <= c && c <= '9')
x = c - '0';
else
if ('A' <= c && c <= 'F')
x = c - 'A' + 10;
else
goto funny;
x <<= 4;
c = getchar ();
if ('0' <= c && c <= '9')
x |= c - '0';
else
if ('A' <= c && c <= 'F')
x |= c - 'A' + 10;
else {
funny:
fprintf (stderr, "Funny hex letter %c\n", c);
exit (2);
}
checksum += x;
return x;
}
main (int argc, char **argv) {
register unsigned i, n;
char c, buf[64];
unsigned type;
unsigned int al, ah, addr = 0, naddr;
if (argc < 2) fpout = stdout;
else fpout = fopen(argv[1],"wb");
do {
do {
c = getchar ();
if (c == EOF) {
fprintf (stderr, "Premature EOF colon missing\n");
exit (1);
}
} while (c != ':');
checksum = 0;
n = getbyte (); /* bytes / line */
ah = getbyte ();
al = getbyte ();
switch (type = getbyte ())
{
case 1:
break;
case 0:
naddr = (ah << 8) | al;
if (!addr) addr = naddr;
else while (addr < naddr)
{
fwrite("", 1, 1, fpout);
++addr;
}
if (addr > naddr)
{
fprintf(stderr,"Records out of sequence at %x\n", naddr);
exit(1);
}
for (i = 0; i < n; i++)
buf[i] = getbyte ();
fwrite (buf, 1, n, fpout);
break;
default:
fprintf (stderr, "Funny record type %d\n", type);
exit (1);
}
(void) getbyte ();
if (checksum != 0)
{
fprintf (stderr, "Checksum error");
exit (2);
}
addr += n;
} while (type != 1);
}

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/HEXCOM.EXE Normal file
View File

Binary file not shown.

632
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAIN.PLM Normal file
View File

@@ -0,0 +1,632 @@
/* 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. */
$include (comlit.lit)
$include (mon.plm)
dcl patch (128) address;
/* 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 (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 mon2(12,0);
end get$version;
select$drive: procedure(d);
declare d byte;
call mon1(14,d);
end select$drive;
search$first: procedure(d) byte external;
dcl d address;
end search$first;
search$next: procedure byte external;
end search$next;
get$cur$drv: procedure byte; /* return current drive number */
return mon2(25,0);
end get$cur$drv;
getlogin: procedure address; /* get the login vector */
return mon3(24,0);
end getlogin;
getusr: procedure byte; /* return current user number */
return mon2(32,0ffh);
end getusr;
getscbbyte: procedure (offset) byte public; /* [JCE] public so the timest */
declare offset byte; /* code can use it */
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);
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 do;
if token(2) = 'F' then
formfeeds = true;
else if token(2) = 'U' then
format = form$full;
else goto op$err;
end;
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
do;
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;
end;
/* 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 do;
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;
end;
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; /* User option */
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 */
if bdos > bdos30 then do;
if not formfeeds then do;
if page$len = 0ffffh then do;
page$len = getscbbyte(page$len$offset);
if page$len < 5 then
page$len = 24;
end;
end;
end;
end set$defaults;
dcl (save$uvec,temp) address;
dcl i byte;
declare last$dseg$byte byte
initial (0);
plm:
do;
os = high(get$version);
bdos = low(get$version);
if bdos < bdos30 or os = mpm then do;
call print(.('Requires CP/M 3',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 = getscbbyte(nopage$mode$offset);
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 get$files; /* 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(.('No File',cr,lf,'$'));
call terminate;
end;
end sdir;

10
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAIN80.PLM Normal file
View File

@@ -0,0 +1,10 @@
$title ('SDIR 8080 - Main Module')
sdir: /* SDIR FOR 8080 */
do;
$include(copyrt.lit)
declare plm label public;
$include(main.plm)

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAKE2000.BAT Normal file
View File

@@ -0,0 +1,5 @@
@call makemcd
@call makecom date
@call makecom dir
@call makecom setdef
@call makecom show

15
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAKECOM.BAT Normal file
View File

@@ -0,0 +1,15 @@
@ECHO OFF
call env.bat
rem Do the compilation. %1.MAK contains the lines from CPM3PLM*.SUB which
rem compile %1.COM. Output is in .HEX format
%ISIS% <%1.MAK
rem Convert to CP/M .COM format
ERASE %1.MOD
HEXCOM %1.COM <%1.HEX
ERASE %1
ERASE %1.HEX

13
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAKEDIR.BAT Normal file
View File

@@ -0,0 +1,13 @@
@ECHO OFF
call env.bat
rem Do the compilation. DIR.MAK contains the lines from CPM3PLM7.SUB which
rem compile DIR.COM. Output is in .HEX format
%ISIS% <DIR.MAK
rem Convert to CP/M .COM format
ERASE DIR.LNK
HEXCOM DIR.COM <DIR.HEX

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAKEMCD.BAT Normal file
View File

@@ -0,0 +1,5 @@
@ECHO OFF
@CALL ENV.BAT
@%ISIS% <MCD80A.MAK
@%ISIS% <MCD80F.MAK
@%ISIS% <PARSE.MAK

24
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MAKEPACK.BAT Normal file
View File

@@ -0,0 +1,24 @@
@echo off
rem The build tools
arc a cpm2000s hexcom.c hexcom.exe
arc a cpm2000s dir.mak date.mak show.mak setdef.mak mcd80a.mak mcd80f.mak parse.mak
arc a cpm2000s make2000.bat makepack.bat makecom.bat
arc a cpm2000s makemcd.bat env.bat
rem CP/M sources...
arc a cpm2000s date.plm show.plm setdef.plm mcd80a.asm mcd80f.asm parse.asm
arc a cpm2000s main80.plm scan.plm search.plm sort.plm disp.plm dpb80.plm
arc a cpm2000s util.plm timest.plm main.plm *.lit
rem binaries...
arc a cpm2000s date.com dir.com setdef.com show.com
arc a cpm2000b date.com dir.com setdef.com show.com
rem docs...
arc a cpm2000s cpm2000.doc compile.doc
arc a cpm2000b cpm2000.doc

90
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MCD80A.ASM Normal file
View File

@@ -0,0 +1,90 @@
$title ('COM Externals')
name mcd80a
CSEG
; September 14, 1982
offset equ 0000h
boot equ 0000h ;[JCE] to make SHOW compile
EXTRN PLM
; EXTERNAL ENTRY POINTS
mon1 equ 0005h+offset
mon2 equ 0005h+offset
mon2a equ 0005h+offset
mon3 equ 0005h+offset
public mon1,mon2,mon2a,mon3
; EXTERNAL BASE PAGE DATA LOCATIONS
iobyte equ 0003h+offset
bdisk equ 0004h+offset
maxb equ 0006h+offset
memsiz equ maxb
cmdrv equ 0050h+offset
pass0 equ 0051h+offset
len0 equ 0053h+offset
pass1 equ 0054h+offset
len1 equ 0056h+offset
fcb equ 005ch+offset
fcba equ fcb
sfcb equ fcb
ifcb equ fcb
ifcba equ fcb
fcb16 equ 006ch+offset
dolla equ 006dh+offset
parma equ 006eh+offset
cr equ 007ch+offset
rr equ 007dh+offset
rreca equ rr
ro equ 007fh+offset
rreco equ ro
tbuff equ 0080h+offset
buff equ tbuff
buffa equ tbuff
cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000
public iobyte,bdisk,maxb,memsiz
public cmdrv,pass0,len0,pass1,len1
public fcb,fcba,sfcb,ifcb,ifcba,fcb16
public cr,rr,rreca,ro,rreco,dolla,parma
public buff,tbuff,buffa, cpu, boot
;*******************************************************
; The interface should proceed the program
; so that TRINT becomes the entry point for the
; COM file. The stack is set and memsiz is set
; to the top of memory. Program termination is done
; with a return to preserve R/O diskettes.
;*******************************************************
; EXECUTION BEGINS HERE
;
;[JCE 17-5-1998] Guard code prevents this program being run under DOS
;
db 0EBh,7 ;Sends 8086s to I8086:
lxi sp, stack
JMP PLM
db 0 ;Packing.
;
I8086: db 0CDh,020h ;INT 20h - terminate immediately
; PATCH AREA, DATE, VERSION & SERIAL NOS.
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0
db 0
db 'CP/M Version 3.0'
db 'Copyright 1998, '
db 'Caldera, Inc. '
db '190598' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF

2
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MCD80A.MAK Normal file
View File

@@ -0,0 +1,2 @@
:F2:asm80 mcd80a.asm debug
exit

97
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MCD80F.ASM Normal file
View File

@@ -0,0 +1,97 @@
$title ('COM Externals')
name mcd80b
CSEG
; August 2, 1982
offset equ 0000h
EXTRN PLM
; EXTERNAL ENTRY POINTS
mon1 equ 0005h+offset
mon2 equ 0005h+offset
mon2a equ 0005h+offset
mon3 equ 0005h+offset
public mon1,mon2,mon2a,mon3
; EXTERNAL BASE PAGE DATA LOCATIONS
iobyte equ 0003h+offset
bdisk equ 0004h+offset
maxb equ 0006h+offset
memsiz equ maxb
cmdrv equ 0050h+offset
pass0 equ 0051h+offset
len0 equ 0053h+offset
pass1 equ 0054h+offset
len1 equ 0056h+offset
fcb equ 005ch+offset
fcba equ fcb
sfcb equ fcb
ifcb equ fcb
ifcba equ fcb
fcb16 equ 006ch+offset
dolla equ 006dh+offset
parma equ 006eh+offset
cr equ 007ch+offset
rr equ 007dh+offset
rreca equ rr
ro equ 007fh+offset
rreco equ ro
tbuff equ 0080h+offset
buff equ tbuff
buffa equ tbuff
cpu equ 0 ; 0 = 8080, 1 = 8086/88, 2 = 68000
public iobyte,bdisk,maxb,memsiz
public cmdrv,pass0,len0,pass1,len1
public fcb,fcba,sfcb,ifcb,ifcba,fcb16
public cr,rr,rreca,ro,rreco,dolla,parma
public buff,tbuff,buffa,cpu,reset
;*******************************************************
; The interface should proceed the program
; so that TRINT becomes the entry point for the
; COM file. The stack is set and memsiz is set
; to the top of memory.
;*******************************************************
bdos equ mon1
getalv equ 27
getdpb equ 31
; EXECUTION BEGINS HERE
reset:
trint:
;[JCE 17-5-1998] Protect against being run under DOS
db 0EBh,0Bh ;Sends 8086s to I8086: below
lxi sp, stack
call plm ; call program
mvi c,0
call bdos
I8086: db 0CDh,020h ;8086 processors come here - INT 20h
; PATCH AREA, DATE, VERSION & SERIAL NOS.
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
dw 0,0,0,0,0,0,0,0
db 0
db 'CP/M Version 3.0'
db 'COPYRIGHT 1998, '
db 'Caldera, Inc. '
db '190598' ; version date day-month-year
db 0,0,0,0 ; patch bit map
db '654321' ; Serial no.
END
EOF

2
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/MCD80F.MAK Normal file
View File

@@ -0,0 +1,2 @@
:F2:asm80 mcd80f.asm debug
exit

234
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/PARSE.ASM Normal file
View File

@@ -0,0 +1,234 @@
$title ('Filename Parser')
name Parse
public parse
CSEG
; BC->.(.filename,.fcb)
;
; filename = [d:]file[.type][;password]
;
; fcb assignments
;
; 0 => drive, 0 = default, 1 = A, 2 = B, ...
; 1-8 => file, converted to upper case,
; padded with blanks
; 9-11 => type, converted to upper case,
; padded with blanks
; 12-15 => set to zero
; 16-23 => password, converted to upper case,
; padded with blanks
; 24-25 => address of password field in 'filename',
; set to zero if password length = 0
; 26 => length of password (0 - 8)
;
; Upon return, HL is set to FFFFH if BC locates
; an invalid file name;
; otherwise, HL is set to 0000H if the delimiter
; following the file name is a 00H (NULL)
; or a 0DH (CR);
; otherwise, HL is set to the address of the delimiter
; following the file name.
;
parse: lxi h,0
push h
push h
mov h,b
mov l,c
mov e,m
inx h
mov d,m
inx h
mov a,m
inx h
mov h,m
mov l,a
call deblnk
call delim
jnz parse1
mov a,c
ora a
jnz parse9
mov m,a
jmp parse3
parse1: mov b,a
inx d
ldax d
cpi ':'
jnz parse2
mov a,b
sui 'A'
jc parse9
cpi 16
jnc parse9
inr a
mov m,a
inx d
call delim
jnz parse3
cpi '.'
jz parse9
cpi ':'
jz parse9
cpi ';'
jz parse9
jmp parse3
parse2: dcx d
mvi m,0
parse3: mvi b,8
call setfld
mvi b,3
cpi '.'
jz parse4
call padfld
jmp parse5
parse4: inx d
call setfld
parse5: mvi b,4
parse6: inx h
mvi m,0
dcr b
jnz parse6
mvi b,8
cpi ';'
jz parse7
call padfld
jmp parse8
parse7: inx d
call pwfld
parse8: push d
call deblnk
call delim
jnz pars81
inx sp
inx sp
jmp pars82
pars81: pop d
pars82: mov a,c
ora a
pop b
mov a,c
pop b
inx h
mov m,c
inx h
mov m,b
inx h
mov m,a
xchg
rnz
lxi h,0
ret
parse9: pop h
pop h
lxi h,0ffffh
ret
setfld: call delim
jz padfld
inx h
cpi '*'
jnz setfd1
mvi m,'?'
dcr b
jnz setfld
jmp setfd2
setfd1: mov m,a
dcr b
setfd2: inx d
jnz setfld
setfd3: call delim
rz
pop h
jmp parse9
pwfld: call delim
jz padfld
inx sp
inx sp
inx sp
inx sp
inx sp
inx sp
push d
push h
mvi l,0
xthl
dcx sp
dcx sp
pwfld1: inx sp
inx sp
xthl
inr l
xthl
dcx sp
dcx sp
inx h
mov m,a
inx d
dcr b
jz setfd3
call delim
jnz pwfld1
;jmp padfld
padfld: inx h
mvi m,' '
dcr b
jnz padfld
ret
delim: ldax d
mov c,a
ora a
rz
mvi c,0
cpi 0dh
rz
mov c,a
cpi 09h
rz
cpi ' '
jc delim2
rz
cpi '.'
rz
cpi ':'
rz
cpi ';'
rz
cpi '='
rz
cpi ','
rz
cpi '/'
rz
cpi '['
rz
cpi ']'
rz
cpi '<'
rz
cpi '>'
rz
cpi 'a'
rc
cpi 'z'+1
jnc delim1
ani 05fh
delim1: ani 07fh
ret
delim2: pop h
jmp parse9
deblnk: ldax d
cpi ' '
jz dblnk1
cpi 09h
jz dblnk1
ret
dblnk1: inx d
jmp deblnk
END
EOF


2
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/PARSE.MAK Normal file
View File

@@ -0,0 +1,2 @@
:F2:asm80 parse.asm debug
exit

37
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/README.MARKDOWN Normal file
View File

@@ -0,0 +1,37 @@
Source for the CP/M 3 year 2000 fixes.
# Fixing the year 2000 bug in CP/M 3.0 (DATE.COM)
Here is a pair of patches for DATE.COM to fix the year 2000 problem for CP/M 3.
```
Here are the two Year 2000 patches for CP/M 3's DATE.COM. The first one
keeps the dates in US format:
:0B011000FE4ED21701C66432980BC9E6
:15012000790613FE64DA2B0104DE64F548CD7205F14FC372058F
:0107500000A8
:03075400CD1001C4
:02096300200171
:010A1F0016C0
:0000000000
and the second one changes them to UK format:
:0D0106001E1F0E01CDEA0532970B0E2FC90A
:1C012000FE4ED22701C66432980BC9790613FE64DA360104DE64F548CD7205F1F8
:04013C004FC3720536
:0501E00044442F4D4DC9
:1C070C00CD0601C51E0C0E01CD65063D32960B3A960BD601D6019F329D0B1FD2C4
:1C0728003307219C0B361DC34007002A960B2600018001097E329C0B21970B3A86
:060744009C0BBEDA8204EA
:0107500000A8
:03075400CD2001B4
:01095100970E
:010958009608
:020963002B0166
:010A1F0016C0
:0000000000
Apply them with HEXPAT or SID.
```

22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SCAN.LIT Normal file
View File

@@ -0,0 +1,22 @@
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';

731
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SCAN.PLM Normal file
View File

@@ -0,0 +1,731 @@
$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;

22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SEARCH.LIT Normal file
View File

@@ -0,0 +1,22 @@
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 */

436
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SEARCH.PLM Normal file
View File

@@ -0,0 +1,436 @@
$title ('SDIR - Search For Files')
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 public,
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;
store$file: procedure;
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 */
d$map$cnt = 0; /* count kilobytes for current dir entry */
i = 1; /* 1 or 2 byte block numbers ? */
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;
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 */
/* save sfcb,xfcb or fcb type info */
if sfcbs$present then do;
if (buf$fcb(f$drvusr) and xfcb$type) = 0 then do;
if buf$fcb(f$drvusr) <> sfcb$type then do;
/* store sfcb info into xfcb table */
if buf$fcb(f$ex) <= dpb$byte(extmsk$b) then do;
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; /* extent check */
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);
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 do;
call store$file; /* must be a regular fcb then */
end;
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 */
call print(.(cr,lf,'Scanning Directory...',cr,lf,'$'));
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, 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
sfcbs$present = true;
else
sfcbs$present = false;
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;
used$de = used$de + 1;
if buf$fcb(f$drvusr) = dirlabel$type then /* dir label ? */
dir$label = buf$fcb(f$ex); /* save label info */
else
if (match) then
do;
if not store$file$info then /* store fcb or xfcb info */
do; /* out of space */
call print (.('Out of Memory',cr,lf,'$'));
return;
end; /* not store$file$info */
end; /* else if match */
end; /* buf$fcb(f$drvusr) <> deleted$type */
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;

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SETDEF.COM Normal file
View File

Binary file not shown.

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SETDEF.MAK Normal file
View File

@@ -0,0 +1,5 @@
:F1:plm80 setdef.plm pagewidth(132) debug optimize
:F3:link mcd80a.obj,setdef.obj,:F1:plm80.lib to setdef.mod
:F3:locate setdef.mod code(0100H) stacksize(100)
:F3:objhex setdef to setdef.hex
exit

894
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SETDEF.PLM Normal file
View File

@@ -0,0 +1,894 @@
$ TITLE('CP/M 3.0 --- SETDEF')
setdef:
do;
/*
Copyright (C) 1982
Digital Research
P.O. Box 579
Pacific Grove, CA 93950
*/
/*
Written: 27 July 82 by John Knight
Modified: 30 Sept 82 by Doug Huskey
Modified: 03 Dec 82 by Bruce Skidmore
Modified: 18 May 1998 by John Elliott
*/
/********************************************
* *
* LITERALS AND GLOBAL VARIABLES *
* *
********************************************/
declare
true literally '1',
false literally '0',
forever literally 'while true',
lit literally 'literally',
proc literally 'procedure',
dcl literally 'declare',
addr literally 'address',
cr literally '13',
tab literally '9',
lf literally '10',
ctrlc literally '3',
ctrlx literally '18h',
bksp literally '8',
date$flag$offset literally '0ch', /* [JCE] Date in UK order? */
con$width$offset literally '1ah',
drive0$offset literally '4ch',
drive1$offset literally '4dh',
drive2$offset literally '4eh',
drive3$offset literally '4fh',
temp$drive$offset literally '50h',
ccp$flag1$offset literally '17h',
ccp$flag2$offset literally '18h',
pg$mode$offset literally '2ch',
pg$def$offset literally '2dh',
cpmversion literally '30h';
declare drive$table (4) byte;
declare order$table (2) byte initial(0);
declare drive (4) byte;
declare temp$drive byte;
declare date$flag byte; /* [JCE] Date in UK form? */
declare ccp$flag1 byte;
declare ccp$flag2 byte;
declare con$width byte;
declare i byte;
declare begin$buffer address;
declare buf$length byte;
/* display control variables */
declare show$drive byte initial(true);
declare show$order byte initial(true);
declare show$temp byte initial(true);
declare show$page byte initial(true);
declare show$display byte initial(true);
declare show$date byte initial(true); /* [JCE] */
declare scbpd structure
(offset byte,
set byte,
value address);
/* scanner variables and data */
declare
options(*) byte data
('TEMPORARY~ORDER~PAGE~DISPLAY~NO~COM~SUB~NOPAGE~NODISPLAY',
'~ON~OFF~UK~US',0ffh), /* [JCE] added US and UK */
options$offset(*) byte data
(0,10,16,21,29,32,36,40,47,57,60,64,67,70),
drives(*) byte data
('*~A:~B:~C:~D:~E:~F:~G:~H:~I:~J:~K:~',
'L:~M:~N:~O:~P:',0ffh),
drives$offset(*) byte data
(0,2,5,8,11,14,17,20,23,26,29,32,
35,38,41,44,47,49),
end$list byte data (0ffh),
delimiters(*) byte data (0,'[]=, ./;()',0,0ffh),
SPACE byte data(5),
j byte initial(0),
buf$ptr address,
index byte,
endbuf byte,
delimiter byte;
declare end$of$string byte initial ('~');
declare plm label public;
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
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;
mon3:
procedure (func,info) address external;
declare func byte;
declare info address;
end mon3;
declare cmdrv byte external; /* command drive */
declare fcb (1) byte external; /* 1st default fcb */
declare fcb16 (1) byte external; /* 2nd default fcb */
declare pass0 address external; /* 1st password ptr */
declare len0 byte external; /* 1st passwd length */
declare pass1 address external; /* 2nd password ptr */
declare len1 byte external; /* 2nd passwd length */
declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
printchar:
procedure(char);
declare char byte;
call mon1(2,char);
end printchar;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
version: procedure address;
/* returns current cp/m version # */
return mon3(12,0);
end version;
getscbbyte: procedure (offset) byte;
declare offset byte;
scbpd.offset = offset;
scbpd.set = 0;
return mon2(49,.scbpd);
end getscbbyte;
setscbbyte:
procedure (offset,value);
declare offset byte;
declare value byte;
scbpd.offset = offset;
scbpd.set = 0ffh;
scbpd.value = double(value);
call mon1(49,.scbpd);
end setscbbyte;
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * Option scanner * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
separator: procedure(character) byte;
/* determines if character is a
delimiter and which one */
declare k byte,
character byte;
k = 1;
loop: if delimiters(k) = end$list then return(0);
if delimiters(k) = character then return(k); /* null = 25 */
k = k + 1;
go to loop;
end separator;
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
/* scans the list pointed at by idxptr
for any strings that are in the
list pointed at by list$ptr.
Offptr points at an array that
contains the indices for the known
list. Idxptr points at the index
into the list. If the input string
is unrecognizable then the index is
0, otherwise > 0.
First, find the string in the known
list that starts with the same first
character. Compare up until the next
delimiter on the input. if every input
character matches then check for
uniqueness. Otherwise try to find
another known string that has its first
character match, and repeat. If none
can be found then return invalid.
To test for uniqueness, start at the
next string in the knwon list and try
to get another match with the input.
If there is a match then return invalid.
else move pointer past delimiter and
return.
P.Balma */
declare
buff based buf$ptr (1) byte,
idx$ptr address,
off$ptr address,
list$ptr address;
declare
i byte,
j byte,
list based list$ptr (1) byte,
offsets based off$ptr (1) byte,
wrd$pos byte,
character byte,
letter$in$word byte,
found$first byte,
start byte,
index based idx$ptr byte,
save$index byte,
(len$new,len$found) byte,
valid byte;
/*****************************************************************************/
/* internal subroutines */
/*****************************************************************************/
check$in$list: procedure;
/* find known string that has a match with
input on the first character. Set index
= invalid if none found. */
declare i byte;
i = start;
wrd$pos = offsets(i);
do while list(wrd$pos) <> end$list;
i = i + 1;
index = i;
if list(wrd$pos) = character then return;
wrd$pos = offsets(i);
end;
/* could not find character */
index = 0;
return;
end check$in$list;
setup: procedure;
character = buff(0);
call check$in$list;
letter$in$word = wrd$pos;
/* even though no match may have occurred, position
to next input character. */
i = 1;
character = buff(1);
end setup;
test$letter: procedure;
/* test each letter in input and known string */
letter$in$word = letter$in$word + 1;
/* too many chars input? 0 means
past end of known string */
if list(letter$in$word) = end$of$string then valid = false;
else
if list(letter$in$word) <> character then valid = false;
i = i + 1;
character = buff(i);
end test$letter;
skip: procedure;
/* scan past the offending string;
position buf$ptr to next string...
skip entire offending string;
ie., falseopt=mod, [note: comma or
space is considered to be group
delimiter] */
character = buff(i);
delimiter = separator(character);
/* No skip for SETPATH */
do while ((delimiter < 1) or (delimiter > 11));
i = i + 1;
character = buff(i);
delimiter = separator(character);
end;
endbuf = i;
buf$ptr = buf$ptr + endbuf + 1;
return;
end skip;
eat$blanks: procedure;
declare charac based buf$ptr byte;
do while ((delimiter := separator(charac)) = SPACE);
buf$ptr = buf$ptr + 1;
end;
end eat$blanks;
/*****************************************************************************/
/* end of internals */
/*****************************************************************************/
/* start of procedure */
call eat$blanks;
start = 0;
call setup;
/* match each character with the option
for as many chars as input
Please note that due to the array
indices being relative to 0 and the
use of index both as a validity flag
and as a index into the option/mods
list, index is forced to be +1 as an
index into array and 0 as a flag*/
do while index <> 0;
start = index;
delimiter = separator(character);
/* check up to input delimiter */
valid = true; /* test$letter resets this */
do while delimiter = 0;
call test$letter;
if not valid then go to exit1;
delimiter = separator(character);
end;
go to good;
/* input ~= this known string;
get next known string that
matches */
exit1: call setup;
end;
/* fell through from above, did
not find a good match*/
endbuf = i; /* skip over string & return*/
call skip;
return;
/* is it a unique match in options
list? */
good: endbuf = i;
len$found = endbuf;
save$index = index;
valid = false;
next$opt:
start = index;
call setup;
if index = 0 then go to finished;
/* look at other options and check
uniqueness */
len$new = offsets(index + 1) - offsets(index) - 1;
if len$new = len$found then do;
valid = true;
do j = 1 to len$found;
call test$letter;
if not valid then go to next$opt;
end;
end;
else go to nextopt;
/* fell through...found another valid
match --> ambiguous reference */
index = 0;
call skip; /* skip input field to next delimiter*/
return;
finished: /* unambiguous reference */
index = save$index;
buf$ptr = buf$ptr + endbuf;
call eat$blanks;
if delimiter <> 0 then
buf$ptr = buf$ptr + 1;
else
delimiter = 5;
return;
end opt$scanner;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crlf: proc;
call printchar(cr);
call printchar(lf);
end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* The error processor. This routine prints the command line
with a carot '^' under the offending delimiter, or sub-string.
The code passed to the routine determines the error message
to be printed beneath the command string. */
error: procedure (code);
declare (code,i,j,nlines,rem) byte;
declare (string$ptr,tstring$ptr) address;
declare chr1 based string$ptr byte;
declare chr2 based tstring$ptr byte;
declare carot$flag byte;
print$command: procedure (size);
declare size byte;
do j=1 to size; /* print command string */
call printchar(chr1);
string$ptr = string$ptr + 1;
end;
call crlf;
do j=1 to size; /* print carot if applicable */
if .chr2 = buf$ptr then do;
carot$flag = true;
call printchar('^');
end;
else
call printchar(' ');
tstring$ptr = tstring$ptr + 1;
end;
call crlf;
end print$command;
carot$flag = false;
string$ptr,tstring$ptr = begin$buffer;
con$width = getscbbyte(con$width$offset);
if con$width < 40 then con$width = 40;
nlines = buf$length / con$width; /* num lines to print */
rem = buf$length mod con$width; /* num extra chars to print */
if ((code = 1) or (code = 5)) then /* adjust carot pointer */
buf$ptr = buf$ptr - 1; /* for delimiter errors */
else
buf$ptr = buf$ptr - endbuf - 1; /* all other errors */
call crlf;
do i=1 to nlines;
tstring$ptr = string$ptr;
call print$command(con$width);
end;
call print$command(rem);
if carot$flag then
call print$buf(.('Error at the ''^''; $'));
else
call print$buf(.('Error at end of line; $'));
if con$width < 65 then
call crlf;
do case code;
call print$buf(.('More than four drives specified$'));
call print$buf(.('Invalid delimiter$'));
call print$buf(.('Invalid drive$'));
call print$buf(.('Invalid type for ORDER option$'));
call print$buf(.('Invalid option$'));
call print$buf(.('End of line expected$'));
call print$buf(.('Drive defined twice in search path$'));
call print$buf(.('Invalid ORDER specification$'));
call print$buf(.('Must be ON or OFF$'));
end;
call crlf;
call mon1(0,0);
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This is the main screen display for SETPATH. After every
successful operation, this procedure will be called to
show the results. This routine is also called whenever the
user just types SETPATH with no options. */
display$path: procedure;
declare i byte;
declare (display$flag,pg$mode,order,date) byte;
/* GET SETTINGS FROM SYSTEM CONTROL BLOCK */
drive(0) = getscbbyte(drive0$offset);
drive(1) = getscbbyte(drive1$offset);
drive(2) = getscbbyte(drive2$offset);
drive(3) = getscbbyte(drive3$offset);
temp$drive = getscbbyte(temp$drive$offset);
pg$mode = getscbbyte(pg$mode$offset);
ccp$flag2 = getscbbyte(ccp$flag2$offset);
date$flag = getscbbyte(date$flag$offset);
display$flag = ccp$flag2 and 00$000$011b;
order = shr((ccp$flag2 and 00$011$000b),3);
date = (date$flag and 1);
/* 0 = COM, 1 = COM,SUB, 2 = SUB,COM */
/* DRIVE SEARCH PATH */
if show$drive then do;
call crlf;
call print$buf(.('Drive Search Path:',cr,lf,'$'));
i = 0;
do while ((drive(i) <> 0ffh) and (i < 4));
call printchar(i + '1');
do case i;
call print$buf(.('st$'));
call print$buf(.('nd$'));
call print$buf(.('rd$'));
call print$buf(.('th$'));
end;
call print$buf(.(' Drive - $'));
if drive(i) = 0 then
call print$buf(.('Default$'));
else do;
call printchar(drive(i) + 40h);
call printchar(':');
end;
call crlf;
i = i + 1;
end;
end;
/* PROGRAM vs. SUBMIT SEARCH ORDER */
if show$order then do;
call crlf;
call print$buf(.('Search Order - $'));
do case order;
call print$buf(.('COM$'));
call print$buf(.('COM, SUB$'));
call print$buf(.('SUB, COM$'));
end;
end;
/* TEMPORARY FILE DRIVE */
if show$temp then do;
call crlf;
call print$buf(.('Temporary Drive - $'));
if temp$drive > 16
then temp$drive = 0;
if temp$drive = 0 then
call print$buf(.('Default$'));
else do;
call printchar(temp$drive + 40h);
call printchar(':');
end;
end;
/* CONSOLE PAGE MODE */
if show$page then do;
call crlf;
call print$buf(.('Console Page Mode - $'));
if pg$mode = 0 then
call print$buf(.('On$'));
else
call print$buf(.('Off$'));
end;
/* PROGRAM NAME & DRIVE DISPLAY */
if show$display then do;
call crlf;
call print$buf(.('Program Name Display - $'));
if display$flag = 0 then
call print$buf(.('Off$'));
else
call print$buf(.('On$'));
end;
/* [JCE] TIME FORMAT DISPLAY */
if show$date then do;
call crlf;
call print$buf(.('Date format used - $'));
if date = 0 then
call print$buf(.('US$'));
else
call print$buf(.('UK$'));
end;
call crlf;
end display$path;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This routine processes the search drives string. When called
this routine scans the command line expecting a drive name, a:-p:.
It puts the drive code in a drive table and continues the scan
collecting drives until more than 4 drives are specified (an error)
or an eoln or the delimiter '[' is encountered. Next it modifies
the SCB searchchain bytes so that it reflects the drive order as
inputed. No check is made to insure that the drive specified is
a known drive to the particular system being used. */
process$drives: procedure;
declare (i,ct) byte;
show$drive = true;
index = 0;
delimiter = 0;
do i=0 to 3; /* clear drive table */
drive$table(i) = 0ffh;
end;
ct = 0;
do while ((delimiter <> 1) and (delimiter <> 11)); /* not eoln */
call opt$scanner(.drives(0),.drives$offset(0),.index);
if ct > 3 then /* too many drives */
call error(0);
if index = 0 then /* invalid drive */
call error(2);
do i=0 to 3;
if drive$table(i) = (index-1) then
call error(6); /* Drive already defined */
end;
drive$table(ct) = index-1;
ct = ct + 1;
end;
do i=0 to 3; /* update scb drive table */
call setscbbyte(drive0$offset+i,drive$table(i));
end;
end process$drives;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* This routine does all the processing for the options. Ie. any
string beginning with a '['. The routine will handle basically
five options: Temporary, Order, Display, Page, No Display and
No Page. Each routine is fairly short and can be found as a
branch in the case statement.
*/
process$options: procedure;
declare next$delim based buf$ptr byte;
declare (first$sub,paren,val) byte;
do while (delimiter <> 2) and (delimiter <> 11);
index = 0;
delimiter = 1;
call opt$scanner(.options(0),.options$offset(0),.index);
do case index;
call error(4); /* not in options list (INVALID) */
do; /* temporary drive option */
show$temp = true;
if delimiter <> 3 then /* = */
call error(1);
call opt$scanner(.drives(0),.drives$offset(0),.index);
if index = 0 then
call error(2);
call setscbbyte(temp$drive$offset,index-1);
end;
do; /* order option */
show$order = true;
first$sub,paren = false;
if delimiter <> 3 then /* = */
call error(1);
do while ((next$delim = ' ') or (next$delim = tab)); /* skip spaces */
buf$ptr = buf$ptr + 1;
end;
if next$delim = '(' then do;
paren = true;
buf$ptr = buf$ptr + 1;
end;
call opt$scanner(.options(0),.options$offset(0),.index);
if ((index <> 6) and (index <> 7)) then
call error(3);
if index = 7 then /* note that the first entry was SUB */
first$sub = true;
order$table(0) = index - 6;
if (first$sub and ((delimiter = 10) or not paren)) then
call error(7); /* (SUB) not allowed */
if (delimiter <> 10) and paren then do;
call opt$scanner(.options(0),.options$offset(0),.index);
if ((index <> 6) and (index <> 7)) then
call error(3);
order$table(1) = index - 6;
if (first$sub and (index = 7)) then /* can't have SUB,SUB */
call error(7);
end;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
if order$table(0) = 0 then
ccp$flag2 = ccp$flag2 and 111$0$1111b;
else
ccp$flag2 = ccp$flag2 or 000$1$0000b;
if order$table(1) = 0 then
ccp$flag2 = ccp$flag2 and 1111$0$111b;
else
ccp$flag2 = ccp$flag2 or 0000$1$000b;
call setscbbyte(ccp$flag2$offset,ccp$flag2);
if paren then do;
if delimiter <> 10 then
call error(1);
else
buf$ptr = buf$ptr + 1;
end;
else if delimiter = 10 then
call error(1);
if next$delim = ']' or next$delim = 0 then /* two delimiters */
delimiter = 11; /* eoln, so exit loop */
end;
/* PAGE Option */
do;
show$page = true;
val = 0;
if delimiter = 3 then do; /* = */
call opt$scanner(.options(0),.options$offset(0),.index);
if index <> 10 then
if index = 11 then
val = 0ffh;
else
call error(8);
end;
call setscbbyte(pg$mode$offset,val);
call setscbbyte(pg$def$offset,val);
end;
/* call error(4); page option now an error */
do; /* DISPLAY option */
show$display,val = true;
if delimiter = 3 then do; /* = */
call opt$scanner(.options(0),.options$offset(0),.index);
if index <> 10 then
if index = 11 then
val = false;
else
call error(8);
end;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
if val then
ccp$flag2 = ccp$flag2 or 00000$0$11b; /* set bits */
else
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
/* call error(4); Display option now an error */
do; /* NO keyword */
call opt$scanner(.options(0),.options$offset(0),.index);
if (index <> 3) and (index <> 4) then
call error(4);
if index = 3 then do; /* NO PAGE option */
show$page = true;
call setscbbyte(pg$mode$offset,0FFh);
call setscbbyte(pg$def$offset,0FFh);
end;
else do; /* NO DISPLAY option */
show$display = true;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
end;
/* call error(4); NO keyword is now an error */
call error(4); /* COM is not an option */
call error(4); /* SUB is not an option */
/* NOPAGE option */
do;
show$page = true;
call setscbbyte(pg$mode$offset,0FFh);
call setscbbyte(pg$def$offset,0FFh);
end;
/* NODISPLAY option */
do;
show$display = true;
ccp$flag2 = getscbbyte(ccp$flag2$offset);
ccp$flag2 = ccp$flag2 and 11111$1$00b; /* clear bits */
call setscbbyte(ccp$flag2$offset,ccp$flag2);
end;
call error(4); /* ON is not an option */
call error(4); /* OFF is not an option */
/* [JCE] UK option */
do;
show$date = true;
date$flag = getscbbyte(date$flag$offset);
date$flag = date$flag or 1; /* Set that bit */
call setscbbyte(date$flag$offset, date$flag);
end;
/* [JCE] US option */
do;
show$date = true;
date$flag = getscbbyte(date$flag$offset);
date$flag = date$flag and 11111110b; /* Clear that bit */
call setscbbyte(date$flag$offset, date$flag);
end;
end;
end;
end process$options;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
input$found: procedure (buffer$adr) byte;
declare buffer$adr address;
declare char based buffer$adr byte;
do while (char = ' ') or (char = 9); /* tabs & spaces */
buffer$adr = buffer$adr + 1;
end;
if char = 0 then /* eoln */
return false; /* input not found */
else
return true; /* input found */
end input$found;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/**************************************
* *
* M A I N P R O G R A M *
* *
**************************************/
plm:
do;
if (low(version) < cpmversion) or (high(version) = 1) then do;
call print$buf(.('Requires CP/M 3.0$'));
call mon1(0,0);
end;
if not input$found(.tbuff(1)) then do;
/* SHOW DEFAULTS */
call display$path;
call mon1(0,0); /* & terminate */
end;
/* SET DEFAULTS */
i = 1; /* skip over leading spaces */
do while (tbuff(i) = ' ');
i = i + 1;
end;
show$drive,show$order,show$temp,show$page,show$display,show$date /*[JCE]*/
= false;
begin$buffer = .tbuff(1); /* note beginning of input */
buf$length = tbuff(0); /* note length of input */
buf$ptr = .tbuff(i); /* set up for scanner */
if tbuff(i) = '[' then do; /* options, no drives */
buf$ptr = buf$ptr + 1; /* skip over '[' */
call process$options;
end;
else do; /* drives first, maybe options too */
call process$drives;
if delimiter = 1 then /* options, because we found an '[' */
call process$options;
end;
call display$path; /* show results */
call mon1(0,0); /* & terminate */
end;
end setdef;

BIN
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SHOW.COM Normal file
View File

Binary file not shown.

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SHOW.MAK Normal file
View File

@@ -0,0 +1,5 @@
:F1:PLM80 show.PLM debug optimize PAGEWIDTH(132)
:F3:link mcd80a.obj,show.obj,:F1:plm80.lib to show.mod
:F3:locate show.mod code(0100H) stacksize(100) map print(show.tra)
:F3:objhex show to show.hex
exit

1898
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SHOW.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

119
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/SORT.PLM Normal file
View File

@@ -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 print(.(cr,lf,'Sorting Directory...',cr,lf,'$'));
call qsort(0,filesfound - 1);
sorted = true;
end sort;
end sort;

242
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/TIMEST.PLM Normal file
View File

@@ -0,0 +1,242 @@
$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)
getscbbyte: procedure (offset) byte external;
declare offset byte;
end getscbbyte;
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;
/* [JCE 17-5-1998] As the comment below makes clear, DIR is not Year2000
compliant as supplied in 1982. Hence the line below: */
b = b mod 100;
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;
if (get$scb$byte(date$flag$offset) and 1) then /* [JCE] UK-format dates */
do;
call emit$slant(day);
call emit$slant(month);
end;
else
do;
call emit$slant(month);
call emit$slant(day);
end;
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;

148
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/UTIL.PLM Normal file
View File

@@ -0,0 +1,148 @@
$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;

5
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/VERS.LIT Normal file
View File

@@ -0,0 +1,5 @@
declare
bdos20 lit '20h',
bdos30 lit '30h',
mpm lit '01h',
mpm86 lit '11h';

22
CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/Y2K PATCHES/XFCB.LIT Normal file
View File

@@ -0,0 +1,22 @@
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';