PGM MLIB86
REL
**********************************************************
* *
* (C) Copyright 1980 Network Development Group *
* Rutherford Laboratory *
* *
**********************************************************
**********************************************************
* *
* This is the assembly language library for TRIPOS on an *
* INTEL 8086 system. *
* *
* Author Graham Adams April 1980 *
* Modified to use separate code segment August 1980 *
* Maximum code version August 1981 *
* *
**********************************************************
* system constants
LIBWORD EQU 23456 marks library routines
SECWORD EQU 12345 marks BCPL sections
*
* device bits and addresses
*
COKRDY EQU 2 console keyboard ready bit
COPRDY EQU 1 console printer ready bit
COKPCSW EQU #DE console status register
COKPIOW EQU #DC console i/o register
*
* Coroutine stack symbols
*
* 0 link to next coroutine
C.CLLR EQU 2 caller coroutine
C.SEND EQU 4 stack end
C.RESP EQU 6 resumption ptr
C.FUNC EQU 8 function
C.RTRN EQU 10 return link for STOP
*
* Root node items
CRNTSK EQU #506
CBLKLIST EQU #528
* Global Vector symbols
*
G.GETCOB EQU 3*2
G.PUTCOB EQU 4*2
G.FETCHC EQU 5*2
G.STOREC EQU 6*2
G.GETCOD EQU 7*2
G.FRCOD EQU 9*2
G.RES2 EQU 10*2 RESULT2 for errors etc.
G.RC EQU 11*2 RETURNCODE for STOP
G.SBASE EQU 12*2 Current stack base
*
* Kernel Primitives
*
G.FVEC EQU 30*2 FREEVEC
G.GVEC EQU 29*2 GETVEC
*
* Machine code library routines
*
G.APT EQU 20*2 APTOVEC
G.CALCO EQU 25*2 CALLCO
G.COWAIT EQU 26*2 COWAIT
G.CRCO EQU 23*2 CREATECO
G.DELCO EQU 24*2 DELETECO
G.GBYTE EQU 15*2 GETBYTE
G.LEVEL EQU 17*2 LEVEL
G.LJUMP EQU 18*2 LONGJUMP
G.MULDIV EQU 19*2 MULDIV
G.PBYTE EQU 16*2 PUTBYTE
G.RESCO EQU 27*2 RESUMECO
G.SARDCH EQU 21*2 SARDCH
G.SAWRCH EQU 22*2 SAWRCH
G.STOP EQU 2*2 STOP
*
* Section header
*
MLIB DW MLBEND-MLIB/2 Section length in words
DW SECWORD
*
DB 17,"MLIB 11-Aug-81"
**********************************************************
* *
* PUTBYTE(S,N,C) *
* S,STRING: N,BYTE POSITION: C,BYTE *
* *
**********************************************************
DW LIBWORD
DB 7,"putbyte"
PB1 SHL BX string address
ADD BX,AX char address
MOV (BX),CL stuff it
RETS
**********************************************************
* *
* LEVEL() RETURNS ACTIVATION LEVEL *
* *
**********************************************************
DW LIBWORD
DB 7,"level "
LEVEL MOV BX,BP
RETS
**********************************************************
* *
* STOP(ARG) *
* *
* This function returns from the current coroutine or *
* task, setting RETURNCODE and passing the argument ARG. *
* *
**********************************************************
DW LIBWORD
DB 7,"stop "
STOP ADD SP,!4 discard return address
MOV G.RC(DI),BX set return code
MOV BP,G.SBASE(DI) find stack base
SHL BP
CMP C.CLLR(BP),!0 find caller
JS STP1 root stack := -1
JMP CRC2 return from coroutine
STP1 JIS C.RTRN(BP) return to task deactivation
**********************************************************
* *
* LONGJUMP(P, L) JUMP TO DIFFERENT ACTIVATION LEVEL *
* *
**********************************************************
DW LIBWORD
DB 7,"longjum"
LONGJ MOV BP,BX
ADD SP,!4 keep m/c stack correct
MOV SI,AX ready for jump
JIS (SI)
**********************************************************
* *
* APTOVEC(G, N) *
* *
**********************************************************
DB 7,"aptovec"
APTOVEC ADD BP,DX std BCPL entry
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV 8(BP),BX
MOV 10(BP),AX save args.
MOV DX,AX n
INC DX
SHL DX 2*(N+1)
LEA CX,12(BP) vector address
SHR CX -> BCPL
ADD DX,!14
MOV SI,BX entry point
MOV BX,CX
CIS (SI)
JMP BRET
**********************************************************
* *
* MULDIV(A, B, C) *
* Computes 32 bit result of A*B then divides it by C. *
* Result of call is the quotient, remainder is placed *
* in RESULT2. *
* *
**********************************************************
DW LIBWORD
DB 7,"muldiv "
MULDIV IMUL BX dx:ax := ax * bx
IDIV CX ax := dx:ax/cx; dx := dx:ax REM cx
MOV G.RES2(DI),DX
MOV BX,AX
RETS
*
* Outch and Inch are used by Sawrch and Sardch
*
OUTCH AND AL,!#7F
CMP AL,!#A
JNE ONLF
MOV AL,!#D for *N do cr then lf
CALL OUTCH
MOV AL,!#A line feed
CALL ONLF
XOR AL,AL idle
CALL ONLF
CALL ONLF
CALL ONLF
MOV AL,!#A
RET
ONLF PUSH AX
OUT1 IN #DE
TEST AL,!1
JE OUT1
POP AX
OUT #DC data
RET
*
*
INCH IN #DE
TEST AL,!2
JE INCH
IN #DC
AND AL,!#7F
CMP AL,!#D if cr then change to *N
JNE INCR
MOV AL,!#A
INCR CALL OUTCH
RET
**********************************************************
* *
* GETBYTE(S,N) *
* S,STRING: N,BYTE POSITION *
* *
**********************************************************
DW LIBWORD
DB 7,"getbyte"
GB1 SHL BX string address
ADD BX,AX char address
MOV BL,(BX) get character
XOR BH,BH
RETS
**********************************************************
* *
* FETCHCODE(ADDRESS,SEGMENT) *
* ADDRESS = MC ADDRESS OF WORD IN SEGMENT *
* *
**********************************************************
DW LIBWORD
DB 7,"FETCHCO"
FETCHC CLI protect ES
MOV ES,AX
MOV BX,(BX)[ES]
STI
RETS
**********************************************************
* *
* STORECODE(ADDRESS, SEGMENT, WORD) *
* STORES WORD AT MC ADDRESS IN SEGMENT *
* *
**********************************************************
DW LIBWORD
DB 7,"STORECO"
STOREC CLI protect ES
MOV ES,AX
MOV (BX),CX[ES]
STI
RETS
**********************************************************
* *
* GETCODEBYTE(S,SEG,N) *
* S,MC STRING IN SEGMENT,SEG = SEGMENT,N = BYTE POSITION *
* *
**********************************************************
DW LIBWORD
DB 7,"GETCODE"
GETCO ADD BX,CX no protection against overflowing seg
CLI protect ES
MOV ES,AX
MOV BL,(BX)[ES]
STI
XOR BH,BH
RETS
**********************************************************
* *
* PUTCODEBYTE(S, SEG, N, C) *
* S=MC STRING, SEG=SEGMENT, N=BYTE POSITION IN STRING, *
* C=BYTE VALUE *
* *
**********************************************************
DW LIBWORD
DB 7,"PUTCODE"
PUTCO ADD BP,DX std. BCPL entry
MOV 4(BP),DX
POP (BP)
POP 2(BP)
*
ADD BX,CX
MOV CL,14(BP)
CLI
MOV ES,AX
MOV (BX),CL[ES]
STI
*
JMP BRET
************************************************************
* *
* GETCODEVEC(UPPERBOUND) *
* *
* This function is BCPL callable. *
* It returns the mc address of a vector with at least *
* the given upper bound. (In fact, the upperbound is *
* rounded up to the next even number.) The words at offset *
* -2 of the vector contain the length of the store block *
* and should not be touched by the user. *
* The vector is taken from the code area store chain *
* Runs with interrupts disabled, but reenables and disables*
* them each time round the search loop, so that they will *
* not be locked out for the whole of a lengthy search *
* If no global vector has been set up then DI must be zero.*
* The ls. 16 bits of the address are returned in RESULT2. *
* The normal result contains the segment register contents *
* unless an error has occurred in which case the result is *
* -1 (not 0 as for GETVEC). *
* *
************************************************************
DW LIBWORD
DB 7,"getcode"
*
GETCOD EQU $ std. entry sequence
ADD BP,DX
MOV 4(BP),DX
POP (BP)
POP 2(BP)
*
INC BX true vector size
JG GG1
JMP GVC7 error
GG1 INC BX one word of count
OR BX,!1 make odd
INC BX other word of count
SHL BX size requested in bytes
MOV 8(BP),BX save
CLI disable interrupts
*
GVCRTY MOV SI,CRNTSK
MOV GVTSK,SI record caller
MOV AX,CBLKLIST ls. of mc address
MOV BX,CBLKLIST+2 seg for mc address
XOR DX,DX
MOV CX,!12 get 12 bits from seg in DX
GG1A SHR BX
RCR DX
LOOP GG1A
ADD AX,DX now correct ls. 16 bits
ADC BX,!0 and ms. 4 bits
MOV 10(BP),BX AX and BX now contain 20 bit mc address
ROR BX
ROR BX
ROR BX
ROR BX
MOV GVES,BX
*
GVC1 XCHG AX,SI
XCHG 10(BP),BX
GVC1A STI enable interrupts
*
* At this point interrupts are enabled. This is because the
* search for a suitable free block may be long. If any
* other task is run and calls GETCODEVEC then GVTSK will be
* reset and the search must start again at the beginning of
* the block list in case it has been updated meanwhile.
CLI disable interrupts again
MOV AX,GVTSK
CMP AX,CRNTSK any other callers?
JNE GVCRTY restart the search
*
MOV ES,GVES
MOV CX,(SI)[ES] get 19-bit count
MOV DX,2(SI)[ES]
CMP DX,!7 bizarre?
JLE GG2
JMP ERRSTOR
GG2 OR CX,CX
JNE G1B non-zero
OR DX,DX
JNE G1B
JMP GVC7 count field is zero
*
G1B TEST CX,!1 free?
JNE GVC2 yes
SHL CX -> byte count
RCL DX
* Find next count.
ADD SI,CX
ADC BX,DX
MOV CX,BX
ROR CX
ROR CX
ROR CX
ROR CX
MOV GVES,CX set up ES
JMP GVC1A
*
GVC2 MOV AX,SI save MC address of free block
MOV 10(BP),BX
GVC3 DEC CX count-1, ignore free bit
SHL CX get '32 bit' count in bytes
RCL DX
ADD SI,CX move to next block
ADC BX,DX
MOV CX,BX construct ES
ROR CX
ROR CX
ROR CX
ROR CX
MOV ES,CX
MOV CX,(SI)[ES]
MOV DX,2(SI)[ES]
MOV 12(BP),!0
OR 12(BP),CX
OR 12(BP),DX
JE GVC4
CMP DX,!7 bizarre?
JLE GG3
JMP ERRSTOR loop?
GG3 TEST CX,!1
JNE GVC3 jump if block free
*
* Now 8(BP) = size request in bytes
* AX,10(BP) ls and ms of start of free area
* SI,BX ls and ms of end of free area
*
GVC4 EQU $
* Find size of free area.
MOV CX,SI
MOV DX,BX
SUB CX,AX
SBB DX,10(BP)
* Swap pointers.
XCHG AX,SI
XCHG 10(BP),BX
MOV ES,GVES
* Amalgamate blocks.
MOV (SI),CX[ES]
MOV 2(SI),DX[ES]
SHR 2(SI)[ES]
RCR (SI)[ES]
INC (SI)[ES] mark as free
* Split block by subtracting request
SUB CX,8(BP)
SBB DX,!0
JNS GG4
JMP GVC1 can't be done
GG4 MOV 12(BP),!0
OR 12(BP),CX
OR 12(BP),DX
JE GVC5 exact fit
SUB AX,CX find upper part and calc. size
SBB 10(BP),DX
SHR DX -> BCPL
RCR CX
INC CX mark as free
XCHG AX,BX
MOV 12(BP),SI temp store SI
MOV SI,10(BP) use to calc. segment
ROR SI
ROR SI
ROR SI
ROR SI
MOV ES,SI
MOV SI,12(BP) get back value
MOV (BX),CX[ES] plant size
MOV 2(BX),DX[ES]
XCHG BX,AX
*
GVC5 MOV AX,8(BP) get request
SHR AX -> BCPL
MOV CX,BX
ROR CX
ROR CX
ROR CX
ROR CX
MOV ES,CX
MOV (SI),AX[ES] plant size
MOV 2(SI),!0[ES]
* Returns seg as result
* and ls. part in RESULT2.
MOV DX,SI
MOV CX,!12
GVC5A SHL SI
RCL BX
LOOP GVC5A
AND DX,!#F
ADD DX,!4 skip count (and ensure offset >=4)
MOV G.RES2(DI),DX
STI enable interrupts
JMP BRET
*
GVC7 OR DI,DI if no glob. vec then
JE GVC8 can't set RESULT2
MOV G.RES2(DI),!103 insufficient free store
GVC8 MOV BX,!-1 -1 means error return
STI
JMP BRET
*
ERRSTOR MOV CX,!197 free store corrupt
INT 34
JMP GVCRTY
****************************************************************
* *
* FREECODEVEC(OFF, SEG) *
* *
* This BCPL callable routine frees the vector, which should *
* have been obtained by GETCODEVEC. It aborts the task if an *
* error is detected. *
* *
****************************************************************
DW LIBWORD
DB 7,"freecod"
FREECOD EQU $
FVEC CLI
MOV ES,AX
TEST -4(BX),!1[ES] free? (n.b. BX always >= 4)
JNE FVC1 error
INC -4(BX)[ES] mark free
RETS
FVC1 MOV CX,!199
INT 34
RETS
**********************************************************
* *
* SARDCH() *
* Stand alone rdch routine *
* *
**********************************************************
DW LIBWORD
DB 7,"sardch "
RD1 CALL INCH
XOR BH,BH
MOV BL,AL
RETS
**********************************************************
* *
* SAWRCH() *
* Stand alone wrch routine *
* *
**********************************************************
DW LIBWORD
DB 7,"sawrch "
WR1 MOV AX,BX
CALL OUTCH
RETS
**********************************************************
* *
* CREATECO(FN, STSIZE) *
* *
* This function creates a coroutine with body FN, stack *
* size STSIZE and returns a pointer to its stack base *
* *
**********************************************************
DB 7,"createc"
CREATEC ADD BP,DX std BCPL entry
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV 8(BP),BX
MOV 10(BP),AX save arguments
MOV BX,AX
MOV DX,!12
MOV SI,G.GVEC(DI) call getvec
CIS (SI)
*
OR BX,BX any store?
JNE CRCA1
JMP BRET no, return result 0
CRCA1 MOV SI,BX BCPL new stack in BX
SHL SI MC new stack in SI
MOV CX,10(BP) size in CX
INC CX
CRC1 MOV (SI),!0
INC SI
INC SI
LOOP CRC1
*
MOV SI,G.SBASE(DI) get current corot.
MOV DX,BX save new BCPL stack
SHL BX
MOV C.CLLR(BX),SI set caller
SHL SI MC current
MOV CX,(SI)
MOV (BX),CX
MOV (SI),DX link in new stack
MOV C.RESP(SI),BP save resumption ptr
MOV CX,8(BP) function
MOV C.FUNC(BX),CX to new stack
MOV CX,10(BP) size
ADD CX,DX BCPL new stack end
SUB CX,!50
MOV C.SEND(BX),CX
MOV G.SBASE(DI),DX
MOV BP,BX
MOV BX,DX return correct result
CRC2 MOV DX,!C.RTRN
PUSH CS mimic CIS
CALL COWAIT
MOV DX,!C.RTRN
MOV SI,C.FUNC(BP)
CIS (SI)
JMP CRC2 repeat
**********************************************************
* *
* DELETECO(CPTR) *
* This routine deletes the coroutine represented by CPTR *
* *
**********************************************************
DB 7,"deletec"
DELETEC ADD BP,DX std BCPL entry
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV 8(BP),BX save cptr
*
MOV SI,BX
SHL SI MC coptr
CMP C.CLLR(SI),!0 active?
JNE COERR yes, error
MOV SI,G.SBASE(DI) corot. chain
* descend to root coroutine
DC1 MOV DX,SI
SHL SI
MOV SI,C.CLLR(SI)
OR SI,SI
JG DC1 loop till root
* locate corot. DX holds root the first time
MOV SI,DX
DC2 SHL SI
MOV DX,SI
MOV SI,(SI)
OR SI,SI
JE COERR end of chain
CMP SI,BX found?
JNE DC2
* now unlink
SHL SI
MOV CX,(SI)
MOV SI,DX
MOV (SI),CX
* free the store
MOV DX,!12
MOV SI,G.FVEC(DI)
CIS (SI)
B BRET
*
* error in coroutine call etc
COERR MOV CX,!195
INT 34 abort the task
* BCPL fn return
BRET MOV SI,4(BP)
SUB BP,SI
JIS (BP,SI)
**********************************************************
* *
* CALLCO(CPTR, ARG) *
* *
* This function calls the coroutine represented by CPTR, *
* passing the argument ARG. *
* *
**********************************************************
DB 7,"callco "
CALLCO ADD BP,DX
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV DX,BX save new corot
SHL BX MC new corot ptr
MOV CX,BX save MC ptr
CMP C.CLLR(BX),!0 already active?
JNE COERR
MOV SI,G.SBASE(DI)
MOV C.CLLR(BX),SI activate new coroutine
SHL SI MC old corot ptr
COENT MOV G.SBASE(DI),DX
MOV BX,AX arg in BX
COSWP MOV C.RESP(SI),BP save resumption ptr
MOV SI,CX
MOV BP,C.RESP(SI) new stack
B BRET
**********************************************************
* *
* RESUMECO(CPTR, ARG) *
* *
* This function deactivates the current coroutine and *
* resumes the coroutine represented by CPTR, passing the *
* argument ARG. *
* *
**********************************************************
DB 7,"resumec"
RESUME ADD BP,DX
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV DX,BX
SHL BX MC new corot ptr
MOV CX,BX
MOV SI,G.SBASE(DI)
SHL SI MC old corot ptr
CMP SI,BX new=old?
JE COENT yes - bypass checks
CMP C.CLLR(BX),!0 new already active?
JNE COERR yes - error
CMP C.CLLR(SI),!0 old=root?
JS COERR yes - error
PUSH C.CLLR(SI)
POP C.CLLR(BX) activate new
MOV C.CLLR(SI),!0 deactivate old
B COENT
**********************************************************
* *
* COWAIT(ARG) *
* *
* This function returns from the current coroutine *
* passing the argument ARG. *
* *
**********************************************************
DB 7,"cowait "
COWAIT ADD BP,DX
MOV 4(BP),DX
POP (BP)
POP 2(BP)
MOV 6(BP),SI
MOV SI,G.SBASE(DI)
SHL SI MC old corot ptr
MOV CX,C.CLLR(SI) get caller
OR CX,CX
JNS COW1
JMP COERR | -1 => root node
COW1 MOV G.SBASE(DI),CX stackbase
SHL CX MC new corot ptr
MOV C.CLLR(SI),!0 deactivate old coroutine
B COSWP
*
*
* Globals to be initialized
*
*
EVEN
DW 0
DW G.GETCOB/2
DW GETCOI-MLIB
DW G.PUTCOB/2
DW PUTCOI-MLIB
DW G.FETCHC/2
DW FETCHCI-MLIB
DW G.STOREC/2
DW STORECI-MLIB
DW G.GETCOD/2
DW GETCODI-MLIB
DW G.FRCOD/2
DW FREECODI-MLIB
DW G.APT/2
DW APTOVECI-MLIB
DW G.LEVEL/2
DW LEVELI-MLIB
DW G.LJUMP/2
DW LONGJI-MLIB
DW G.MULDIV/2
DW MULDIVI-MLIB
DW G.GBYTE/2
DW GB1I-MLIB
DW G.PBYTE/2
DW PB1I-MLIB
DW G.SARDCH/2
DW RD1I-MLIB
DW G.SAWRCH/2
DW WR1I-MLIB
DW G.CRCO/2
DW CREATECI-MLIB
DW G.DELCO/2
DW DELETECI-MLIB
DW G.CALCO/2
DW CALLCOI-MLIB
DW G.RESCO/2
DW RESUMEI-MLIB
DW G.COWAIT/2
DW COWAITI-MLIB
DW G.STOP/2
DW STOPI-MLIB
DW 99 highest referenced global
MLBEND EQU $
*
*
DSEG
DMLIB DW DMLBEND-DMLIB/2
GVTSK DW 0
GVES DW 0
*
GETCOI DW GETCO
DW 0
PUTCOI DW PUTCO
DW 0
FETCHCI DW FETCHC
DW 0
STORECI DW STOREC
DW 0
GETCODI DW GETCOD
DW 0
FREECODI DW FREECOD
DW 0
APTOVECI DW APTOVEC
DW 0
LEVELI DW LEVEL
DW 0
LONGJI DW LONGJ
DW 0
MULDIVI DW MULDIV
DW 0
GB1I DW GB1
DW 0
PB1I DW PB1
DW 0
RD1I DW RD1
DW 0
WR1I DW WR1
DW 0
CREATECI DW CREATEC
DW 0
DELETECI DW DELETEC
DW 0
CALLCOI DW CALLCO
DW 0
RESUMEI DW RESUME
DW 0
COWAITI DW COWAIT
DW 0
STOPI DW STOP
DW 0
DMLBEND END