seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-25 17:34:06 +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

12
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/COMLIT.LIT Normal file
View File

@@ -0,0 +1,12 @@
declare
lit literally 'literally',
dcl lit 'declare',
true lit '0ffh',
false lit '0',
no lit 'not',
boolean lit 'byte',
forever lit 'while true',
cr lit '13',
lf lit '10',
tab lit '9';


8
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/COPYRT.LIT Normal file
View File

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


22
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/FCB.LIT Normal file
View File

@@ -0,0 +1,22 @@
declare
f$drvusr lit '0', /* drive/user byte */
f$name lit '1', /* file name */
f$namelen lit '8', /* file name length */
f$type lit '9', /* file type field */
f$typelen lit '3', /* type length */
f$rw lit '9', /* high bit is R/W attribute */
f$dirsys lit '10', /* high bit is dir/sys attribute */
f$arc lit '11', /* high bit is archive attribute */
f$ex lit '12', /* extent */
f$s1 lit '13', /* module byte */
f$rc lit '15', /* record count */
f$diskmap lit '16', /* file disk map */
diskmaplen lit '16', /* disk map length */
f$drvusr2 lit '16', /* fcb2 */
f$name2 lit '17',
f$type2 lit '25',
f$cr lit '32', /* current record */
f$rrec lit '33', /* random record */
f$rreco lit '35'; /* " " overflow */


1845
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/FILE4.BDO Normal file
View File

File diff suppressed because it is too large Load Diff

159
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/FILE5.BDO Normal file
View File

@@ -0,0 +1,159 @@
;************ bdos file system part 5 ************
; BDOS functions which do not require
; ownership of the MXdisk queue
func24: ;return the login vector
;======
mov bx,dlog
ret
func25: ;return selected disk number
;======
if BCPM
mov bl,p_dsk
endif
if BMPM
mov si,rlr
mov bl,p_dsk[si]
endif
ret
func26: ;set the subsequent dma address to info
;======
if BCPM
mov p_dma_off,dx
endif
if BMPM
mov u_dma_ofst,dx
endif
ret
func29: ;return r/o bit vector
;======
mov bx,rodsk
ret
func32: ;set user code
;======
if BCPM
mov al,dl
cmp al,0ffh
jnz setusrcode
mov bl,p_user ;interrogate user code instead
ret
setusrcode:
and al,0fh
mov p_user,al
ret ;jmp goback
endif
if BMPM
mov si,rlr
cmp dl,0ffh ! jne setusrcode
mov bl,p_user[si]
ret
setusrcode:
and dl,0fh
mov p_user[si],dl
ret
endif
func44: ;set multi-sector count
;======
xor bx,bx
or dl,dl
jz return_not_ok
cmp dl,129
jnb return_not_ok
if BCPM
mov p_mult_cnt,dl
endif
if BMPM
mov u_mult_cnt,dl
endif
ret
return_not_ok:
dec bx ;return BX = 0ffffh
ret
func45: ;set bdos error mode
;======
if BCPM
mov p_error_mode,dl
endif
if BMPM
mov u_error_mode,dl
endif
ret
func51: ; set dma base
;======
if BCPM
mov p_dma_seg,dx
endif
if BMPM
mov u_dma_seg,dx
endif
ret
func52: ; get dma
;======
if BCPM
mov ax,p_dma_seg
mov p_user_es,ax
mov bx,p_dma_off
endif
if BMPM
mov ax,u_dma_seg
mov u_retseg,ax
mov bx,u_dma_ofst
endif
ret
func104: ;set current date and time
;=======
mov si,dx
mov di,offset tod
pushf! cli
push es! push ds ;save DS and ES
if BCPM
mov ds,p_user_ds
endif
if BMPM
mov ds,u_wrkseg
endif
pop es
movsw! movsw
push es
pop ds! pop es ;restore DS and ES
mov byte ptr tod+4,0
popf
ret
func105: ;get current date and time
;=======
mov di,dx
mov si,offset tod
push es
if BCPM
mov es,p_user_ds
endif
if BMPM
mov es,u_wrkseg
endif
pushf! cli
movsw! movsw
mov bl,tod+4
popf
pop es
ret
;********** end bdos file system part 5 **********


43
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/MFUNC.LIT Normal file
View File

@@ -0,0 +1,43 @@
/* Concurrent CP/M function numbers */
dcl m$prtbuf lit '9',
m$select lit '14',
m$openf lit '15',
m$closef lit '16',
m$deletef lit '19',
m$readf lit '20',
m$writef lit '21',
m$makef lit '22',
m$getlogin lit '24',
m$curdsk lit '25',
m$setdma lit '26',
m$setatt lit '30',
m$setusr lit '32',
m$readrf lit '33',
m$writerf lit '34',
m$resetdrv lit '37',
m$errmode lit '45',
m$dirbios lit '50',
m$makeq lit '134',
m$openq lit '135',
m$deleteq lit '136',
m$readq lit '137',
m$creadq lit '138',
m$writeq lit '139',
m$cwriteq lit '140',
m$delay lit '141',
m$dispatch lit '142',
m$setprior lit '145',
m$detach lit '147',
m$setcns lit '148',
m$parse lit '152',
m$getcns lit '153',
m$sysdat lit '154',
m$getpd lit '156',
m$abort lit '157';
/* Internal calls */
dcl mi$sleep lit '0212H',
mi$wakeup lit '0213H';


8
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/MXFUNC.LIT Normal file
View File

@@ -0,0 +1,8 @@
/* MP/M-86 XIOS function numbers */
dcl mx$conin lit '1',
mx$conout lit '2',
mx$lstout lit '4',
mx$switch lit '7',
mx$upstatus lit '8',
mx$consmode lit '30';

24
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/NETPIN.LIT Normal file
View File

@@ -0,0 +1,24 @@
/* Network-related structures and pointers for PIN, 12/7/83 RBB */
dcl net$bit lit '040h';
dcl net$flag boolean;
dcl nda$pointer pointer;
dcl nda$ptr structure (offset word, segment word) at (@nda$pointer);
/* Start of NDA structure */
dcl nda based nda$pointer structure (
rcb$pointer pointer,
rct$pointer pointer);
/* Requester configuration table */
dcl rct$ptr pointer;
dcl rct based rct$ptr structure (
rc$cnt word,
rc$disks(16) word,
rc$cons(16) word,
rc$list(16) word);


20
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/PIN.CSD Normal file
View File

@@ -0,0 +1,20 @@
; This sub file compiles, links and generates in hex the PIN rsp
; for Concurrent CP/M version 3.1.
; It is meant for use under UDI.
;
; After the last step in this file, do:
; GENCMD PIN DATA[B1000]
; REN PIN.RSP=PIN.CMD
;
asm86 rhpin.a86
asm86 pxios.a86
plm86 pin.p86 xref debug optimize(3)
link86 rhpin.obj, pxios.obj, pin.obj to rhpin.lnk
rename rhpin.lnk to pin.lnk
loc86 pin.lnk od(sm(code,dats,data,const,stack)) &
ad(sm(code(0),dats(10000h))) ss(stack(0)) to pin.dat
oh86 pin.dat
rename pin.hex to pin.h86


592
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/PIN.P86 Normal file
View File

