Category : Pascal Source Code
Archive   : STAY50.ZIP
Filename : SRMSGU.PAS
{$I direct.inc}
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ SRMSGU.PAS }
{ }
{ Copyright (C) 1988 L.H.Ferris }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
unit SRMSGU ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
interface
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
type
string8 = string[8] ;
msgptr = pointer ;
Procedure MakeMailbox (pMailboxname : string8) ;
Procedure Send (pMailboxname : string8 ; pmsgptr: pointer ) ;
Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
implementation
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
uses sr50, { StayResident Kernel }
sr50subs ; { StayResident subroutines }
type
msgrecptr = ^msgrec ; { pointer to msgrec in mailbox }
msgrec = record
msgreclink : msgrecptr ; { ptr to next msg in mailbox }
msgprocid : word ; { id of sending process }
msgrecdata : pointer ; { ptr to user data }
end {msgrec} ;
mailboxptr = ^ mailbox ;
mailbox = record
maillink : mailboxptr ;
mailname : string8 ;
mailLock : word ;
mailsendhead : msgrecptr ; { pointer to head of message queue }
mailsendtail : msgrecptr ; { pointer to tail of message queue }
mailwaithead : msgrecptr ; { pointer to head of waiting queue }
mailwaittail : msgrecptr ; { pointer to tail of waiting queue }
end {mailbox} ;
var
f1stMailbox : mailboxptr ; { anchor for first mailbox }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Dummy routines for testing }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
(*************
const
msgwait = 0010 ;
Procedure Suspend(pSRBid : word; msgwait : word) ;
begin end ;
Procedure UnSuspend(pSRBid : word; msgwait:word ) ;
begin end ;
Function Getsrbid : word ;
begin
Getsrbid := 1 ;
end ;
Procedure Yield ;
Begin end;
******************)
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Lock/UnLock }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Loop until exclusive control of a semaphore }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Lock(var Lockword : word ) ;
Begin
Repeat
while Lockword <>0 do ; { spin for available lock }
inc(Lockword) ; { try to get the lock }
if Lockword = 1 then exit { if locked, exit with it }
else dec(Lockword) ; { else, reset lock }
Until false ; { spin for available lock }
End {Lock} ;
Procedure UnLock(var Lockword : word ) ;
Begin
Lockword := 0 ;
End {UnLock} ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Make Mail Box }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Make a mailbox by "Mailboxname" and place on mailbox chain }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure MakeMailbox(pMailboxname : string8) ;
var
mbptr : mailboxptr ;
begin
getmem(mbptr, sizeof(mailbox) );
if mbptr = nil then
errormsg(haltlevel,'MakeMailbox: memory exhausted') ;
mbptr^.mailname := UpperCase(pmailboxname) ;
mbptr^.maillock := 0 ;
mbptr^.mailsendhead := nil ;
mbptr^.mailsendtail := nil ;
mbptr^.mailwaithead := nil ;
mbptr^.mailwaittail := nil ;
SingleTask ;
mbptr^.maillink := f1stMailbox ;
f1stMailbox := mbptr ;
Multitask ;
End {Procedure MakeMailbox} ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ OnWaitList }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Return "true" if this procid is waiting on Receive mailbox chain }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Function OnWaitList( pMailboxptr:mailboxptr ;
pmsgprocid :word ) : boolean ;
var
mbptr : mailboxptr ;
recptr : msgrecptr ;
found : boolean ;
Begin
OnWaitList := false ;
found := false ;
with pMailboxptr^ do begin
if mailwaithead = nil then exit ; { wait list is empty }
recptr := mailwaithead ;
while (recptr <> nil) and (NOT found) do begin
if recptr^.msgprocid = pmsgprocid then begin
found := true ;
OnWaitList := true ;
exit ;
end ;
recptr := recptr^.msgreclink ;
end {while recptr..} ;
end {with pMail...} ;
End { OnWaitList } ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Send }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Enque message ptr on Send (Named) Mailbox chain }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Send( pMailboxname:string8 ; pmsgptr:pointer ) ;
var
mbptr : mailboxptr ;
recptr : msgrecptr ;
found : boolean ;
tid : word ;
begin
tid := GetSRBid ;
mbptr := f1stMailbox ;
found := false ;
while (mbptr <> nil) and (NOT found) do { find named mailbox }
if mbptr^.mailname = UpperCase(pMailboxname)
then found := true
else mbptr := mbptr^.maillink ;
if NOT found then
errormsg(warnlevel,'Send: Mailbox name error: '+pMailboxname) ;
Lock(mbptr^.maillock) ; { get exclusive control of mailbox }
WITH mbptr^ do begin
new(recptr) ;
recptr^.msgrecdata := pmsgptr ; { store ptr to user data }
recptr^.msgprocid := tid ; { store id of sender }
if mailsendhead = nil then { Queue the message ptr }
mailsendhead := recptr
else
mailsendtail^.msgreclink := recptr ;
recptr^.msgreclink := nil ;
mailsendtail := recptr ;
{ Unsuspend first process (which is not this id )waiting for }
{ messages in this mailbox }
if mailwaithead = nil then {nothing} { Nobody waiting for msg }
else begin { Unsuspend waiting tasks }
Recptr := mailwaithead ; { ptr to waiting queue }
mailwaithead := Recptr^.msgreclink ; { ptr to nxt waiting proc }
if mailwaithead = nil { Tail get nil if head is }
then mailwaittail := nil ;
UnSuspend(recptr^.msgprocid,msgwait) ; { remove suspended status }
dispose(Recptr) ; { release chained element }
end {else mailwaithead..} ;
UnLock(maillock) ; { release mailbox control }
end {with mbptr..} ;
End {Procedure Send} ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Receive }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ Receive/wait for message ptr from Receive mailbox chain. }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
var
mbptr : mailboxptr ; { mailbox pointer }
recptr : msgrecptr ; { receive msg ptr }
found : boolean ; { success flag }
tid : word ;
begin
tid := GetSRBid ;
mbptr := f1stMailbox ; { first mainbox pointer }
found := false ;
{ find mailbox by name }
while (mbptr <> nil) and (NOT found) do
if mbptr^.mailname = UpperCase(pMailboxname)
then found := true
else mbptr := mbptr^.maillink ;
if NOT found then begin
if debug then
errormsg(warnlevel,
'Receive: Mailbox name error: ' +pMailboxname) ;
pmsgptr := nil ; exit ;
end ;
found := false ;
Lock(mbptr^.MailLock) ; { Get exclusive control of mailbox }
REPEAT
WITH mbptr^ do begin
if mailsendhead <> nil then begin { Return available message }
recptr := mailsendhead ; { but not ones we sent }
if recptr^.msgprocid <> tid then begin
mailsendhead := recptr^.msgreclink ;
if mailsendhead = nil then
mailsendtail := nil ;
pmsgptr := recptr^.msgrecdata ; { pointer to user data }
dispose(recptr) ; { free message record }
found := true ;
end {if..tid} ;
end {if msgsendhead..} ;
if NOT found then begin { suspend caller when no msgs }
if NOT onwaitlist(mbptr,tid) { and place on waiting chain }
then begin { if not there already }
new(recptr) ;
recptr^.msgrecdata := pmsgptr ; { store ptr to user data }
recptr^.msgprocid := tid ; { store id of caller }
if mailwaithead = nil then { Queue the message ptr }
mailwaithead := recptr
else
mailwaittail^.msgreclink
:= recptr ;
recptr^.msgreclink := nil ;
mailwaittail := recptr ;
end {if NOT onwaitlist} ;
end {if NOT found..} ;
if NOT found then begin
SingleTask ; {** Critical section **}
UnLock(mbptr^.mailLock) ; { release the mailbox }
suspend(tid,msgwait) ; { without a taskswitch }
MultiTask ;
Yield ; { release CPU control here }
Lock(mbptr^.mailLock) ; { reacquire mailbox lock }
end {if NOT found} ;
end {with mbptr^..} ;
UNTIL found ;
UnLock(mbptr^.MailLock) ; { Release control of mailbox }
End {Procedure Receive} ;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
{ initialization }
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
begin { SRMSGU initialization }
f1stMailbox := nil ;
end { SRMSGU initialization } .
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/