@@ -0,0 +1,592 @@
$set (debug=0)
$compact
pin:
do;
/* PIN performs physical input from for each physical console
and places the characters into the input queue associated
with each virtual console. Switch screen commands are
received from the XIOS and acted on by PIN.
Control S/Q, Control O and Control C are intercepted and
processed by PIN. The input queues are created by VOUT.
*/
$include (comlit.lit)
dcl rsp$link word external; /* segment of SYSDAT */
$include (mfunc.lit)
$include (mxfunc.lit)
$include (sdpin.lit)
$include (proces.lit)
declare pd$pointer pointer;
declare pd$ptr structure (offset word, segment word) at (@pd$pointer);
declare pd based pd$pointer pd$structure;
$include (uda.lit)
declare ncopies byte external, /* copy number of this process, corresponds */
cnsnum byte at(@ncopies);/* with physical console number */
declare himark byte; /* total physical consoles for this PIN */
declare lomark byte; /* first virtual console for this PIN */
declare ctrlC lit '3'; /* some ASCII codes */
declare ctrlD lit '4';
declare bell lit '7';
declare ctrlO lit '15';
declare ctrlP lit '16';
declare ctrlQ lit '17';
declare ctrlS lit '19';
declare esc lit '27';
/* - global variables - */
$include (netpin.lit)
$include (vccb.lit)
declare ccb$pointer pointer;
declare ccb$ptr structure(offset word,segment word) at (@ccb$pointer);
declare ccb based ccb$pointer ccb$structure;
declare old$ccb$pointer pointer;
declare old$ccb based old$ccb$pointer ccb$structure;
declare lcb$pointer pointer;
declare lcb$ptr structure(offset word,segment word) at (@lcb$pointer);
declare lcb based lcb$pointer lcb$structure;
declare screen byte; /* current foreground screen number */
declare cns word; /* Hi byte = physical, Lo byte = virtual */
declare cnmode word; /* Result of GetConMode XIOS call - PCMODE*/
$include (qd.lit)
declare qpb qpb$structure;
dcl null word data (0ffffh); /* sent to VOUTQ to wake up VOUT */
/* Note: this forces a 2 byte constant section and thus hex generation */
dcl apb structure ( /* abort parameter block */
pd word, term word, cns byte, rsrvd byte) initial (0,0,0,0);
dcl cword word, /* format of console input from XIOS */
chars (2) byte at (@cword),
char byte at (@chars(0)),
char$type byte at(@chars(1)),
ct$switch lit '0ffh',
ct$data lit '0';
dcl temp1$pointer pointer;
dcl temp1$ptr structure (offset word, segment word) at (@temp1$pointer);
dcl temp1 based temp1$pointer pd$structure;
dcl temp2$pointer pointer;
dcl temp2$ptr structure (offset word, segment word) at (@temp2$pointer);
dcl temp2 based temp2$pointer pd$structure;
mon1: procedure(func,a) external;
dcl func byte, a address;
end mon1;
mon2: procedure(func,a) byte external;
dcl func byte, a address;
end mon2;
mon3: procedure(func,a) address external;
dcl func byte, a address;
end mon3;
mon4: procedure(func,a) pointer external;
dcl func byte, a address;
end mon4;
intsys: procedure (cx, dx, bx) external; /* internal O.S. functions */
dcl (cx, dx, bx) word;
end intsys;
/* the following 4 procedures call the XIOS directly, the PXIOS.A86 */
/* sets the registers to make this legal. DS = system data segment, */
/* ES = UDA. The parameters are passed AX=FUNC, CX=P1, DX=P2 */
pxios1: procedure(func,p1,p2) external;
dcl (func,p1,p2) address;
end pxios1;
/*pxios2: procedure(func,p1,p2) byte external;
dcl (func,p1,p2) address;
end pxios2;*/
pxios3: procedure(func,p1,p2) word external;
dcl (func,p1,p2) address;
end pxios3;
/*pxios4: procedure(func,p1,p2) pointer external;
dcl (func,p1,p2) address;
end pxios4;*/
conin: procedure;
cword = pxios3(mx$conin, 0, ccb.pc);/* get console input from XIOS */
end; /* AX=func, CX=0, DX(device#)=0 */
get$cons$mode: procedure;
cnmode = pxios3(mx$consmode,0100h,ccb.vc); /* get console mode from XIOS*/
end;
print$msg: procedure(len, endchar, sptr); /* print string to delimiter */
dcl (len, i, endchar) byte, sptr pointer, /* or len number of chars */
string based sptr (1) byte;
i = 0;
do while string(i) <> endchar and i < len;
call pxios1(mx$conout, string(i), ccb.vc);
i = i + 1;
end;
end print$msg;
$if debug=1
error: procedure (msg$ptr);
dcl msg$ptr pointer;
call print$msg(0ffh, 0, @(cr, lf, '**** PIN ERROR ****', cr, lf, 0));
call print$msg(0ffh, '$', msg$ptr);
halt;
end error;
$endif
read$change$mxq: procedure (qaddr);
dcl qaddr address;
qpb.qaddr = qaddr;
call mon1 (m$readq, .qpb);
end read$change$mxq;
write$change$mxq: procedure (qaddr);
dcl qaddr address;
qpb.qaddr = qaddr;
call mon1 (m$writeq, .qpb);
end write$change$mxq;
sleep: procedure (list$root);
dcl list$root word;
call intsys(mi$sleep, list$root, ps$ciowait);
end sleep;
wake$up: procedure (list$root);
dcl list$root word;
call intsys(mi$wakeup, list$root, 0);
end wake$up;
/* The conout flag is set and "owned" before any process calls the XIOS
console output routine for a particular screen. PIN sets this flag
to insure there is no process in the XIOS console output code. The
ccb.cosleep is a temporary location for processes waiting to own the
the XIOS conout bit. */
set$conout$flag: procedure(ccb$ptr);
dcl ccb$ptr pointer;
dcl ccb based ccb$ptr ccb$structure;
disable;
do while (ccb.flag and cf$conout) <> 0; /* Another process is in XIOS */
call sleep (.ccb.cosleep); /* PIN gets awakened 1st: */
end; /* better priority */
ccb.flag = ccb.flag or cf$conout;
enable;
end set$conout$flag;
reset$conout$flag: procedure (ccb$ptr);
dcl ccb$ptr pointer;
dcl ccb based ccb$ptr ccb$structure;
ccb.flag = ccb.flag and not cf$conout; /* wake sleeping process */
call wakeup(.ccb.cosleep);
end reset$conout$flag;
wake$vout: procedure(ccb$ptr);
dcl ccb$ptr pointer;
dcl ccb based ccb$ptr ccb$structure;
if (ccb.state and csm$buffered) = 0 then
return; /* dynamic mode */
qpb.qaddr = ccb.voutq;
qpb.buffptr = .null; /* VOUT message is 2 byte format */
call mon1(m$cwriteq, .qpb); /* null message if first byte = 0ffh */
qpb.qaddr = ccb.voutq;
qpb.buffptr = .null; /* VOUT needs two wake-ups in some */
call mon1(m$cwriteq, .qpb); /* situations */
call wake$up(.ccb.vsleep);
end wake$vout;
write$vinq: procedure(c);
dcl c word;
qpb.qaddr = ccb.vinq;
qpb.buffptr = .c;
if mon3(m$cwriteq, .qpb) = 0ffffh then /* ring console bell if type */
do;
call set$conout$flag(@ccb); /* XIOS is not reentrant on same console */
call pxios1(mx$conout, bell, ccb.vc); /* ahead buffer if full */
call reset$conout$flag(@ccb);
end;
end write$vinq;
set$ccb: procedure (vc); /* base VCCB structure */
dcl vc byte;
old$ccb$pointer = ccb$pointer;
ccb$ptr.offset = sd.ccb + size(ccb) * vc;
end set$ccb;
/* the functions below act on special keys received from the keyboard */
dcl controlS$has$been$pressed boolean initial (false);
switch: procedure; /* switch virtual consoles */
if char >= himark then
return; /* check for legal range */
if (ccb.state and csm$noswitch) <> 0 then /* no switch state */
return;
call get$cons$mode; /*returns graphics or alpha mode*/
if (cnmode and 0ffh) > 15 then /*Graphics-active processes may */
return; /*not switch into background */
char = char + lomark; /* normalize to right ccb number */
if char = ccb.vc then /* request is for currently selected screen */
return;
call set$ccb(screen := char); /* switch old$ccb and ccb structures */
/* - Switch Out Action - */
call read$change$mxq(oldccb.vcmxq); /* read the MX 1st THEN */
call set$conout$flag(@oldccb); /* the conout flag */
pd$ptr.offset = oldccb.attach;
uda$ptr.segment = pd.uda;
uda$ptr.offset = 0;
if (pd.ps_flag and psf_suspend) then /* tell system to suspend */
oldccb.state = oldccb.state or csm$suspend; /* the process */
pd$pointer = mon4(m$getpd,0); /* restore PD offset */
oldccb.state = oldccb.state or csm$background;
if (oldccb.state and csm$purging) <> 0 then
oldccb.state = oldccb.state and not double(csm$purging);
/* turn off purge */
/* Ensure the two affected screens are not currently being updated */
/* by the XIOS console output routines. */
call read$change$mxq(ccb.vcmxq);
call set$conout$flag$(@ccb);
cns = ccb.pc;
cns = shl(cns,8) + ccb.vc; /* Hi byte = phys.,Lo byte = virtual*/
call pxios1(mx$switch, 0, cns); /* for XIOS device parameter */
call reset$conout$flag(oldccb$pointer);
call write$change$mxq(oldccb.vcmxq); /* allow VOUT to change state */
if (oldccb.state and csm$buffered) <> 0 then /* background buffered */
call wake$vout(@oldccb); /* send chars to VOUT if buffer, */
/* else user process hangs on USLEEP */
/* - Switch In Action - */
if (ccb.state and csm$suspend) <> 0 then /* process is suspended */
do; /* put it back in action */
disable;
ccb.state = ccb.state and not double(csm$suspend);
pd$ptr.offset = ccb.attach;
temp1$ptr.offset = susplst; /* get Suspend List Root */
do while (temp1.link <> pd$ptr.offset) and /* search SPL for process*/
(temp1.link <> 0);
temp1$ptr.offset = temp1.link;
end;
if (temp1.link = pd$ptr.offset) then /* it's on suspend list */
do;
temp1.link = pd.link; /* temp1 = PD ; take it off the list */
/* Get the Dispatch Ready List */
temp2$ptr.offset = dsptchlst;
pd.link = temp2.link;
pd.stat = psrun;
temp2.link = pd$ptr.offset; /* put on top of list */
end;
enable;
end;
ccb.state = ccb.state and not double(csm$background);
if (ccb.state and csm$buffered) <> 0 then
do; /* buffer or buffer error states */
/* turn on purge */
ccb.state = (ccb.state or csm$purging) and not double(csm$filefull);
/* turn off error could print msg */
call wake$vout(@ccb); /* here eventually */
end;
call reset$conout$flag(ccb$pointer);
call write$change$mxq(ccb.vcmxq);
if (ccb.state and csm$ctrlS) <> 0 then /* we "own" the XIOS console */
controlS$has$been$pressed = true; /* output flag */
else
controlS$has$been$pressed = false;
call pxios1(mx$upstatus, 0, ccb.pc);
end switch;
dcl drive$letters (17) byte initial ('ABCDEFGHIJKLMNOP ');
controlC: procedure;
dcl (junk,cur$drive,logged$in$drives) word;
dcl letter$index byte;
if (pd.conmode and pcm$ctlc) <> 0 then
do;
call write$vinq(cword);
return;
end;
call read$change$mxq(ccb.vcmxq); /* keep CCB state from changing */
/* while we test and change it */
ccb.state = ccb.state and not double(csm$ctrlS or csm$ctrlO);
controlS$has$been$pressed = false;
/* control C turns off control S and */
/* control O, doesn't change control P */
if (ccb.state and csm$purging) <> 0 then /* stop purge */
ccb.state = ccb.state and not double (csm$purging) or csm$abort;
qpb.qaddr = ccb.vinq; /* drain input queue, we have better */
qpb.buffptr = .junk; /* priority than user process or TMP */
do while mon2(m$creadq, .qpb) <> 0ffh; /* drain type-ahead q */
end;
ccb.nchar = 0; /* zero console status look ahead */
call write$change$mxq(ccb.vcmxq);
call wake$vout(@ccb); /* let VOUT clean up if buffering */
call wake$up(.ccb.usleep); /* user process could have gone to sleep */
/* during this rigamarole */
apb.pd = ccb.attach; /* CIO keeps aborts from happening */
call mon1(m$abort, .apb); /* while in the XIOS, do abort after */
/* VOUT has cleaned up, otherwise the TMP*/
/* with a better priority can print its */
/* prompt, and then VOUT prints one last */
/* purge character */
/* reset drives and print which fail */
logged$in$drives = mon3(m$getlogin,0);
cur$drive = 1; /* drive to reset */
letter$index = 0;
do junk = 0 to 15;
if (logged$in$drives and cur$drive) <> 0 then
if mon2(m$resetdrv, cur$drive) <> 0 then
do;
drive$letters(letter$index) = 'A' + junk;
letter$index = letter$index + 1;
end;
cur$drive = shl(cur$drive,1);
end;
if letter$index > 0 then
do;
call set$conout$flag(@ccb);
call print$msg(0ffh,0,@(cr,lf,'Open file on drive(s) ',0));
call print$msg(1,0,@drive$letters(0));
do junk = 1 to letter$index - 1;
call print$msg(1,0,@(','));
call print$msg(1,0,@drive$letters(junk));
end;
call print$msg(2,0,@(cr,lf));
ccb.startcol, ccb.column = 0; /* for function 10 - line redraw */
call reset$conout$flag(@ccb);
end;
end controlC;
controlO: procedure; /* toggle console output byte bucket */
if (pd.conmode and pcm$ctlo) <> 0 then /* ignore if control P or if func */
do;
call write$vinq(cword);
return;
end;
call read$change$mxq(ccb.vcmxq);
ccb.state = ccb.state xor csm$ctrlO;
call write$change$mxq(ccb.vcmxq);
call wake$vout(@ccb);
call pxios1(mx$upstatus, 0, ccb.pc);
end controlO;
turn$off$ctrlO: procedure;
call read$change$mxq(ccb.vcmxq);
ccb.state = ccb.state and not double(csm$ctrlO);
call write$change$mxq(ccb.vcmxq);
call wake$vout(@ccb);
call pxios1(mx$upstatus, 0, ccb.pc);
end turn$off$ctrlO;
controlS: procedure;
if (pd.flag and pf$noctls) <> 0 then /* special condition for CLI day */
return; /* file logging */
if (pd.conmode and pcm$ctlS) <> 0 then
do;
call write$vinq(cword);
return;
end;
call read$change$mxq(ccb.vcmxq);
ccb.state = ccb.state and not double(csm$ctrlO) or csm$ctrlS;
/* control S turns off control O */
call pxios1(mx$upstatus, 0, ccb.pc);
call write$change$mxq(ccb.vcmxq);
controlS$has$been$pressed = true;
end controlS;
controlQ: procedure;
call read$change$mxq(ccb.vcmxq);
ccb.state = ccb.state and not double(csm$ctrlS);
call write$change$mxq(ccb.vcmxq);
call wake$vout(@ccb);
call wakeup(.ccb.usleep);
call pxios1(mx$upstatus, 0, ccb.pc);
controlS$has$been$pressed = false;
end controlQ;
controlP: procedure;
if (pd.conmode and pcm$rout) <> 0 then /* control P is ignored if console */
do;
call write$vinq(cword);
return; /* mode is raw output */
end;
call turn$off$ctrlO;
call read$change$mxq(ccb.vcmxq);
if (ccb.state and csm$ctrlP) = 0 then /* turn control P on */
do;
lcb$ptr.offset = sd.lcb + pd.lst * size(lcb);
disable;
/* Network check,12/7/83,RBB */
net$flag = true;
if (sd.module$map and net$bit) <> 0 then /* Check for net loaded */
if pd.nda$para <> 0 then /* Check for process attached*/
do;
nda$ptr.segment = pd.nda$para;
nda$ptr.offset = 0;
rct$ptr = nda.rct$pointer; /* Check if printer is mapped*/
if (rct.rc$list(pd.lst) and 0080h) <> 0 then
net$flag = false;
end;
if (lcb.attach = 0) and net$flag then
do;
lcb.attach = 0ffffh;
lcb.msource = screen;
ccb.mimic = pd.lst;
ccb.state = ccb.state or csm$ctrlP;
enable;
end;
/*if lcb.attach = 0 then
do;
lcb.attach = 0ffffh;
lcb.msource = screen;
ccb.mimic = pd.lst;
ccb.state = ccb.state or csm$ctrlP;
enable;
end; */
else
do;
enable;
call set$conout$flag(@ccb);
call print$msg(0ffh,0,@(cr,lf,'Printer Busy',cr,lf,0));
ccb.column,ccb.startcol = 0; /* for function 10 */
call reset$conout$flag(@ccb);
end;
end;
else /* turn off control P */
do;
disable;
lcb$ptr.offset = sd.lcb + ccb.mimic * size(lcb);
lcb.attach = 0;
lcb.msource,ccb.mimic = 0ffh;
ccb.state = ccb.state and not double(csm$ctrlP);
ccb.flag = ccb.flag and not cf$bufp;
call wakeup(.lcb.queue);
enable;
end;
call write$change$mxq(ccb.vcmxq);
call pxios1(mx$upstatus, 0, ccb.pc);
end controlP;
raw: procedure boolean;
if (pd$ptr.offset := ccb.attach) = 0 then /* 0 during initialization */
return(true);
if (pd.flag and pf$raw) = 0 then /* set by function 6 only */
return(false);
/* 3.1M maintenance fix for call to status line routine */
if (controlS$has$been$pressed) then
/* end of 3.1M patch */
call controlQ; /* avoid deadlock if user is mixing func 6 */
return(true); /* other console I/O calls */
end raw;
plmstart: procedure public;
sysdat$ptr.segment, lcb$ptr.segment, ccb$ptr.segment = rsp$link;
temp1$ptr.segment,temp2$ptr.segment = rsp$link; /* init pointers */
ccb$ptr.offset = sd.ccb ;
/* CCB 0 is first in the table */
lomark = 0;
do while ccb.pc <> cnsnum; /* Find first ccb in list that*/
ccb$ptr.offset = ccb$ptr.offset + size(ccb); /* belongs to this PIN */
end;
lomark = ccb.vc; /* First virtual for this PIN */
/* All of its virtuals are */
/* linked thru ccb link field.*/
himark = 1; /* Find out how many virtual */
do while ccb.link <> 0; /* consoles this PIN needs to */
himark = himark + 1; /* manage (himark). */
ccb$ptr.offset = ccb.link;
end;
ccb$ptr.offset = sd.ccb + (lomark * size(ccb)); /* Reset ccb pointer */
pd$pointer = mon4(m$getpd, 0);
screen = lomark; /* initial foreground console */
cns = ccb.pc; /* Hi byte = pc, Lo byte = vc. */
cns = shl(cns,8) + ccb.vc; /* This is the initial device parameter*/
/* for the XIOS call to switch */
do forever;
call conin;
if char$type = ct$switch then
call switch;
else if (char$type and 1) <> 0 then
call write$vinq(cword);
else
do;
if raw then
call write$vinq(cword);
else
do;
if controlS$has$been$pressed then
do;
if char = ctrlC then
call controlC;
else if char = ctrlQ then
call controlQ;
else if char = ctrlP then
call controlP;
else
do;
call set$conout$flag(ccb$pointer); /* guard against unlikely */
call pxios1(mx$conout,bell,ccb.vc); /* race condition */
call reset$conout$flag(ccb$pointer);
end;
end;
else
do; /* controlS has not been pressed */
if char = ctrlC then
call controlC;
else if char = ctrlS then
call controlS;
else if char = ctrlO then
call controlO;
else if char = ctrlP then
call controlP;
else
do;
if (ccb.state and csm$ctrlO) <> 0 then
call turn$off$ctrlO;
call write$vinq(cword);
end;
end;
end;/* else (if not raw) */
end; /* if char$type <> ct$data and char$type <> ct$switch then */
/* XIOS console input is ignored */
end; /* do forever */
end plmstart;
end pin;


52
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/PROCES.LIT Normal file
View File

@@ -0,0 +1,52 @@
/*
Proces Literals MP/M-8086 II
*/
declare pnamsiz literally '8';
declare pd$hdr literally 'structure
(link word,thread word,stat byte,prior byte,flag word,
name (8) byte,uda word,dsk byte,user byte,ldsk byte,luser byte,
mem word';
/* NDA field added for network 12/7/83 RBB */
declare pd$structure literally 'pd$hdr,
dvract word,wait word,nda$para word,parent word,
cns byte,abort byte,conmode word,lst byte,sf3 byte,ps_flag word,
reservd (4) byte,pret word,scratch word)';
declare psrun lit '00',
pspoll lit '01',
psdelay lit '02',
psswap lit '03',
psterm lit '04',
pssleep lit '05',
psdq lit '06',
psnq lit '07',
psflagwait lit '08',
psciowait lit '09';
declare pf$sys lit '00001h',
pf$keep lit '00002h',
pf$kernal lit '00004h',
pf$pure lit '00008h',
pf$table lit '00010h',
pf$resource lit '00020h',
pf$raw lit '00040h',
pf$ctlc lit '00080h',
pf$active lit '00100h',
pf$tempkeep lit '00200h',
pf$ctld lit '00400h',
pf$childabort lit '00800h',
pf$noctls lit '01000h';
declare pcm$11 lit '00001h',
pcm$ctls lit '00002h',
pcm$rout lit '00004h',
pcm$ctlc lit '00008h',
pcm$ctlo lit '00080h',
pcm$rsx lit '00300h';
declare psf_suspend lit '00001h';


51
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/PXIOS.A86 Normal file
View File

@@ -0,0 +1,51 @@
; Interface to call Physical XIOS
; From a process not in the O.S.
; code reentrant, separate data areas per process
; used by VOUT and PIN RSPs
name pxios
cgroup group code
dgroup group dats
assume cs:cgroup
assume ds:dgroup
dats segment public 'DATA'
extrn rsplink:word ;segment of SYSDAT
extrn udaseg:word ;UDA must be in ES for XIOS call
extrn u_retseg:word, u_wrkseg:word, u_insys:byte
dats ends
code segment public 'CODE'
public pxios1, pxios2, pxios3, pxios4
xiosmod equ 28h
p_uda equ 10h
rlr equ 68h
pxios2 equ pxios1
pxios3 equ pxios1
pxios4 equ pxios1
pxios1 proc
push bp
mov bp,sp
mov ax,[bp+8] ;set up registers
mov cx,[bp+6]
mov dx,[bp+4]
push ds
mov ds,rsplink ;SYSDAT
mov si,ds:word ptr rlr ;ready list root
mov es,[p_uda+si] ;UDA
call ds:dword ptr [xiosmod]
pop ds
pop bp
ret 6
pxios1 endp
code ends
end


38
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/QD.LIT Normal file
View File

@@ -0,0 +1,38 @@
/* Queue Descriptor */
dcl qnamsiz lit '8';
dcl qd$structure lit 'structure(
link word,
net byte,
org byte,
flags word,
name(qnamsiz) byte,
msglen word,
nmsgs word,
dq word,
nq word,
msgcnt word,
msgout word,
buffer word)';
/* queue flag values */
dcl qf$mx lit '001h'; /* Mutual Exclusion */
dcl qf$keep lit '002h'; /* NO DELETE */
dcl qf$hide lit '004h'; /* Not User writable */
dcl qf$rsp lit '008h'; /* rsp queue */
dcl qf$table lit '010h'; /* from qd table */
dcl qf$rpl lit '020h'; /* rpl queue */
dcl qf$dev lit '040h'; /* device queue */
/* Queue Parameter Block */
dcl qpb$structure lit 'structure(
flgs byte,
net byte,
qaddr word,
nmsgs word,
buffptr word,
name (qnamsiz) byte )';


114
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/RHPIN.A86 Normal file
View File

@@ -0,0 +1,114 @@
; Code and Data Interface for PIN RSP
; Virtual console support for Concurrent CP/M
; March 30, 1982
name rpin
cgroup group code
dgroup group dats
assume cs:cgroup,ds:dgroup
public xdos,mon1,mon2,mon3,mon4,intsys
public rsplink, pd, ncopies, udaseg
public u_retseg, u_wrkseg, u_insys
extrn plmstart:near
dats segment public 'DATA'
org 0
rlr equ 68h ;ready list root
p_uda equ 10h ;UDA in process descriptor
supervisor equ 0 ;supervisor entry point for internal
nvcns equ 47h
npcns equ 9fh ; XIOS # physical consoles
rsphdr_len equ 16
pd_len equ 30H
uda_len equ 100H
insysoff equ 60H
rsp_top equ 0
rsp_pd equ rsp_top + rsphdr_len
rsp_uda equ rsp_pd + pd_len
rsp_bottom equ rsp_uda + uda_len
org rsp_top
;RSP header
rsplink dw 0 ;becomes system data page paragraph
sdatvar dw npcns ;Tell Gensys to make 1 for each phys. cons.
ncopies db 0
dw 0,0,0,0, 0
db 0
org rsp_pd
pd dw 0,0 ;link fields
db 0 ;status
db 185 ;initial priority better than TMP - worse than
;VOUT
dw 3 ;flags - system and keep
db 'PIN ' ;name
udaseg dw rsp_uda/10h ;uda paragraph
db 0,0 ;disk,user
db 0,0 ;ldisk,luser
dw 0ffh ;puremem - re-entrant
;rest of pd
org rsp_uda ;start of uda
uda dw 0
dw 0 ;no default DMA
dw 0,0,0,0, 0,0,0,0, 0,0,0,0
dw 0,0,0,0, 0,0,0,0, 0,0,0,0
dw offset stk_top
dw 0,0,0,0, 0,0,0,0
u_wrkseg dw 0
u_retseg dw 0
org rsp_uda + insysoff
u_insys db 1
db 0 ;u_stat_save
dw 0 ;ccb
dw 0 ;lcb
db 0 ;print string delimiter
db 93h dup (0cch) ;fill rest of UDA stack with INT3s
stk_top dw plmstart
dw 0,0 ;segment, flags: unknown
dats ends
code segment public 'CODE'
xdos proc
push bp
mov bp,sp
mov dx,[bp+4]
mov cx,[bp+6]
int 224
pop bp
ret 4
xdos endp
intsys proc ;call O.S. as if we are
push bp ;already in it
mov bp,sp
mov bx,[bp+4]
mov dx,[bp+6]
mov cx,[bp+8]
push ds
mov ds,rsplink ;DS = Sysdat Segment
mov si,ds:word ptr rlr
mov es,[si+p_uda]
call ds:dword ptr [supervisor]
pop ds
pop bp
ret 6
intsys endp
mon1 equ xdos
mon2 equ xdos
mon3 equ xdos
mon4 equ xdos
code ends
end


119
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/RHVOUT.A86 Normal file
View File

@@ -0,0 +1,119 @@
; Code and Data Interface for VOUT RSP
; (for virtual console support)
; March 30, 1983
name rvout
cgroup group code
dgroup group dats
assume cs:cgroup,ds:dgroup
public xdos,mon1,mon2,mon3,mon4,intsys
public rsplink,pd,udaseg,u_retseg,u_wrkseg
public u_insys, ncopies
extrn plmstart:near
dats segment public 'DATA'
org 0
rsphdr_len equ 16
pd_len equ 30H
uda_len equ 100H
insysoff equ 60H
rsp_top equ 0
rsp_pd equ rsp_top + rsphdr_len
rsp_uda equ rsp_pd + pd_len
rsp_bottom equ rsp_uda + uda_len
org rsp_top
;RSP header
rsplink dw 0 ;becomes system data page paragraph
sdatvar dw nvcns ;gensys makes a copy per virtual cons
ncopies db 0
dw 0,0,0,0, 0
db 0
org rsp_pd
pd dw 0,0 ;link fields
db 0 ;status
db 180 ;initial priority - better than TMPs and PIN
dw 3 ;flags - system and keep
db 'VOUT ' ;name
udaseg dw rsp_uda/10h ;uda paragraph
db 0,0 ;disk,user
db 0,0 ;ldisk,luser
dw 0ffh ;puremem - re-entrant
;rest of pd
org rsp_uda ;start of uda
uda dw 0
dw 0 ;init DMA, must be set by program
dw 0,0,0,0, 0,0,0,0, 0,0,0,0
dw 0,0,0,0, 0,0,0,0, 0,0,0,0
dw offset stk_top
dw 0,0,0,0, 0,0,0,0
u_wrkseg dw 0
u_retseg dw 0
org rsp_uda + insysoff
u_insys db 1
db 0 ;status save
dw 0 ;ccb
dw 0 ;lcb
db 0 ;delimiter for print string
db 93h dup (0cch) ;fill UDA stack with INT 3s
stk_top dw plmstart
dw 0,0 ;segment and flags - unknown
dats ends
code segment public 'CODE'
db 'COPYRIGHT (C) 1983,'
db ' DIGITAL RESEARCH '
xdos proc
push bp
mov bp,sp
mov dx,[bp+4]
mov cx,[bp+6]
int 224
pop bp
ret 4
xdos endp
mon1 equ xdos
mon2 equ xdos
mon3 equ xdos
mon4 equ xdos
supervisor equ 0
rlr equ 68h
p_uda equ 10h
nvcns equ 47h
intsys proc ;call O.S. as if we are
push bp ;already in it
mov bp,sp
mov bx, [bp+4]
mov dx, [bp+6]
mov cx, [bp+8]
push ds
mov ds, rsplink ;DS = Sysdat Segment
mov si, ds:word ptr rlr
mov es, [si + p_uda]
call ds:dword ptr [supervisor]
pop ds
pop bp
ret 6
intsys endp
code ends
end


67
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/SD.LIT Normal file
View File

@@ -0,0 +1,67 @@
/* System Data Page */
dcl sysdat$pointer pointer;
dcl sysdat$ptr structure(
offset word,
segment word) at (@sysdat$pointer);
declare sd based sysdat$pointer structure (
supmod (4) word,
/* rtmmod (4) word,
memmod (4) word,
ciomod (4) word,
bdosmod (4) word,
xiosmod (4) word,
netmod (4) word,
reservd (4) word */
space1(28) word,
mpmseg word,
rspseg word,
endseg word,
module$map byte,
ncns byte,
nlst byte,
nccb byte,
nflags byte,
srchdisk byte,
mmp word,
nslaves byte,
dayfile byte,
tempdisk byte,
tickspersec byte,
lul word,
ccb word,
flags word,
mdul word,
mfl word,
pul word,
qul word,
qmau (4) word,
rlr word,
dlr word,
drl word,
plr word,
slr word,
thrdrt word,
qlr word,
mal word,
version word,
vernum word,
mpmvernum word,
tod_day word,
tod (3) byte,
ncondev byte,
nlstdev byte,
nciodev byte,
lcb word,
openvec word,
lockmax byte,
openmax byte,
space2 (2) word,
cmod byte );
declare sd$byte based sysdat$pointer (1) byte;
dcl ncondev lit '83h',
nlstdev lit '84h',
nciodev lit '85h';


73
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/SDPIN.LIT Normal file
View File

@@ -0,0 +1,73 @@
/* System Data Page */
dcl sysdat$pointer pointer;
dcl sysdat$ptr structure(
offset word,
segment word) at (@sysdat$pointer);
declare sd based sysdat$pointer structure (
supmod (4) word,
/* rtmmod (4) word,
memmod (4) word,
ciomod (4) word,
bdosmod (4) word,
xiosmod (4) word,
netmod (4) word,
reservd (4) word */
space1(28) word,
mpmseg word,
rspseg word,
endseg word,
module$map byte,
ncns byte,
nlst byte,
nccb byte,
nflags byte,
srchdisk byte,
mmp word,
nslaves byte,
dayfile byte,
tempdisk byte,
tickspersec byte,
lul word,
ccb word,
flags word,
mdul word,
mfl word,
pul word,
qul word,
qmau (4) word,
rlr word,
dlr word,
drl word,
plr word,
slr word,
thrdrt word,
qlr word,
mal word,
version word,
vernum word,
mpmvernum word,
tod_day word,
tod (3) byte,
ncondev byte,
nlstdev byte,
nciodev byte,
lcb word,
openvec word,
lockmax byte,
openmax byte,
space2 (2) word,
cmod byte ,
space3 (11) word,
space4 byte,
splr word );
declare sd$byte based sysdat$pointer (1) byte;
dcl ncondev lit '83h',
nlstdev lit '84h',
nciodev lit '85h',
readylst lit '68h',
dsptchlst lit '6ch',
susplst lit '0a8h';


635
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/TMP.A86 Normal file
View File

@@ -0,0 +1,635 @@
;*****************************************************
;*
;* Terminal Message Processor
;*
;* The TMP determines the user interface to CCP/M.
;* Much of the interface is available though
;* system calls. This TMP takes advantage of
;* as much as possible for simplicity. The TMP
;* could, for instance, be easily modified to
;* force logins and have non-standard defaults.
;*
;* With a little more work, the TMP could do all
;* command parsing and File Loading instead of
;* using the CLI COMMAND FUNCTION.
;* Suggestions are given in the CCP/M-86 SYSTEM'S GUIDE.
;*
;*****************************************************
title 'Terminal Message Processor - CCP/M-86 3.1'
; Some common equates
true equ 0ffh
false equ 0
cr equ 13 ; carraige return
lf equ 10 ; linefeed
tab equ 9 ; tab char
; CCP/M-86 system functions used by the TMP
osint equ 224 ; interrupt number for CCP/M
; system calls
c_write equ 2 ; console functions
c_writebuf equ 9
c_readbuf equ 10
c_attachc equ 146
c_detachc equ 147
c_setnum equ 148
l_setnum equ 160 ; list device functions
l_getnum equ 164
f_open equ 15 ; file functions
f_close equ 16
f_read equ 20
f_setdma equ 26
f_parse equ 152
drv_set equ 14 ; drive functions
drv_get equ 25
drv_free equ 39
dir_usernum equ 32 ; directory functions
p_cli equ 150 ; process control functions
; Process descriptor flags
ps_run equ 00 ; on ready list root
pf_sys equ 001h ; system process
pf_keep equ 002h ; do not terminate
; Some locations in the system data segment
s_ccpmseg equ word ptr 40H ;begin CCPM segment
s_sysdisk equ byte ptr 04bh ;system disk
s_ncns equ byte ptr 47H ;sys. consoles
s_version equ word ptr 78h ;ofst ver. str in SUP
; Some RSP format equates
rsp_top equ 0
rsp_md equ 008h
rsp_pd equ 010h
rsp_uda equ 040h
rsp_bottom equ 140h
; Error codes returned by the CLI
e_no_memory equ 3 ; cant find memory
e_no_pd equ 12 ; no free pd's
e_q_full equ 15 ; full queue
e_illdisk equ 23 ; illegal disk #
e_badfname equ 24 ; illegal filename
e_badftype equ 25 ; illegal filetype
e_bad_load equ 28 ; bad ret. from BDOS load
e_bad_read equ 29 ; bad ret. from BDOS read
e_bad_open equ 30 ; bad ret. from BDOS open
e_nullcmd equ 31 ; null command sent
e_ill_lst equ 37 ; illegal list device
e_ill_passwd equ 38 ; illegal password
e_abort equ 40 ; aborted in CLI
;*****************************************************
;*
;* TMP Shared Code and Constant Area
;*
;*****************************************************
cseg
org 0
jmps tmp
db 'COPYRIGHT (c) 1983,1984 DIGITAL RESEARCH 2/28/84. '
;===
tmp: ; PROGRAM MAIN - INITIALIZATION
;===
; Set default console # = TMP#
mov dl,defconsole ! call setconsolenum
; Set default disk = system drive
push ds ! mov ds,sysdatseg
mov dl,.s_sysdisk ! pop ds ;get system drive from
call setdisk ;system data segment
xor dl,dl ;all TMPs come up user 0
call setuser
call attach ;print version
push ds ! mov ds,sysdatseg
mov dx,.s_version
mov ds,.s_ccpmseg
call print_ds_string ! pop ds
call detach
push ds ! pop es
mov si,offset pd_ascii_num
mov di,offset startupnum
mov cx,3
rep movsb
mov dx,offset fcb
mov cl,f_open ;try to open the startup file
call ccpm ;on default drive which is
cmp al,0ffh ;the system drive
je nostartup
mov dx,offset clicb_cmd ;use the CLI buffer for this
mov cl,f_setdma ;one time one sector read
call ccpm
mov dx,offset fcb
mov cl,f_read
call ccpm
push ax
mov dx,offset fcb
mov cl,f_close
call ccpm
pop ax
test al,al
jnz nostartup
mov ax,ds
mov es,ax
mov al,cr
mov cx,128
mov di,offset clicb_cmd
repne scasb
jne nostartup ;didn't find a carriage return
inc di ;include cr lf in line
mov byte ptr [di],'$'
sub di,offset clicb_cmd
mov ax,di
sub ax, 2
mov read_blen, al
mov dx,offset supmsg
call printstring
mov dx,offset clicb_cmd
call print_ds_string
jmps startup
nostartup:
; THIS IS WHERE A LOGIN ROUTINE MIGHT
; BE IMPLEMENTED. THE DATA FILE THAT
; CONTAINS THE USER NAME AND PASSWORD
; MIGHT ALSO CONTAIN AN INITIAL DEFAULT
; DISK AND USER NUMBER FOR THAT USER.
;===========
nextcommand: ; LOOP FOREVER
;===========
; free drive
mov dx,0ffffh ! call drive_free
; attach console
call attach
; print CR,LF if we just sent command
cmp cmdsent,false ! je noclearline
mov cmdsent,false
call crlf
noclearline:
; set up and print user prompt
; get current default user # and disk
; this call should be made on every
; loop in case the last command
; has changed the default.
mov dl,cr ! call prchar
call getuser
test bl,bl ! jz nozero ;don't print user 0 prompt
mov dl,bl ! call prnum
nozero:
call getdisk
mov dl,'A' ! add dl,bl
call prchar
mov dx,offset prompt
call print_string
; Read Command from Console
mov dx,offset read_buf ! call conreadbuf
startup:
; echo newline
mov dl,lf ! call prchar
; make sure not a null command
lea bx,clicb_cmd
cmp read_blen,0 ! je gonextcmd
deblank:
cmp byte ptr [bx],' ' ! je zapblank
cmp byte ptr [bx],tab ! jne noblanks
zapblank:
inc bx ! dec read_blen ! jmps deblank
noblanks:
lea ax,clicb_cmd ! cmp ax,bx ! je chksemi
; remove leading blanks
push ds ! pop es ! xor ch,ch ! mov cl,read_blen
mov di,ax ! mov si,bx ! cld ! rep movsb
mov bx,ax
chksemi: ; see if line starts with semicolon
cmp byte ptr [bx],';' ! je gonextcmd
; see if disk change
; if 'X:' change def disk to X
cmp read_blen,2 ! jne chk_dsk
cmp byte ptr 1[bx],':'
jne clicall
jmps chg_dsk
chk_dsk: cmp read_blen,3 ! jne clicall ; allow 'X :' from submit
cmp byte ptr 1[bx],' '
jne clicall
cmp byte ptr 2[bx],':'
jne clicall
chg_dsk: ; change default disk
mov dl,[bx] ;get disk name
and dl,5fh ;Upper Case
sub dl,'A' ;disk number
; check bounds
cmp dl,0 ! jb baddrive
cmp dl,15 ! ja baddrive
; select default disk
call setdisk ! jmp gonextcmd
baddrive: mov dx,offset errstr ! call printstring
mov dx,offset drverr ! call printstring ! call crlf
gonextcmd: jmp nextcommand
;=======
clicall: ; SEND CLI COMMAND
;=======
; put null at end of input
mov bx,offset clicb_cmd
mov al,read_blen ! mov ah,0
add bx,ax ! mov byte ptr [bx],0
; copy command string for error
; reporting later and to check
; for built in commands...
mov cx,64
mov si,offset clicb_cmd
mov di,offset savebuf
push ds ! pop es
rep movsw
; parse front to see if
; built in command
mov si,offset fcb
mov di,offset savebuf
call parsefilename
jcxz goodparse
sub bx,bx ! mov bl,read_blen
add bx,offset savebuf
mov byte ptr [bx],'$'
jmp clierror
goodparse: mov parseret,bx
cmp bx,0 ! jne haveatail
mov bl,read_blen
add bx,offset savebuf
haveatail: mov byte ptr [bx],'$' ! inc bx
cmp fcb,0 ! je try_builtin
jmp not_builtin
; is it USER command?
try_builtin: mov si,offset fcb ! inc si
mov di,offset usercmd
push cs ! pop es
mov cx,4 ! repz cmpsw
jnz notuser
mov si,offset fcb
mov di,parseret
cmp di,0 ! je pruser
inc di
call parsefilename
cmp cx,0 ! jne pruser
mov si,offset fcb
inc si
mov dx,[si]
call a_to_b
cmp bl,15 ! ja usererr
mov dl,bl
call setuser
jmp pruser
usererr: mov dx,offset usererrmsg
call printstring
pruser: mov dx,offset usermsg
call printstring
call getuser
mov dl,bl ! call prnum
call crlf
jmp nextcommand
notuser:
mov si,offset fcb ! inc si
mov di,offset printercmd
push cs ! pop es
mov cx,4 ! repz cmpsw
jnz notprinter
mov si,offset fcb
mov di,parseret
cmp di,0 ! je prprinter
inc di
call parsefilename
cmp cx,0 ! jne prprinter
mov si,offset fcb
inc si
mov dx,[si]
call a_to_b
cmp bl,0ffh
je printererr
mov dl,bl
call setlist
jcxz prprinter
printererr: mov dx,offset printemsg
call printstring
prprinter: mov dx,offset printermsg
call printstring
call getlist
mov dl,bl ! call prnum
call crlf
jmp nextcommand
notprinter:
not_builtin:
; initialize Cli Control Block
mov clicb_net,0
; make cli call
mov cmdsent,true
lea dx,clicb ! mov cl,p_cli
call ccpm
cmp bx,0 ! jne clierror
jmp nextcommand
;========
clierror:
;========
; Cli call unsuccesful, analyze and display err msg
; input: CX = ERROR CODE
mov si,(offset clierrtab)-4
nexterr:
add si,4
cmp cs:word ptr [si],0ffffh ! je unknownerr
cmp cx,cs:[si] ! jne nexterr
unknownerr:
mov dx,cs:2[si]
; jmps showerr
showerr: ; Print Error String
;------- ; input: DX = address of Error
; string in CSEG
; if DX=0 then NULL COMMAND
cmp dx,0 ! jne perr
mov cmdsent,false ! jmp nextcommand
perr: push dx ! call crlf
mov dx,offset errstr ! call printstring
pop dx ! call printstring ! call crlf
mov dx,offset cmdstr ! call printstring
mov dx,offset savebuf ! call print_ds_string ! call crlf
jmp nextcommand
parsefilename: ; SI = fcb DI = string
mov cx,f_parse
mov bx,offset pcb
mov [bx],di ! mov 2[bx],si
mov dx,bx ! jmp ccpm
a_to_b: ;dl = 1st char, dh = 2nd char
cmp dh,' ' ! jne atob2char
mov dh,dl ! mov dl,'0'
atob2char: cmp dh,'0' ! jb atoberr
cmp dh,'9' ! ja atoberr
cmp dl,'0' ! jb atoberr
cmp dl,'9' ! ja atoberr
sub dh,'0' ! sub dl,'0'
mov ax,0 ! mov al,dl
push dx ! mov cl,10
mul cl ! pop dx
mov dl,dh ! mov dh,0
add ax,dx
mov bx,ax ! ret
atoberr: mov bl,0ffh ! ret
prnum: ; dl = num (0-15)
cmp dl,10 ! jb prnum_one
push dx
mov dl,'1' ! call prchar
pop dx ! sub dl,10
prnum_one: add dl,'0'
; jmp prchar
prchar: mov cl,c_write ! jmp ccpm
getuser: mov dl,0ffh
setuser: mov cl,dir_usernum ! jmp ccpm
crlf: mov dx,offset crlfstr
;jmps printstring
printstring: push ds ! mov ax,cs ! mov ds,ax
call print_ds_string ! pop ds ! ret
print_ds_string:mov cl,c_writebuf ! jmps ccpm
setconsolenum: mov cl,c_setnum ! jmps ccpm
setdisk: mov cl,drv_set ! jmps ccpm
getdisk: mov cl,drv_get ! jmps ccpm
setlist: mov cl,l_setnum ! jmps ccpm
getlist: mov cl,l_getnum ! jmps ccpm
attach: mov cl,c_attachc ! jmps ccpm
detach: mov cl,c_detachc ! jmps ccpm
con_readbuf: mov cl,c_readbuf ! jmps ccpm
drivefree: mov cl,drv_free !; jmps ccpm
;====
ccpm: ; INTERFACE ROUTINE FOR SYSTEM ENTRY POINTS
;====
int osint ! ret
;*****************************************************
;*
;* CONSTANTS (IN SHARED CODE SEGMENT)
;*
;*****************************************************
clierrtab dw e_nullcmd, 0 ;null command
dw e_no_memory, memerr ;No memory
dw e_no_pd, pderr ;No unused PD
dw e_badfname, fnameerr;Ill. command
dw e_illdisk, fnameerr;Ill. disk
dw e_ill_passwd, fnameerr;Ill. password
dw e_badftype, fnameerr;Ill. type
dw e_bad_load, loaderr ;
dw e_bad_read, loaderr ;
dw e_bad_open, openerr ;
dw e_q_full, qfullerr;
dw e_abort, aborterr;
; a few extra entries for future errors
dw 0ffffh, catcherr;
dw 0ffffh, catcherr;
dw 0ffffh, catcherr;
dw 0ffffh, catcherr;
prompt db '>$'
crlfstr db 13,10,'$'
errstr db 'CP/M Error: $'
memerr db 'Not Enough Memory$'
pderr db 'PD Table Full$'
fnameerr db 'Bad File Spec$'
catcherr rb 0 ;Unknown Errs give
loaderr db 'Load Error$' ; Load Error Msg
openerr db 'Can''t Find Command$'
qfullerr db 'RSP Command Que Full$'
aborterr db 'CLI Abort$'
drverr db 'Invalid Drive$'
cmdstr db 'Command = $'
usererrmsg db 13,10,'Invalid User Number,'
db ' IGNORED',13,10,'$'
usermsg db 13,10,'User Number = $'
printemsg db 13,10,'Invalid Printer Number,'
db ' IGNORED',13,10,'$'
printermsg db 13,10,'Printer Number = $'
usercmd db 'USER '
printercmd db 'PRINTER '
supmsg db 'Start up command: $'
;*****************************************************
;*
;* TMP Data Area - this area is copied once for
;* each system console. The 'defconsole'
;* field is unique for each copy
;* - Each Data Area is run by a common
;* shared code segment.
;*
;*****************************************************
DSEG
org rsp_top
sysdatseg dw 0
sdatvar dw s_ncns
defconsole db 0,0
dw 0,0,0,0,0
org rsp_pd
pd dw 0,0 ; link fields
db ps_run ; status
db 198 ; priority
dw pf_sys+pf_keep ; flags
db 'Tmp' ; Name
pd_ascii_num db ' ' ; Ascii number field set by GENSYS
dw offset uda/10h ; uda seg
db 0,0 ; disk,user
db 0,0 ; ldisk,luser
dw 0ffffh ; mem
dw 0,0 ; dvract,wait
db 0,0 ; org,net
dw 0 ; parent
db 0,0 ; cns,abort
db 0,0 ; cin,cout
db 0,0 ; lst,sf3
db 0,0 ; sf4,sf5
dw 0,0 ; reserved
dw 0,0 ; pret,scratch
org rsp_uda
uda dw 0,0,0,0 ;0-7 note: no default DMA
dw 0,0,0,0 ;8-fh
dw 0,0,0,0 ;10-17
dw 0,0,0,0 ;18-1f
dw 0,0,0,0 ;20-27
dw 0,0,0,0 ;28-2f
dw 0,0,offset stack_top,0 ;30-37
dw 0,0,0,0 ;38-3f
dw 0,0,0,0 ;40-47
dw 0,0,0,0 ;48-4f
dw 0,0,0,0 ;50-57
dw 0,0,0,0 ;58-5f
db 1 ;60 INSYS <> 0
;don't switch from
;from UDA stack
;on entry to SUP
db 0 ;61
dw 0,0 ;62-64
db 0 ;66
dw 0 ;67-68
db 0 ;69
dw 0cccch,0cccch,0cccch ;6A-6F
dw 0cccch,0cccch,0cccch,0cccch ;70
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;80
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;90
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;A0
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;B0
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;C0
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;D0
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;E0
dw 0cccch,0cccch,0cccch,0cccch
dw 0cccch,0cccch,0cccch,0cccch ;F0
dw 0cccch
stack_top dw offset tmp ; code starting point
dw 0 ; code seg - set by GENSYS
dw 0 ; init. flags - set by GENSYS
; UDA is 100H bytes long
maxcmdlen equ 128
; the Read Console Buffer and the
; Cli Control Block share the same memory
read_buf rb 0
read_maxcmd db 128
clicb rb 0
clicb_net rb 0
read_blen rb 1
clicb_cmd rb maxcmdlen + 1
cmdsent db false
parseret dw 0
pcb dw offset savebuf
dw offset fcb
fcb db 0, 'STARTUP '
startupnum db ' '
rb 20
db 0 ;current record
savebuf rb 128
db 0 ;ensure hex is formed
end


27
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/UDA.LIT Normal file
View File

@@ -0,0 +1,27 @@
/* MP/M-86 II User Data Area format - August 8, 1981 */
declare uda$pointer pointer;
declare uda$ptr structure (offset word, segment word) at (@uda$pointer);
declare uda based uda$pointer structure (
dparam word,
dma$ofst word,
dma$seg word,
func byte,
searchl byte,
searcha word,
searchabase word,
dcnt word,
dblk word,
error$mode byte,
mult$cnt byte,
df$password (8) byte,
pd$cnt byte,
uspace1 byte,
uspace2 (8) word,
uspace3 (8) word,
uspace4 (8) word,
uspace5 (8) word,
uspace6 (2) word,
dinsys byte);


81
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/VCCB.LIT Normal file
View File

@@ -0,0 +1,81 @@
/* +---------+---------+---------+---------+
00 | attach | queue |
+---------+---------+---------+---------+
04 | flag | startcol| column | nchar |
+---------+---------+---------+---------+
08 | mimic | msource | pc | vc |
+---------+---------+---------+---------+
0C | btmp | resrvd | state |
+---------+---------+---------+---------+
10 | maxbufsiz | vinq |
+---------+---------+---------+---------+
14 | voutq | vcmxq |
+---------+---------+---------+---------+
18 | qpbflgs | qpbfill | qpbqaddr |
+---------+---------+---------+---------+
1C | qpbnmsgs | qpbbuffptr |
+---------+---------+---------+---------+
20 | qbuff | cosleep |
+---------+---------+---------+---------+
24 | usleep | vsleep |
+---------+---------+---------+---------+
28 | ... reserved ... |
+---------+---------+---------+---------+
*/
dcl ccb$structure lit 'structure (attach address, queue address,
flag byte, startcol byte, column byte, nchar byte, mimic byte, msource byte,
ccb$tail1';
dcl ccb$tail1 lit
'pc byte, vc byte, btmp byte, reservd byte, state word, maxbufsiz word,
ccb$tail2';
dcl ccb$tail2 lit
'vinq address, voutq address, vcmxq address,
qpbflags byte, qpbresrvd byte, qpbqaddr address,
qpbnmsgs address, qpbbuffptr address, qbuff address, cosleep word,
usleep word, vsleep word, link word, r2 word)';
declare /* flag values */
cf$listcp lit '001h', /* control P toggle */
cf$compc lit '002h', /* suppress output */
cf$switchs lit '004h', /* XIOS supports switch screening */
cf$conout lit '008h', /* XIOS console output ownership */
cf$vout lit '010h', /* process writing to VOUTQ */
cf$bufp lit '020h'; /* toggle to control printer echo */
/* on control P when background */
/* and buffered */
/* values of state byte */
/* conout goes to XIOS */
/* state word flags */
dcl
csm$buffered lit '0001h',
csm$background lit '0002h',
csm$purging lit '0004h',
csm$noswitch lit '0008h',
csm$suspend lit '0010h',
csm$abort lit '0020h',
csm$filefull lit '0040h',
csm$ctrlS lit '0080h',
csm$ctrlO lit '0100h',
csm$ctrlP lit '0200h';
dcl x$init$offset lit '0Ch',
x$init$pointer pointer,
x$init$ptr structure (offset word, segment word) at (@x$init$pointer),
x$init based x$init$pointer structure
(tick byte, ticks$sec byte, door byte, resrvd1 (2) byte,
nvcns byte, nccb byte, nlst byte, ccb word, lcb word);
dcl lcb$structure lit 'structure (attach address, queue address,
flag byte, startcol byte, column byte, nchar byte,
mimic byte, msource byte)';


20
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/VOUT.CSD Normal file
View File

@@ -0,0 +1,20 @@
;
; This sub file compiles, links and generates in hex the VOUT rsp
; for Concurrent CP/M version 3.1
; It is meant for use under UDI.
;
; After the last step in this file, do:
; GENCMD VOUT DATA[B1000]
; REN VOUT.RSP=VOUT.CMD
;
asm86 rhvout.a86
asm86 pxios.a86
plm86 vout.p86 xref debug optimize(3)
link86 rhvout.obj, pxios.obj, vout.obj to rhvout.lnk
rename rhvout.lnk to vout.lnk
loc86 vout.lnk od(sm(code,dats,data,const,stack)) &
ad(sm(code(0),dats(10000h))) ss(stack(0)) to vout.dat
oh86 vout.dat
rename vout.hex to vout.h86


492
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 3.1 SOURCE/D3/VOUT.P86 Normal file
View File

@@ -0,0 +1,492 @@
$title('VOUT.RSP - virtual console disk write')
$set(debug=0)
$compact
vout:
do;
/* Disk output process. Reads Virtual OUTput Queue (VOUTQ) associated
with a virtual console in buffered background mode. Output is spooled
to the file VOUTX.$$$. When console is in foreground purge mode, spooled
output is read from this file and dumped on the screen. There is one
copy of the VOUT process per virtual console. Each VOUT RSP has
its own data area, but the code is reentrant for all the VOUT RSPs.
*/
/* VAX commands used to generate VOUT.RSP
asm86 rvout.a86
plm86 vout.plm optimize(3) debug 'p1' 'p2' 'p3'
link86 rvout.obj, pxios.obj, vout.obj to vout.lnk
loc86 vout.lnk od(sm(code,dats,data,const,stack)) -
ad(sm(code(0))) ss(stack(0))
h86 vout.dat
refmt vout.mp2 vout.2
ren vout.2 vout.mp2
the hex is uploaded to a micro to make a binary file using the command:
gencmd vout data[bxxx]
xxx is taken from the VOUT.MP2 file generated on the VAX by LOC86.
xxx is the next paragraph after the CODE segment.
*/
$include (copyrt.lit)
$include (comlit.lit)
$include (qd.lit)
$include (mfunc.lit)
$include (mxfunc.lit)
$include (fcb.lit)
dcl name$len lit '4'; /* number of letters in RSP name: 'VOUT' */
dcl fcblen lit '36';
dcl rsplink word external; /* set to SYSDAT by O.S. initialization */
dcl udaseg word external; /* DS for this process */
dcl ncopies byte external;
dcl copynum byte at (.ncopies); /* VOUT process copy number, also the */
/* virtual console number for console */
/* output to the XIOS */
$include (sd.lit)
dcl ccb$pointer pointer;
dcl ccb$ptr structure ( offset address, segment address) at
(@ccb$pointer);
$include (vccb.lit)
dcl ccb based ccb$pointer ccb$structure;
dcl data$msg lit '0';
dcl wake$msg lit '0ffh';
dcl voutq$msg structure (
dayta byte, type byte);
mon1: procedure (func,a) external;
dcl func byte, a address;
end mon1;
mon2: procedure (func,a) byte external;
dcl func byte, a address;
end mon2;
mon4: procedure (func,a) pointer external;
dcl func byte, a address;
end mon4;
intsys: procedure (cx, dx, bx) external; /* internal O.S. functions */
dcl (cx, dx, bx) word; /* see RVOUT module */
end intsys;
/* special disk output assembly module */
pxios1: procedure (func,p1,p2) external;
dcl func byte, (p1,p2) address; /* XIOS interface for process */
end pxios1; /* not in the O.S. */
dcl ps$ciosleep lit '9';
sleep: procedure(addr);
dcl addr word;
call intsys(mi$sleep, addr, ps$ciosleep);
end sleep;
wakeup: procedure(addr);
dcl addr word;
call intsys(mi$wakeup, addr, 0);
end wakeup;
$if debug=1
/* conditionally compiled error print routines */
print$msg: procedure(endchar, sptr);
dcl (i, endchar) byte, sptr pointer,
string based sptr (1) byte;
i = 0;
do while string(i) <> endchar;
call pxios1(mx$conout, string(i), copynum);
i = i + 1;
end;
end print$msg;
print$hex: procedure (nib);
dcl nib byte;
nib = nib and 0fh;
if nib < 10 then
call pxios1(mx$conout, nib + '0', copynum);
else
call pxios1(mx$conout, nib + 'A' - 10, copynum);
end print$hex;
error: procedure(msgptr);
dcl msgptr pointer;
call print$msg(0, @(cr, lf, '**** VOUT ERROR **** ',0));
call print$msg(0, msgptr);
call print$msg(0, @(', CCB.STATE = ', 0));
call print$hex(shr(ccb.state, 12));
call print$hex(shr(ccb.state, 8));
call print$hex(shr(ccb.state, 4));
call print$hex(ccb.state);
call print$msg(0, @('H', cr, lf, 0));
end error;
$endif
read$change$mxq: procedure;
qpb.qaddr = ccb.vcmxq;
call mon1 (m$readq, .qpb);
end read$change$mxq;
write$change$mxq: procedure;
qpb.qaddr = ccb.vcmxq;
call mon1 (m$writeq, .qpb);
end write$change$mxq;
dcl logeof lit '0ffh';
dcl dump$op lit '0ffh';
dcl writing boolean initial (false);
dcl delete$flag boolean initial (true); /* delete when convienient */
dcl deleted boolean initial (true); /* has been deleted */
dcl file$is$empty boolean initial (true);
dcl rrr address initial(0); /* next random record to read */
dcl wrr address initial(0); /* next random record to write */
delete$file: procedure;
call mon1(m$closef, .fcb); /* force allocation vector */
call mon1(m$deletef, .fcb); /* update */
delete$flag = false;
deleted = true;
end delete$file;
make$file: procedure boolean;
call setb(0, @fcb(f$ex), fcblen-f$ex);
fcb(f$drvusr) = sd.tempdisk + 1; /* try deleting the file in case drive */
call mon1(m$deletef, .fcb); /* was read only when delet$file was */
/* called or tempdisk has changed */
if mon2(m$makef, .fcb) = 0ffh then /* open in locked mode */
return(false); /* error - force open attempt next time */
deleted = false;
return(true);
/* fcb(f$ex) = fcb(f$ex) or 80h; /* make system */
/* call mon1(m$setatt, .fcb); */
end make$file;
reset$file: procedure;
delete$flag, file$is$empty = true;
writing = false; /* force setdma */
wrr, rrr = 0; /* not necessary ? */
end reset$file;
dcl bufsiz lit '128';
dcl in$buf(bufsiz) byte; /* buffer to fill on from reading VOUTQ */
dcl in$ptr word initial (0ffffh); /* initially empty buffer */
dcl purge$buf (buf$siz) byte; /* buffer to use when purging */
dcl purge$ptr word initial (0ffffh);
dcl num$purge$buf$chars word initial (0);
write$buf: procedure boolean;
if deleted then
do;
if not make$file then /* delete and make file */
return(false);
end;
else if rrr = wrr and not file$is$empty then
return(false); /* don't write if we haven't purged it yet */
if not writing then /* we want to be in write mode */
do;
call mon1(m$setdma,.in$buf);
writing = true;
end;
fcb(f$rrec) = low(wrr);
fcb(f$rrec+1) = high(wrr);
if mon2(m$writerf, .fcb) <> 0 then
return(false); /* out of disk space or physical error */
file$is$empty = false;
in$ptr = 0ffffh;
wrr = (wrr + 1) mod (ccb.maxbufsiz * 8); /* next record to write */
return(true);
end write$buf;
read$buf: procedure boolean;
dcl ret boolean;
if file$is$empty then
do;
if not deleted then /* made file but had a write error */
call reset$file;
return(false);
end;
if writing then /* we want to be in read mode */
do;
call mon1(m$setdma, .purge$buf);
writing = false;
end;
fcb(f$rrec) = low(rrr);
fcb(f$rrec+1) = high(rrr);
ret = mon2(m$readrf,.fcb) = 0; /* physical error if false - skips record */
rrr = (rrr + 1) mod (ccb.maxbufsiz * 8);
if rrr = wrr then /* done with file ? */
call reset$file;
return(ret); /* return read status */
end read$buf;
dcl active$msg boolean initial (false);
read$voutq: procedure;
if active$msg then
return;
qpb.qaddr = ccb.voutq;
qpb.buffptr = .voutq$msg;
call mon1(m$readq, .qpb);
if voutq$msg.type = data$msg then
active$msg = true;
end read$voutq;
drain$voutq: procedure(char$adr) boolean;
dcl char$adr address; /* return false if no chars found in */
dcl char based char$adr byte; /* VOUTQ, return true and put char @ */
dcl (have$a$char, qempty) boolean; /* char$adr if there is one */
qpb.qaddr = ccb.voutq;
qpb.buffptr = .voutq$msg;
have$a$char, qempty = false;
do while not have$a$char and not qempty;
if mon2(m$creadq, .qpb) = 0 then /* successful queue read */
have$a$char = voutq$msg.type = data$msg; /* and msg is data */
else
qempty = true;
end;
char = voutq$msg.dayta;
if qempty then
return(false); /* no chars in queue */
return(true); /* char was a data msg */
end drain$voutq;
put$char: procedure boolean;
active$msg = false;
if voutq$msg.type <> data$msg then
return(true);
voutq$msg.type = wake$msg; /* probably garbage */
in$buf(in$ptr := in$ptr + 1) = voutq$msg.dayta;
if in$ptr = buf$siz - 1 then
return(write$buf); /* don't call again no write */
return(true);
end put$char;
get$char: procedure (charadr) boolean;
dcl charadr address, char based charadr byte;
if purge$ptr + 1 = num$purge$buf$chars then
if read$buf then
do;
num$purge$buf$chars = bufsiz;
purge$ptr = 0ffffh;
end;
else if in$ptr <> 0ffffh then /* data in buff but not in file */
do;
call move(in$ptr + 1, .in$buf, .purge$buf);
write$pending = false;
num$purge$buf$chars = in$ptr + 1;
in$ptr, purge$ptr = 0ffffh; /* indicate data in purge$buf */
end;
else if active$msg then
do;
active$msg = false;
char = voutq$msg.dayta;
return(true);
end;
else
do;
if not drain$voutq(char$adr) then /* get chars from VOUTQ */
do;
do while (ccb.flag and cf$vout) <> 0; /* user process is NQing wait */
call mon1(m$delay, 2); /* for q write to finish */
end;
return(drain$voutq(char$adr)); /* now read message, usr proc */
end; /* sleeps because of state */
else
return(true); /* got a char from VOUTQ */
end;
purge$ptr = purge$ptr + 1;
char = purge$buf(purge$ptr);
return (true);
end get$char;
full$disk: procedure; /* arrive when we can't write*/
call read$change$mxq; /* to the disk */
if (ccb.state and csm$purging) = 0 then /* wait for PIN to switch us */
/* to the foreground, */
ccb.state = ccb.state or csm$filefull; /* csm$file$full and csm$pur-*/
/* ging are mutually exclusive*/
call write$change$mxq;
end full$disk;
dcl write$pending boolean initial (false);
buffer: procedure;
if write$pending then
if write$pending := not write$buf then
do;
call full$disk;
return;
end;
do while (ccb.state and not double(csm$ctrlP)) =
csm$buffered + csm$background;
call read$voutq; /* always do something with the */
if write$pending := not putchar then /* character ! */
do;
call full$disk;
return;
end;
end;
end buffer;
dcl purgeok$mask lit '(csm$background or csm$abort or csm$ctrlS)';
purge: procedure;
dcl (char, count) byte;
dcl controlP boolean;
dcl more$in$file boolean;
more$in$file = true;
do while (ccb.state and purgeok$mask) = 0 and
more$in$file;
call read$change$mxq;
controlP = (ccb.state and csm$ctrlP) <> 0;
if (ccb.state and purgeok$mask) = 0 then
do;
disable;
do while (ccb.flag and cf$conout) <> 0;
call sleep(.ccb.cosleep);
end;
ccb.flag = ccb.flag or cf$conout;
enable;
count = 0;
do while more$in$file and count < 40; /* for performance, purge 40 */
if (more$in$file := get$char(.char)) and /* chars before allowing */
(ccb.state and csm$ctrlO) = 0 then /* state to change, 40 is */
do; /* is somewhat arbitrary */
call pxios1(mx$conout, char, copynum);
if controlP then
call pxios1(mx$lstout, char, ccb.mimic);
end;
count = count + 1;
end;
ccb.flag = ccb.flag and not cf$conout;
call write$change$mxq; /* possibly wake up PIN */
call wakeup(.ccb.cosleep); /* or user process */
end;
else
call write$change$mxq;
end;
if not more$in$file then
do;
num$purge$buf$chars = 0;
purge$ptr, inptr = 0ffffh;
call read$change$mxq;
if (ccb.state and csm$purging) <> 0 then
do;
ccb.state = ccb.state and not double(csm$purging ); /* the XIOS call */
call pxios1(mx$upstatus, 0, ccb.pc);
end;
call write$change$mxq;
end;
call wakeup(.ccb.usleep); /* wake up user process */
end purge;
abort: procedure;
dcl junk word;
do while drain$voutq(.junk); /* drain input queue */
end; /* may wake up user process */
call read$change$mxq;
ccb.state = ccb.state and not double(csm$abort);
call write$change$mxq;
call reset$file;
write$pending = false;
purge$ptr, inptr = 0ffffh;
num$purge$buf$chars = 0;
call wakeup(.ccb.usleep); /* wake up user process */
end abort;
initq: procedure(qdaddr) address;
dcl qdaddr address;
dcl ret boolean;
dcl iqd based qdaddr qd$structure;
call move(qnamsiz, .iqd.name, .qpb.name);
ret = mon2(m$makeq, qdaddr); /* 0ffh return = error */
ret = ret or mon2(m$openq, .qpb); /* ret = 0 if no error */
$if debug = 1
if ret then /* if debugging print error */
call error(@('Queue initialization error',0));
$endif
return(qpb.qaddr);
end initq;
dcl pd$pointer pointer; /* in RSP assembly interface */
dcl pd based pd$pointer (1) byte;
dcl pd$name lit '8';
dcl voutq$buf (32) byte;
dcl voutq qd$structure initial
(0,0,0, qf$hide + qf$keep, 'VOUTQ ',2,16,0,0,0,0,.voutq$buf);
dcl vinq$buf (64) word; /* 64 bytes type ahead */
dcl vinq qd$structure initial
(0,0,0, qf$keep + qf$hide, 'VINQ ',2,64,0,0,0,0,.vinq$buf);
dcl vcmxq qd$structure initial
(0,0,0,qf$keep + qf$mx + qf$hide, 'VCMXQ ',0,1,0,0,0,0,0);
dcl qpb qpb$structure;
dcl dummy (1) byte data ('Z'); /* make constant segment non-zero to */
/* hex generation */
dcl fcb(36) byte initial (0,' ', '$$$');
/* initialization */
plmstart: procedure public;
dcl save$state word;
call mon1(m$errmode, 0ffh); /* don't display errors */
ccb$ptr.segment, sysdat$ptr.segment = rsplink;
sysdat$ptr.offset = 0;
ccb$ptr.offset = sd.ccb + copynum * size(ccb);
pd$pointer = mon4(m$getpd,0);
call movb(@pd(pd$name), @fcb(f$name), qnamsiz);
call move(4, .fcb(f$name + name$len), .vinq.name(4));
ccb.vinq = initq(.vinq);
call move(3, .fcb(f$name + name$len), .voutq.name(5));
ccb.voutq = initq(.voutq);
call move(3, .fcb(f$name + name$len), .vcmxq.name(5));
ccb.vcmxq = initq(.vcmxq);
call mon1(m$setcns, copynum); /* copynum is virtual console # */
fcb(f$drvusr) = sd.tempdisk + 1;
call write$change$mxq; /* write initial MX message */
call mon1(m$setprior, 200);
do forever;
if delete$flag then
call delete$file;
if (ccb.state and not double(csm$ctrlP + csm$ctrlO)) =
csm$buffered + csm$background then /* if ctrlO,background and */
call buffer; /* buffered, then sleep */
else if ( (ccb.state and not double(csm$ctrlO + csm$ctrlP))
and csm$purging) <> 0 then
call purge;
else if (ccb.state and csm$abort) <> 0 then
call abort;
if delete$flag then
call delete$file;
else
call read$voutq;
end;
end plmstart;
end vout;