        TTL      *** TRIPOS Kernel for the M68000 ***
******************************************************************
*                                                                *
*           (C) Copyright 1981 Tripos Research Group             *
*                                                                *
*               University of Cambridge                          *
*               Computer Laboratory                              *
*                                                                *
*  Author: Martin Richards (based on a prototype written         *
*                           by Peter Clitherow as a CST          *
*                           dissertation and the TRIPOS kernel   *
*                           for the PDP 11)                      *
*                                                                *
*  Modifications                                                 *
*                                                                *
*  15 Mar 1982  by IDW: Addition of CNOP directives              *
*  26 Apr 1982  by AJW: Addition of conditional assembly tag AJW *
*                       This should be 1 for standard Tripos, or *
*                       0 for the AJW-Tripos mods.               *
*   2 Sep 1982  by PB : Stack checking, Profiling, mul, div & rem*
*                       added at byte offsets 128,256,384,512&640*
*                       relative to the SAVE routine.  JSR n(S)  *
*                       (See CG68HDR)                            *
*   8 Sep 1982  by PB : Assembly tag AJW removed, as standard    *
*                       Tripos now has extra words allocated     *
*                       Abort codes assigned names               *
*  14 Sep 1982  by BJK: Abort code numbers rationalized.         *
*  15 Sep 1982  by BJK: Root node moved clear of interrupt       *
*                       vectors.  Copy left in old position      *
*                       to ease changeover.                      *
*                       Bug fixed at INTRET4: ANDI.L -> ANDI.W   *
*                       MUL, DIV, REM moved back to MLIB.        *
*                       Idle task TCB made same size as others.  *
*  20 Sep 1982  by BJK: Automatic store size finding installed   *
*                       as part of start-up.                     *
*                       Code "to wait for ACIAs" removed.        *
*                       4 words added to initial system stack.   *
*  21 Sep 1982  by BJK: FREEVEC given correct abort number, and  *
*                       checks that it is given an odd address.  *
*  29 Sep 1982  by BJK: Fix to support double root node - CRNTSK *
*                       maintained in old root node.             *
*   1 Oct 1982  by BJK: Fix so that old root node is correctly   *
*                       maintained when store size finder finds  *
*                       that MEMSIZE is already correct.         *
*   1 Feb 1983  by IDW: Removal of size tag from all Bxxx.L      *
*                       instructions.                            *
*                       Bug in ACTIV section of scheduler mended *
*   4 Apr 1983  by MR:  Mod to preserve the user stack pointer   *
*                       (USP) is the TCB, and also to provide    *
*                       a private exception handling mechanism,  *
*                       for use by the ENTER procedure.          *
*                                                                *
******************************************************************
        PAGE
        SPC 10
******************************************************************
******************************************************************
*****        **       *****  ****       ****      ****     *******
********  *****  ***   ****  ****  ***   **   **   **   **  ******
********  *****  ****  ****  ****  ****  **  ****  **   **********
********  *****  ***   ****  ****  ***   **  ****  ***   *********
********  *****       *****  ****       ***  ****  ****   ********
********  *****  **  ******  ****  ********  ****  *****   *******
********  *****  ***  *****  ****  ********  ****  ******   ******
********  *****  ****  ****  ****  ********   **   **  **   ******
********  *****  *****  ***  ****  *********      ****     *******
******************************************************************
******************************************************************
        SPC 3
******************************************************************
*                                                                *
*       A 32 bit kernel for TRIPOS for the MC68000 system        *
*                                                                *
******************************************************************
        PAGE
        SPC 4
* Register usage when in BCPL compiled code.
*
*      D0       work reg - used to hold the stack increment
*                          in a procedure call
*      D1       the first argument and result register
*      D2-D4    the second to fourth argument registers
*      D5-D7    general work registers
*      Z (=A0)  hold the constant 0 (to allow n(Z,Di.L) addresses)
*      P (=A1)  BCPL P pointer (MC address of first arg)
*      G (=A2)  BCPL G pointer (MC address of global 0)
*      L (=A3)  work reg - (hold the return address in the
*                           entry and return sequences)
*      B (=A4)  base reg - (hold the MC address of entry to the
*                           current procedure. It is necessary
*                           for position independent addressing
*                           of data in program code.  Note that
*                           instruction and data space MUST be
*                           the same)
*      S (=A5)  MC address of the save S/R:        Timings Totals
*                  MOVEA.L   (SP)+,L                    6
*                  MOVEM.L   P/L/B,-12(P,D0.L)         19
*                  ADDA.L    D0,P                       7
*                  MOVEM.L   D1-D4,(P)                 20
*                  JMP       (B)                        4       32
*      R (=A6)  MC address of the return code:
*                  MOVEM.L   -12(P),P/L                16
*                  MOVE.L    -4(P),B                    8
*                  JMP       (L)                        4       28
*      SP(=A7)the system stack pointer
*
* The (typical) calling sequence is:
*
*       MOVEQ   #36,D0          Stack increment         2
*       MOVEA.L n(G),B          (calling a global)      8
*       JSR     (S)             Call the save routine   4       14
*
* To return from a procedure:
*
*       JMP     (R)                                     4        4
*
*
        PAGE
        TTL ** TRIPOS   Kernel  -   Equates **
*
*
* Symbol definitions and data structures
*
*
LIBWORD EQU     23456                Marks library routines
SECWORD EQU     12345                Marks a BCPL section
NOTINUSE EQU       -1                Link word for dequeued packets


*
* Various PSWs etc.
*
INTSOFF EQU     $2700                Interrupt mask X'7'
INTSON  EQU     $2000                Interrupt mask X'0'

TRAP13  EQU     $4E4D                The instruction for BREAKPOINTs
*
* Register definition
*
Z       EQUR    A0                   Constant Zero
P       EQUR    A1                   BCPL P ptr
G       EQUR    A2                   BCPL G ptr
L       EQUR    A3                   Work reg
B       EQUR    A4                   Addr of current procedure
S       EQUR    A5                   Save routine addr
R       EQUR    A6                   Return addr
SP      EQUR    A7                   System stack ptr


*
* Clock control
*
MTICKS  EQU      50*60               ticks per minute

*
* Device driver and control blocks
*
D_DRIVER EQU    0                    BCPL device driver ptr
D_ID    EQU     4                    Device id
D_WKQ   EQU     8                    Work queue
D_START EQU    12                    Start routine for QPKT
D_STOP  EQU    16                    Stop routine for DQPKT
D_INT   EQU    20                    Interrupt routine


*
* Driver offsets
*
D_INIT  EQU          4               initialisation routine
D_UNIN  EQU          8               Uninitialisation routine

*
* TCB definition
*
T_LINK  EQU          0               Forward link
T_ID    EQU          4               Task id
T_PRI   EQU          8               Priority
T_WKQ   EQU         12               Work queue
T_STATE EQU         16               State (address of long word)
T_STATEW EQU        18               State (address of word)
T_STATEB EQU        19               State (address of byte)
T_FLAGS EQU         20               Flags for break etc
T_STSIZE EQU        24               Stack size
T_SEGL  EQU         28               Segment list
T_GBASE EQU         32               Global vector base
T_SBASE EQU         36               Root stack base
*
* The system stack pointer for the task is held in the TCB if the
* the task is not currently executing.
*
T_SP    EQU         40
*
T_PXHAND EQU        44               Private exception handler
*
* The value of SP for an INTERRUPTED task is the address of
* the area in memory holding all the machine registers for the
* task stored in the following order:
*
*    USP D0-D7 A0-A6 SR PC
*
* For a non executing task in a RUN state (00XX), SP points
* to:
*     D1 P and G
*
* for the task.
*
* For a task in a WAIT state (01XX), SP points to a dump of P and G.
*
* The system stack for the task is (normally) in the TCB which
* must therefore be large enough.  Be generous for safety (and
* convenience).  After all we do not expect to have many tasks.
*
T_UPB   EQU         40*4             40 words should suffice
TCBSIZE EQU         40               TCB size for GETVEC
*
* Complete register dump relative to SP
*
D_SR    EQU         64
D_PC    EQU         66
*
*
* Task states
*
S_PKT   EQU          1               Pkt on work Q
S_HOLD  EQU          2               Held
S_WAIT  EQU          4               Wait
S_INT   EQU          8               Interrupted
S_DEAD  EQU         12               Dead

*
* Packet symbols
*
P_LINK  EQU          0               Forward link
P_ID    EQU          4               Task or device id
P_TYPE  EQU          8               Type or action
P_RES1  EQU         12               First result
P_RES2  EQU         16               Second result
P_A1    EQU         20               First argument
P_A2    EQU         24               Second argument

*
* Coroutine symbols
*
C_LINK  EQU          0               Link to next co-routine
C_CLLR  EQU          4               Caller coroutine
C_SEND  EQU          8               Stack end - 32
C_RESP  EQU         12               Resumption ptr
C_FUNC  EQU         16               Function
C_EXSBASE EQU       20               Base of static exception chain
C_EXDBASE EQU       24               Base of dynamic exception chain
*C_SPARE1 EQU       28               (spare)
*C_SPARE2 EQU       32               (spare)
*                   36               PC dump - dummy
C_RTRN  EQU         40               Return link for stop
C_FSIZE EQU         48               Frame size for calling of coroutine
*
* Global vector symbols
*
UNGLOB  EQU $474C0001                (Unset global n is UNGLOB + 2*n)

G_START EQU         1*4              START
G_RES2  EQU        10*4              Used for error codes
G_RC    EQU        11*4              RETURNCODE for STOP
G_SBASE EQU        12*4              Current stack base
G_TCB   EQU        13*4              Task block pointer
G_TASKID EQU       14*4              Task id
G_MIN   EQU        14*4              Minimum sized valid global vector
*
* Nucleus primitives
*
G_ABORT   EQU      38*4
G_CPRI    EQU      35*4
G_CDEV    EQU      31*4
G_CTASK   EQU      33*4
G_DDEV    EQU      32*4
G_DTASK   EQU      34*4
G_DQPKT   EQU      43*4
G_FVEC    EQU      30*4
G_GLOBIN  EQU      28*4
G_GVEC    EQU      29*4
G_HOLD    EQU      39*4
G_QPKT    EQU      42*4
G_RELEASE EQU      40*4
G_SFLAGS  EQU      36*4
G_TWAIT   EQU      41*4
G_TFLAGS  EQU      37*4

G_GLOBMAX EQU      G_DQPKT           Highest global used in KLIB

*
*       Abort codes
*
*  68000 specific codes
*
A_L1111         EQU     70      Line 1111 exception (unimplemented instruction)
A_L1010         EQU     71      Line 1010 exception (unimplemented instruction)
A_TRAPV         EQU     72      TRAPV exception
A_CHECK         EQU     73      CHK exception
A_SPURIOUS      EQU     74      Spurious interrupt
A_UNUSEDTRAP    EQU     75      Unexpected TRAP
*
*  General machine aborts
*
A_PRIV          EQU     87      Privileged instruction exception
A_DIVIDE        EQU     88      Division by zero
A_BUS           EQU     89      Bus error
A_IOINT         EQU     90      Unexpected interrupt
A_ILLINSTR      EQU     91      Illegal instruction
A_ADDRESS       EQU     92      Invalid address
A_CONSOLE       EQU     96      Console interrupt
A_NOSTACK       EQU     97      Stack overflow detected
A_UNDEFGLOB     EQU     98      Undefined global called
*
*  Kernel aborts
*
A_INVALIDID     EQU     101
A_INVALIDPRIO   EQU     102
A_GETVEC        EQU     103
A_DEVTABFULL    EQU     104
A_TASKTABFULL   EQU     105
A_DEVINIT       EQU     106
A_WORKQ         EQU     107
A_TASKDELETE    EQU     108
A_PKTNOTFOUND   EQU     109
A_TASKHELD      EQU     110
A_GLOBIN        EQU     111

A_ACTIVATE      EQU     196
A_STORECHAIN    EQU     197
A_PKTINUSE      EQU     198
A_ILLFREEVEC    EQU     199

*
*
*
B_PKT   EQU     0
B_HOLD  EQU     1
B_WAIT  EQU     2
B_INT   EQU     3
B_TRACE EQU     7                  The trace bit in SSR
*
          PAGE
          TTL    ** TRIPOS Kernel  -  Exceptions and Interrupts **
******************************************************************
******************************************************************
**                                                              **
**                 Absolute section                             **
**                                                              **
******************************************************************
******************************************************************


******************************************************************
*                                                                *
*         Interrupt vectors                                      *
*                                                                *
******************************************************************


         ORG         $0

INTVECS  DC.L        DSYSTKB         RESET vector SP value
         DC.L        $C0             and PC value
*
IV_BERR  DC.L        B_EXCPT         Bus error
         DC.L        A_EXCPT         Address error
         DC.L        I_EXCPT         Illegal instruction
         DC.L        D_EXCPT         Divide exception
         DC.L        C_EXCPT         CHK
         DC.L        O_EXCPT         TRAPV exception
         DC.L        P_EXCPT         Privilege exception
TRACEVEC DC.L        T_EXCPT         TRACE exception
         DC.L        X_EXCPT         L1010 emulation
         DC.L        Y_EXCPT         L1111 emulation
         DS.L        12              (Unassigned)
         DC.L        S_EXCPT         Spurious interrupt
*
* Interrupt levels 1-7
*
         DC.L        INT1            Level 1  (assigned to the clk)
         DC.L        INT2            Level 2
         DC.L        INT3            Level 3
         DC.L        INT4            Level 4
         DC.L        INT5            Level 5
         DC.L        INT6            Level 6
INT7VEC  DC.L        INT7            Level 7 abort button
*
* TRAPs
*
        DC.L         TRP0           Error handler for aborts etc.
        DC.L         TRP1
        DC.L         TRP2
        DC.L         TRP3
        DC.L         TRP4
        DC.L         TRP5
        DC.L         TRP6
        DC.L         TRP7
        DC.L         TRP8
        DC.L         TRP9
        DC.L         TRP10
        DC.L         TRP11
        DC.L         TRP12
        DC.L         TRP13           Breakpoints
        DC.L         TRP14
        DC.L         TRP15
*
        ORG          $C0             This overlays unassigned space
        MOVEA.L    RSTART,B          The kernel entry point
        JMP          (B)
*
        ORG          $D0             Polled remote I/O buffers
        DC.L         -1
        DC.L         -1
*
        TTL ** TRIPOS   Kernel  -   Root Node **
        PAGE
******************************************************************
*                                                                *
*         The ROOT node                                          *
*                                                                *
******************************************************************

* Rootnode at long word address 256 to avoid interrupt area.
*
* Many of the entries in the root node are filled in by SYSLINK.
*
******* Temporarily have TWO root nodes, the old one and the new one.
*******
******* The time is copied into the OLD rootnode on each tick.
******* All other fields are static (i.e. pointers to vectors), and so it is
******* necessary to do a SINGLE copy once all the vectors have been obtained.
******* The clock work queue also changes, but NO ONE should look at it except
******* KLIB, so it will always be the correct one.
*******
******* The main ROOTNODE is the new one.



LOWROOT  EQU    $100
HIGHROOT EQU    $400
REALROOT EQU    HIGHROOT
OLDROOT  EQU    LOWROOT

******** Old rootnode - kept during changeover *******************************##
*                                                                             ##
        ORG     OLDROOT                                                       ##
OLDTT   DC.L    0                    Pointer to TRIPOS Task Table             ##
OLDDT   DC.L    0                    Pointer to TRIPOS Device Table           ##
OLDTL   DC.L    0                    Start of TCB chain                       ##
OLDCT   DC.L    0                    Pointer to the TCB of current task       ##
OLDBL   DC.L    0                    Beginning of free store block list       ##
        DC.L    0                    Pointer to DEBUG TCB                     ##
OLDDAYS DC.L    0                    Count of Day                             ##
OLDMINS DC.L    0                    Count of minute since midnight           ##
OLDTICK DC.L    0                    Count of clock ticks                     ##
        DC.L    0                    Pointer to first packet for clock        ##
OLDMSIZ DC.L    0                    Memory size in Kwords                    ##
OLDINFO DC.L    0                    Pointer to info vector                   ##
        DC.L    KSTART               Kernel start address                     ##
        DC.L    NODEVINT             For detection of unset devices           ##
*                                                                             ##
        DC.W    0                                                             ##
        DC.W    $4EF9        JMP  MOVPKT  for devices                         ##
        DC.L    MOVPKT                                                        ##
*                                                                             ##
        DC.W    0                                                             ##
        DC.W    $4EF9        JMP  INTRET1 for devices                         ##
        DC.L    INTRET1                                                       ##
*                                                                             ##
        DC.W    0                                                             ##
        DC.W    $4EF9        JMP  INTRET2 for devices                         ##
        DC.L    INTRET2                                                       ##
*                                                                             ##
* Kernel work space                                                           ##
*                                                                             ##
        DC.L    0                    Calling task                             ##
        DC.L    0                    Word size Kernel work space (in a L word)##
        DC.L    0                    Long word Kernel work space              ##
*                                    (used only at level 7)                   ##
        DC.L    0                    =0 or MC addr of highest pri runnable TCB##
*                                    (always =0 when executing at level 0)    ##
*                                                                             ##
* The packet for DEBUG                                                        ##
          CNOP  0,4                                                           ##
        DC.L    0                     Mode                                    ##
        DC.L    0                     The current task                        ##
        DC.L    0                     Reason for entering DEBUG               ##
        DC.L    0                     Argument                                ##
        DC.L    0                     MC addr of register dump                ##
*                                                                             ##
        DC.W    0                                                             ##
        DC.W    0                     R/W I/N and FC code                     ##
        DC.L    0                     Faulting access address                 ##
*                                                                             ##
        DC.W    0                                                             ##
        DC.W    0                     First word of faulting instr.           ##
        DC.L    0                     Uncorrected PC at fault time            ##
*                                                                             ##
        DC.L    0,0,0,0,0,0,0,0  D      registers  D0-D7                      ##
        DC.L    0,0,0,0,0,0,0    A      registers  Z - R                      ##
*                                                                             ##
        DC.L    0,0,0,0,0,0,0,0   RING request vector                         ##
        DC.L    0,0,0,0,0,0,0,0   RING reply   vector                         ##
*                                                                             ##
********************************************************************************

        ORG     REALROOT
TASKTAB DC.L    0                    Pointer to TRIPOS Task Table
DEVTAB  DC.L    0                    Pointer to TRIPOS Device Table
TCBLIST DC.L    0                    Start of TCB chain
CRNTSK  DC.L    0                    Pointer to the TCB of current task
BLKLIST DC.L    0                    Beginning of free store block list
DEBTASK DC.L    0                    Pointer to DEBUG TCB
DAYS    DC.L    0                    Count of Day
MINS    DC.L    0                    Count of minute since midnight
TICKS   DC.L    0                    Count of clock ticks
CLKWQ   DC.L    0                    Pointer to first packet for clock
MEMSIZE DC.L    0                    Memory size in Kwords
INFO    DC.L    0                    Pointer to info vector
RSTART  DC.L    KSTART               Kernel start address
DEVUNSET DC.L   NODEVINT             For detection of unset devices

        DC.W    0
DEVMVP  DC.W    $4EF9        JMP  MOVPKT  for devices
        DC.L    MOVPKT

        DC.W    0
DEVRET1 DC.W    $4EF9        JMP  INTRET1 for devices
        DC.L    INTRET1

        DC.W    0
DEVRET2 DC.W    $4EF9        JMP  INTRET2 for devices
        DC.L    INTRET2

*
* Kernel work space
*
GVTSK   DC.L    0                    Calling task
WORKW   DC.L    0                    Word size Kernel work space (in a L word)
WORKL   DC.L    0                    Long word Kernel work space
*                                    (used only at level 7)
HTCB    DC.L    0                    =0 or MC addr of highest pri runnable TCB
*                                    (always =0 when executing at level 0)
*
        PAGE
        TTL ** TRIPOS   Kernel -  DEBUG packet and IDLE task **
******************************************************************
*                                                                *
*       DEBUG Packet used for entry to  standalone debug         *
*                                                                *
******************************************************************

* The packet for DEBUG
          CNOP  0,4
DBPKT
DBPMODE DC.L    0                     Mode
DBPTASK DC.L    0                     The current task
DBPCODE DC.L    0                     Reason for entering DEBUG
DBPARG  DC.L    0                     Argument
DBPSP   DC.L    0                     MC addr of register dump

        DC.W    0
DBPFCD  DC.W    0                     R/W I/N and FC code
DBPACCA DC.L    0                     Faulting access address

        DC.W    0
DBPINS  DC.W    0                     First word of faulting instr.
DBPPC   DC.L    0                     Uncorrected PC at fault time
*
DBPUSP  DC.L    0                       Dump of USP
DBPREGS DC.L    0,0,0,0,0,0,0,0  D      registers  D0-D7
        DC.L    0,0,0,0,0,0,0    A      registers  Z - R
*
RQSTVEC DC.L    0,0,0,0,0,0,0,0   RING request vector
RPLYVEC DC.L    0,0,0,0,0,0,0,0   RING reply   vector
*
DBWKW   DC.L    0                       Work space private to DEBUG
*
        PAGE
******************************************************************
*                                                                *
*         The idle task                                          *
*                                                                *
******************************************************************

        CNOP    0,4
IDLE    ADDQ.L  #1,D0         Idle counter
        BRA.S   IDLE

*
* TCB for the idle task
*
          CNOP  0,4
IDLETCB   DC.L  0                     Link - the end of the chain
          DC.L  0                     Task id
          DC.L  0                     Priority
          DC.L  0                     Work queue
          DC.L  S_INT                 Interrupted state
          DC.L  0                     Flags
          DC.L  0                     Stsize
          DC.L  0                     Segl
          DC.L  0                     Gbase
          DC.L  0                     Sbase
          DC.L  IDLEUSP               Idle task system stack
          DC.L  0                     PX handler

          DS.W  17                    Leave a stack safety margin

IDLEUSP   DC.L  0                     USP
IDLEREGS  DC.L  0,0,0,0,0,0,0,0       D0 - D7
          DC.L  0,0,0,0,0,0,0         A0 - A6
          DC.W  INTSON                SR (sup state, ints enabled)
          DC.L  IDLE                  PC (the idle loop)

IPKT      DC.L  0                     The initial startup pkt
          DC.L  0



          CNOP  0,4
DSYSTKT   DS.L  4                     Room for bus error in store size finder
DSYSTKB   EQU   *                     System stack at startup
*
          DC.L  0,0,0                 Standalone DEBUG BCPL stack
DEBPPTR   DC.L  0                     initial P pointer
*
          PAGE
          TTL  ** TRIPOS Kernel  -  Initialisation **
******************************************************************
******************************************************************
**                                                              **
**                 Relocatable section                          **
**                                                              **
******************************************************************
******************************************************************


        RORG    $0
*


******************************************************************
*                                                                *
*       Kernel initialisation                                    *
*                                                                *
******************************************************************

*       SECTION    1

        CNOP    0,4
KLIB    DC.L    (KEND-KLIB)/4   The size of the module for this segment
        DC.L    SECWORD
        DC.B    17,'KLIB     4-Apr-83'

*
*   This is the entry point to the TRIPOS Kernel
*
        CNOP    0,4
KSTART  MOVE    #INTSOFF,SR     (Supervisor state, ints disabled)
        NOP                     DON'T Reset the M68000!!!!
        MOVEA.L #DSYSTKB,A7     Set up a system stack
*
*
********************************************************************************
*                                                                              *
*   Find out how much store is available, and set MEMSIZE in the root node and *
*  adjust the end of the free store chain accordingly.                         *
*                                                                              *
*   The store size is found only to a resolution of 1024 long words, as this   *
*  is the unit of MEMSIZE (and it is reasonable to assume that store comes in  *
*  chunks of at least this size).  The test starts from the current memsize    *
*  and proceeds until either there is a bus error or a non-working location is *
*  found.                                                                      *
*                                                                              *
********************************************************************************

MEMPAT   EQU     $AAAAAAAA      Pattern used for memory test

* Plug bus error trap vector to call code here
*
         MOVE.L  IV_BERR,D0     Use D0 to save old trap address
         LEA     SSF_BERR,A0    Address for trap
         MOVE.L  A0,IV_BERR     Plug trap vector
*
         MOVE.L  MEMSIZE,D1     Get current MEMSIZE from root node
*
* Main loop of store size finder
*
SSFLOOP  MOVE.L  D1,D2          Copy memsize (K long words)
         ASL.L   #6,D2
         ASL.L   #6,D2          Convert to byte address
         MOVEA.L D2,A1          Get into address register
         MOVE.L  (A1),D2        Save current contents (may cause bus error)
         MOVE.L  #MEMPAT,(A1)   Load pattern
         CMPI.L  #MEMPAT,(A1)   See if there is memory there
         BNE.S   SSF_FOUND      Have hit top of store
*
         MOVE.L  D2,(A1)        Restore old contents of word
         ADDQ.L  #1,D1          Go up 1K long words
         BRA.S   SSFLOOP        Round again

* Bus error trap comes here
*
SSF_BERR MOVEA.L #DSYSTKB,A7    Reset system stack pointer

* Memory size found: in D1 in K long words

SSF_FOUND MOVE.L D0,IV_BERR     Restore bus error trap address

* If the memory size discovered is the same as that already set, then there
* is nothing more to do (and following code would mangle the store chain!).

         CMP.L   MEMSIZE,D1     Compare MEMSIZEs
         BEQ.S   SSF_END        Skip rest of store size finder

* Change memory size in rootnode and extend block list

         MOVE.L  D1,MEMSIZE     Put new memsize in root node

* Add the newly found memory to the free store chain
*
***** This code assumes that blocks start on EVEN longword boundaries *****

         MOVE.L  BLKLIST,A0     Start of store chain
         ADDA.L  A0,A0
         ADDA.L  A0,A0          Convert to byte address

* Find end of free store chain

SSFLOOP2 MOVE.L  (A0),D2        D2 := size + marker bit
         BEQ.S   SSF_EOBL       End of block list found
*
         BCLR    #0,D2          Remove marker bit
         ASL.L   #2,D2          Block length in bytes
         ADDA.L  D2,A0          Address of next block
         BRA.S   SSFLOOP2       Step on to next block

* Address of zero word at end of block list in A0

SSF_EOBL ASL.L   #6,D1
         ASL.L   #6,D1          Byte address of first non-existent byte
         SUBQ.L  #8,D1          Last even-addressed long word
         MOVEA.L D1,A1          Get in address register
         CLR.L   (A1)           New end of block list
         SUB.L   A0,D1          D1 := byte length of new final block
         ASR.L   #2,D1          length in long words
         BSET    #0,D1          Mark block as free
         MOVE.L  D1,(A0)        Install new final block

* End of store size finder
SSF_END
         MOVE.L  MEMSIZE,OLDMSIZ **** Put MEMSIZE in old root node    ****
         MOVE.L  INFO,OLDINFO   **** Copy INFO vec address here too   ****
         MOVE.L  BLKLIST,OLDBL  **** Copy BLKLIST address             ****
         MOVE.L  TASKTAB,OLDTT  **** Copy TASKTAB                     ****
         MOVE.L  DEVTAB,OLDDT   **** Copy DEVTAB                      ****
         MOVE.L  TCBLIST,OLDTL  ****
         MOVE.L  CRNTSK,OLDCT   ****


*
        SUBA.L  Z,Z          Initialise Z (=A0) to 0
*
*
* First initialise the clock then all devices in DEVTAB
*
        MOVEQ   #-1,D2       D2 = device Id
        CLR.L   CLKWQ        Clear the clock WKQ
        JSR     INITCLK      Start the clock
*
        MOVEA.L DEVTAB,R
        ADDA.L  R,R
        ADDA.L  R,R          R = MC addr of DEVTAB
        MOVE.L  (R)+,D0      Get the upb
        ASL.L   #2,D0
        LEA.L   -4(R,D0.L),S    S = MC addr of last entry
        TST.L   (R)+         Skip over dev -1 (the clock)
*
KST1    CMPA.L  R,S          Compare with end addr
        BLT.S   KST2         J if no more entries
        SUBQ.L  #1,D2        D2 = device id
        MOVEA.L (R)+,B       B = BCPL ptr to DCB
        MOVE.L  B,D0         Test it and
        BEQ.S   KST1         J if no such device
        ADDA.L  B,B
        ADDA.L  B,B          B = MC addr of DCB
        MOVE.L  D2,D_ID(B)           Plant the  device id
        CLR.L   D_WKQ(B)             and clear its WKQ

*
        MOVEA.L (B),L        Get the driver
        ADDA.L  L,L
        ADDA.L  L,L          L = MC addr of driver
        MOVEA.L D_INIT(L),L     L = MC addr of INIT routine
*
*
* At this point:
*
*         D2 = the device id (a negative number)
*          Z = 0
*          B = MC addr of the DCB
*          L = MC addr of the device INIT routine
*          S = MC addr of the next entry in DEVTAB
*          R = MC addr just after last entry in DEVTAB
*
* The INIT routine may read Z and B and must preserve
*
*         D2, Z, S and R
*
        JSR     (L)          INITialise the device
*
        BRA.S   KST1
*
* Append the idle TCB to the end of the task list
*
KST2    LEA.L   TCBLIST,L            Fetch TCB chain
KST3    TST.L   (L)
        BEQ.S   KST4         J if end of TCB chain
        MOVE.L  (L),L        Keep going
        ADDA.L  L,L
        ADDA.L  L,L          L = MC addr of next TCB
        BRA.S   KST3
*
KST4    MOVE.L  #IDLETCB,D1
        ASR.L   #2,D1        D1 = BCPL ptr to IDLE TCB
        MOVE.L  D1,(L)       Append it to the end of TCBLIST
        MOVE.L  Z,IDLETCB            Make sure its link is null
*
* Next go down the free block chain clearing all unallocated blocks
*
        MOVEA.L BLKLIST,L            Get start of block list
        ADDA.L  L,L
        ADDA.L  L,L          L = MC addr of next block
*
KST5    MOVEA.L L,B          B = MC addr of block under test
        MOVE.L  (B),D1       Get the block size
        BEQ.S   KST8         J if it is the dummy last block
        ASL.L   #2,D1
        ADDA.L  D1,L         L = MC addr (or +4) of next block
        BTST    #2,D1        Test if this block is allocated
        BEQ.S   KST5         J if allocated (freebit=0)
*
* Its free so clear it
*
        TST.L   (B)+         B = MC addr of first word of block
        TST.L   -(L)         Move L back to an even double word
*
KST7    CLR.L   (B)+         Clear the free block
        CMPA.L  L,B
        BLT.S   KST7         J if more to clear
        BRA.S   KST5         Deal with next block (B = L)
*
KST8    CLR.L   DEBTASK      There is no active DEBUG task yet
*
* Now activate the initial task
*
        MOVE.L  CRNTSK,B        Get the initial TCB pointer
        ADDA.L  B,B
        ADDA.L  B,B             B = MC addr of initial TCB
        MOVE.L  #IPKT,D1        Put the
        ASR.L   #2,D1           BCPL ptr to the startup packet
        MOVE.L  D1,T_WKQ(B)     on its WKQ
*
        BRA     ACTIV           and activate the task
*
*
* Various return sequences used by the kernel
*
BCPLERROR MOVE.L D1,G_RES2(G)   Set RESULT2
ER_ULRET  MOVE  #INTSON,SR      Enable interrupts
ER_RET    CLR.L D1              Set zero result
          JMP   (R)             Return (GETVEC returns through R)
*
*
*
        PAGE
        TTL ** TRIPOS Kernel  -   Routines called as n(S) **

SAVE    MOVEA.L (SP)+,L           Standard save sequence
        MOVEM.L P/L/B,-12(P,D0.L) (put here to be close to RET)
        ADDA.L  D0,P
        MOVEM.L D1-D4,(P)
        JMP     (B)

        PAGE
        RORG    SAVE+128
********************************************************************************
**
**      PB 02-Sep-82
**
**      This is the stack checking routine.  It is called just AFTER the entry
**      subroutine, so as we are already in the new stack frame, the damage will
**      probably have been done !
**
**      This code should be made to run fast !!
**
**      Time is 74 assuming all is OK
**
********************************************************************************

        MOVEA.L 48(A2),A3               G48     = Stackbase.                   8
        ADDA.L  A3,A3                   Make it                                7
        ADDA.L  A3,A3                           BYTE ADDRESS.                  7
        MOVE.L  8(A3),D5                Stackbase ! Co.SEnd = top of stack.    8
        MOVEA.L (SP),A3                 Word after JSR is the max stack used in6
        SUB.L   (A3),D5                 this routine -- subtract it.           5
        SUBQ.L  #8,D5                   Eight words of safety.                 4
* or    SUBI.L  #?,D5                   if more than 8 words wanted.           8
        ASL.L   #2,D5                   Stack pointer is a BYTE ADDRESS,       6
        SUB.L   A1,D5                   so adjust number, and subtract.        4
        BGT     StkOK                   Unless it's positive ...               5
**
**      There is no stack left .....
**      This code need not be fast, as it should rarely be called
**

**      EITHER use the Global routine ABORT
*       MOVE.L  D1,-(SP)                <<<<<<<<<<<<<<< Push D1 (& D0 ?)
*       MOVEQ   #97,D1                  Abort code
*       MOVEQ   #12,D0                  We've only used return info ...
*       MOVEA.L 152(A2),A4              G38     = ABORT
*       JSR     (A5)                    Do it ....
*       MOVE.L  (SP)+,D1                >>>>>>>>>>>>>>> Pop  D1 (& D0 ?)

**      OR do it by steam ...
        MOVEQ   #A_NOSTACK,D0           Abort code
        TRAP    #0                      Abort ....

**
**      Now return, skipping the max stack used word
**
StkOK:  MOVEA.L (SP)+,A3                Address of word after JSR              6
        JMP     4(A3)                                                          5
        PAGE
        RORG    SAVE+256
********************************************************************************
*
*       This is the profile routine
*
*       Time is 19
*
********************************************************************************

        MOVEA.L (SP)+,A3                Get the address of the profile count   6
        ADDQ.L  #1,(A3)                 and increment it.                      8
        JMP     4(A3)                   Return (skipping the count)            5

        PAGE
        RORG    SAVE+384
********************************************************************************
*
*       This is a multiply routine
*
*       Arguments arrive in D6 D7 and result is in D6. Other regs saved.
*
********************************************************************************
        MOVEM.L D4-D5,-(SP)     <<<<<<<<<<<<<<<<<<<<    Push 2 regs     <<<<<<<<
        MOVE.W  D6,D5           Low word into D5
        MOVE.W  D7,D4           Low word into D4
        SWAP    D6              High word into D6
        SWAP    D7              High word into D7
        MULU    D5,D7           D7H * D6L
        MULU    D4,D6           D6H * D7L
        MULU    D4,D5           D6L * D7L
        ADD.W   D7,D6           D7H*D6L + D6H*D7L

        SWAP    D6              Get into high word
        CLR.W   D6              Clear bottom word
        ADD.L   D5,D6           (D7H*D6L + D6H*D7L) << 16  +  D6L*D7L
        MOVEM.L (SP)+,D4-D5     >>>>>>>>>>>>>>>>>>>>    Pop 2 regs      >>>>>>>>
        RTS                     Return to the outside world
        PAGE
        RORG    SAVE+512
********************************************************************************
*       Divide                  32 bit division routine                        *
*                               Args in D7 and D6. No other registers corrupted*
********************************************************************************
        SPC     2
*
*  DIVIDE.      32 bit division routine for BCPL.  Perform  D7  :=  D7/D6
*
SR_DIV
        MOVEM.L D3-D5,-(SP)     Save D3, D4 & D5 on the stack for later
        MOVEQ.L #1,D3           Final sign of result
        TST.L   D7              Set Condition codes on D7
        BPL.S   DIVNN1          Not negative, so no change
        NEG.L   D7              Negate D7
        NEG.L   D3              Negate the sign
DIVNN1  TST.L   D6              Set Condition codes on D6
        BPL.S   DIVNN2          Not negative so no change
        NEG.L   D6              Negate D6
        NEG.L   D3              Negate the sign
DIVNN2  BRA     DIVISION        Do the division.  D7 = quotient, D6 = remainder
        PAGE
        RORG    SAVE+640
********************************************************************************
*       Remainder               32 bit remainder routine                       *
********************************************************************************
        SPC     2
*
*  REMAINDER.   32 bit remainder function for BCPL.  Performs  D6  :=  D7 REM D6
*
SR_REM
        MOVEM.L D3-D5,-(SP)     Save D3, D4 & D5 on the stack for later
        MOVEQ.L #1,D3           Set sign of remainder
        TST.L   D7              Set Condition codes on D7
        BPL.S   REMNN1          Not negative, so no change
        NEG.L   D7              Negate D7
        NEG.L   D3              Negate the sign
REMNN1  TST.L   D6              Set Condition codes on D6
        BPL.S   REMNN2          Not negative so no change
        NEG.L   D6              Negate D6
REMNN2  BRA     DIVISION        Do the division.  D7 = quotient, D6 = remainder

        SPC     5
********************************************************************************
**
**
**      Could put other entries in here ........
**
**
********************************************************************************
        PAGE
********************************************************************************
*       DIVISION                Internal subroutine for DIVIDE and REMAINDER   *
********************************************************************************
        SPC     2
*  DIVISION.    Internal code to do a division.  Restores D5, D4 & D3
*               The result is  D7  :=  D7 / D6   and   D6  :=  D7 REM D6.

*  At this point:
*       D7 = ABS dividend
*       D6 = ABS divisor
*       D3 = 1 or -1

DIVISION
        CLR.L   D5              Will hold the result
        MOVEQ.L #1,D4           Holds a loop count
        TST.L   D6              Is the divisor zero ?
        BEQ.S   DIV4            Yes, so error situation

DIV2    CMP.L   D7,D6           Is D6 >= D7 ?
        BCC.S   DIV1            If so, end of loop
        LSL.L   #1,D6           D6  :=  D6 << 1
        LSL.L   #1,D4           D4  :=  D4 << 1
        BRA.S   DIV2            Loop until finished

DIV1    CMP.L   D6,D7           Is  D7 >= D6 (trial subtraction)
        BCS.S   DIV3            If so, ignore the next bit
        SUB.L   D6,D7           D7  :=  D7 - D6
        ADD.L   D4,D5           Add in the result
DIV3    LSR.L   #1,D6           D6  :=  D6 >> 1
        LSR.L   #1,D4           D4  :=  D4 >> 1
        BNE.S   DIV1            Loop until finished

*  On exit from that little lot,  D7 = remainder,  D5 = Quotient.

DIV4    MOVE.L  D7,D6           Put remainder where it belongs
        MOVE.L  D5,D7           Put quotient where it belongs

*  Now check the sign of the final result.  If the signs were different
*  initially (D3 = -1) then negate D7.

        TST.L   D3              Set condition codes on D3
        BPL.S   DIV5            Not negative, so don't worry
        NEG.L   D7              Negate the quotient
        NEG.L   D6              Negate the remainder
DIV5
        MOVEM.L (SP)+,D3-D5     Restore D3, D4 & D5 to their former glory
        RTS                     And return
        PAGE
        TTL ** TRIPOS   Kernel  -   Task Scheduler **
******************************************************************
*                                                                *
*         The TRIPOS scheduler                                   *
*                                                                *
* On entry at SRCHWK1 the following must hold:                   *
*                                                                *
*         Z  = 0                                                 *
*         B  = MC addr of highest priority task that could run   *
*         S  = MC addr of save sequence                          *
*         R  = MC addr of the return sequence                    *
*     Level  = 7                                                 *
*                                                                *
******************************************************************


SRCHWK  MOVEA.L (B),B           Chain down      1 task
SRCHWK1 MOVE.L  B,CRNTSK        BCPL pointer to current task
        MOVE.L  B,OLDCT         *** Copy in old root node too ***
SRCHWK2 ADDA.L  B,B
        ADDA.L  B,B             B = MC addr of TCB
SRCHWK3 MOVE.W  T_STATEW(B),L   Get the state
        ADDA.L  L,L
        JMP     SRCHTAB(L)      Invoke the appropriate action

* Action to be taken is determined from the task state - each
*  permissible state corresponds to a unique entry in the table
*  for reasons of efficiency the state is not checked.
* (The state is a four bit integer).

SRCHTAB BRA.S   RENTER       0000 Run
        BRA.S   RENTER       0001 Run with pkt
        BRA.S   SRCHWK       0010 Run/held
        BRA.S   SRCHWK       0011 Run with pkt/held
        BRA.S   SRCHWK       0100 Wait
        BRA.S   UNWAIT       0111 Wait with pkt
        BRA.S   SRCHWK       0110 Wait/held
        BRA.S   SRCHWK       0111 Wait with pkt/held
        BRA.S   UNINT        1000 Interrupted
        BRA.S   UNINT        1001 Interrupted with pkt
        BRA.S   SRCHWK       1010 Interrupted/held
        BRA.S   SRCHWK       1011 Interrupted with pkt/held
        BRA.S   SRCHWK       1100 Dead
        BRA.S   ACTIV        1101 Dead with pkt
        BRA.S   SRCHWK       1110 Dead/held
        BRA.S   SRCHWK       1111 Active/held

        PAGE
*
* A task in WAIT state that is not HELD and has received a packet
* is re-entered with D1 = the BCPL pointer to the packet and the
* packet link field set to NOTINUSE (-1).
*
UNWAIT  MOVE.L  T_WKQ(B),D1      D1 = BCPL ptr to       the packet
        MOVEA.L T_SP(B),SP       Set SP for the task
        MOVEM.L (SP)+,P/G              Set P and G for the task
*
UNWAIT1 CLR.W   T_STATEW(B)      Set the task state to 0000
        MOVEA.L D1,L
        ADDA.L  L,L
        ADDA.L  L,L            L = MC addr of the pkt
        MOVE.L  (L),T_WKQ(B)     unlink the packet
        BEQ.S   UNWAIT2        J if the WKQ is now empty
        ADDQ.W  #1,T_STATEW(B)   Change the state       to 0001
*
UNWAIT2 MOVEQ.L #NOTINUSE,D0
        MOVE.L  D0,(L)         Mark the packet not in use
        BRA.S   ULRET
*
* A task that is in a RUN state (ie suspended due to
* QPKT, RELEASE etc) only needs SP, D1, P and G restored.
* Z, S and R are assumed to be correctly set already.

RENTER  MOVEA.L T_SP(B),SP       Restore the task       system stack
        MOVEM.L (SP)+,D1/P/G     Restore D1, P and G
*
ULRET   MOVE    #INTSON,SR       Enable interrupts
*
RET     MOVEM.L -12(P),P/L             This is the standard return seq.
        MOVEA.L -4(P),B
        JMP     (L)

*
* An INTERRUPTED task is reentered here, all the registers and
*    the PSW are restored from the TCB before the task is resumed

UNINT   BCLR    #B_INT,T_STATEB(B)    Clear INTERRUPTED state
        MOVEA.L T_SP(B),SP          Set the task system stack
        MOVEA.L (SP)+,R
        MOVE.L  R,USP               Restore the USP
        MOVEM.L (SP)+,D0-D7/Z-R     Restore D0-D7 and A0-A6
        RTE                                 And return from exception

        PAGE
*
* A dead task with a packet is activated. The size of the global
* vector is calculated, then it and the task,s stack are allocated.
* The globals are the initialised, and finally START is called with
* the packet as argument.
*
* At ACTIV:  B  = MC address of the TCB
*            Z  = 0
*
* Before calling START (global 1) SP, P, G, S, R and D1 must be set
*
*       D0-D7, L, S and R may be used during activation,
*       and P and G are used until they are set.
*       B  = MC address of the TCB throughout
*
ACTIV   LEA.L   T_UPB(B),SP         SP = task's system stack
*                                           (its empty for a dead task)

*  Fix:  IDW  1 Feb 1983.
*
*  We must set the state of the task being activated to "run with packet", so
*  that if an interrupt is taken DURING activation, the activation will be
*  re-entered, rather than a new one being started.

        MOVEQ   #1,D1
        MOVE.L  D1,T_STATE(B)               Set state to 0001

        MOVE    #INTSON,SR                  Change to level 0
*
* B  = MC address of the TCB throughout
*
* D0-D7, L, S and R may be used during activation, and P and G are
* used until they are set to the stack and global vector.
*
*
* First find the required global vector size
*
        MOVEA.L T_SEGL(B),P         Get the segment list
        ADDA.L  P,P
        ADDA.L  P,P                 P = MC addr of SEGL
        MOVE.L  (P)+,D0             D0 = SEGL upb
        ASL.L   #2,D0               now in bytes
        LEA.L   -4(P,D0.L),S        S = MC addr of last entry
        MOVEQ.L #G_MIN,D1                   D1 to hold Gvec size
        BRA.S   ACT4
*
ACT1    MOVE.L  (P)+,R              (P was addr of next entry)
        BRA.S   ACT3A               R = BCPL ptr to first sect
*
*
ACT2    MOVE.L  4(R),D0             D0 = size of new section
        ASL.L   #2,D0               Now in bytes
        CMP.L   0(R,D0.L),D1        J if Gvec size >= the size
        BGE.S   ACT3                  required by this section
        MOVE.L  0(R,D0.L),D1        Yes - update Gvec size
*
ACT3    MOVEA.L (R),R               Next section
ACT3A   ADDA.L  R,R
        ADDA.L  R,R                 R = MC addr of next section
        MOVE.L  R,D0                Test for end of list
        BNE.S   ACT2
*
ACT4    CMPA.L  S,P                 Test for end of SEGL
        BLE.S   ACT1                J if there is another entry
*
* D1 = required size of the global vector in (long) words
*
        MOVE.L  D1,S                S = Gvec UPB
        SUBA.L  G,G                 No Gvec for GETVEC
*
ACT5    LEA.L   ACT6,R              (GETVEC returns through R)
        JMP     GETVEC              Allocate the global vector
*
ACT6    TST.L   D1
        BEQ     ACTERR                J if allocation not successful
        MOVEA.L D1,G
        ADDA.L  G,G
        ADDA.L  G,G                 The G pointer is now set
        MOVE.L  D1,D7               D7 = BCPL ptr to G vector
*
*
* At this point:
*
*         D7 = BCPL ptr to the global vector
*         G  = MC address of the global vector
*         B  = MC address of the TCB
*         S  = Gvec UPB
*    and  Z  = 0
*
        MOVE.L  D7,T_GBASE(B)       Set GBASE in TCB
        MOVEA.L G,P
        MOVE.L  S,(P)+              Set G0 = Gvec size
        ADDA.L  D7,S
        ADDA.L  S,S
        ADDA.L  S,S                 S = MC addr of last Gvec entry
*
        MOVE.L  #$474C0003,D0       Form UNGLOB + 2*1
*
ACT7    MOVE.L  D0,(P)+             Put UNGLOB+2*n in global n
        ADDQ.L  #2,D0
        CMPA.L  S,P
        BLE.S   ACT7                Loop until all done

        MOVE.L  CRNTSK,G_TCB(G)     TCB
        MOVE.L  T_ID(B),G_TASKID(G)    Taskid
*
ACT8    MOVE.L  T_STSIZE(B),D1
        LEA.L   ACT9,R              (GETVEC returns through R)
        JMP     GETVEC              Allocate the stack
ACT9    TST.L   D1
        BEQ     ACTERR              J if allocation not successful
        MOVE.L  D1,G_SBASE(G)       Set STACKBASE global
        MOVE.L  D1,T_SBASE(B)       Set SBASE in TCB
        MOVEA.L D1,P
        ADDA.L  P,P                 Set up the stack
        ADDA.L  P,P
*
        MOVE.L  T_STSIZE(B),D2      Get stack size
        ADD.L   D1,D2               D2 = BCPL ptr to last stk wd
        MOVE.L  D2,L
        ADDA.L  L,L
        ADDA.L  L,L                 L = MC addr of last stk wd
*
        CLR.L   (L)                 Clear the last stack word
*
ACT10   CLR.L   -(L)                Clear the BCPL stack
        CMPA.L  P,L
        BGT.S   ACT10
*
        MOVE.L  #-1,C_CLLR(P)       -1 -> root coroutine
        MOVE.L  D2,C_SEND(P)        Stack end
*
        MOVE.L  T_SEGL(B),D7        D7 = BCPL ptr to SEGL
        MOVE.L  D7,D6
        ASL.L   #2,D6               D6 = MC addr to SEGL
        ADD.L   0(Z,D6.L),D7
        ASL.L   #2,D7               D7 = MC addr of last entry
        LEA.L   ACT11,R             Return link for GLOBIN
*
ACT11   ADDQ.L  #4,D6               D6 = MC addr of next entry
        CMP.L   D6,D7
        BLT.S   ACT12               J if all entries processed
*
* At this point:
*
*      D6 = MC addr of the current entry of SEGL
*      D7 = MC address of the last entry of SEGL
*      Z  = 0
*      R  = MC addr of ACT12 (the return addr for GLOBIN)
*
* GLOBIN only changes D0, D1, D2, D3, B and L
*
*
        MOVE.L  0(Z,D6.L),D1        D1 = BCPL ptr to segment
        JMP     GLOBIN              GLOBIN(seg) rtn to ACT11
*
*
* We are now ready to call START(TASKWAIT())
*
ACT12   LEA.L   SAVE,S              Addr of save routine
        LEA.L   RET,R               Addr of return routine
*
        MOVEA.L G_TWAIT(G),B
        MOVEQ.L #C_FSIZE,D0
        JSR     (S)                 D1 := TASKWAIT()
*
        MOVEA.L G_START(G),B
        MOVEQ   #C_FSIZE,D0         Stack increment
        JSR     (S)                 Now call START(pkt)
*
* Task has finished normally - free its stack and global vector
*
        MOVE    #INTSOFF,SR         Interrupts off
        MOVEA.L CRNTSK,B
        ADDA.L  B,B
        ADDA.L  B,B                 B = MC addr of TCB
*
DEACT   ORI.W   #S_DEAD,T_STATEW(B)   Set DEAD state
        MOVE.L  T_SBASE(B),D1
        CLR.L   T_SBASE(B)          Clear SBASE
        LEA.L   DEACT1,R
        JMP     FREEVEC             Call FREEVEC(stack)
*
DEACT1  MOVE.L  T_GBASE(B),D1
        CLR.L   T_GBASE(B)          Clear GBASE
        LEA.L   DEACT2,R
        JMP     FREEVEC             Call FREEVEC(gbase)
*
DEACT2  LEA.L   SAVE,S              Restore S
        LEA.L   RET,R               Restore R
        MOVEA.L CRNTSK,B
        JMP     SRCHWK2             Re-enter the scheduler
*
*
ACTERR  BSET    #B_HOLD,T_STATEB(B)    Set      the HOLD bit
        MOVE.L  #A_ACTIVATE,D0
        TRAP    #0
        BRA.S   DEACT
*

        PAGE
        TTL ** TRIPOS   Kernel  -  Standalone DEBUG **
****************************************************************
*                                                              *
*         Entry sequence to standalone DEBUG                   *
*                                                              *
****************************************************************
*
*
* At CALLDBG:
*
*    All fields in the debug packet are set appropriately
*    except for DBPTASK and DBPSP.
*    SP points to a the old values of:
*
*         SR and PC(corrected if TRAP13, ADDR or BUS exception)
*
*    Level = 7
*
* CALLDBG first fills in DBPTASK and DBPSP then call the debug code in a
* suitable BCPL environment with the debug packet as argument.
*
EXCPT   MOVE.L  #1,DBPMODE                 Set mode 1 for aborts
*
CALLDBG MOVE.W  (SP),DBWKW                 Get old SR
        ANDI.W  #$0700,DBWKW       Test the old level
        BNE.S   CALLDBG0                   J if it was not level 0
*
        MOVEM.L R/S,-(SP)          Dump R and S
        MOVEA.L CRNTSK,R
        ADDA.L  R,R
        ADDA.L  R,R                R = MC addr of curr TCB
        TST.L   T_PXHAND(R)
        BEQ.S   CALLDBGX           J if no private X handler

        MOVEA.L T_PXHAND(R),S      S = EP of private handler

        JSR     (S)                Enter private handler

CALLDBGX
        MOVEM.L B-Z/D7-D0,-(SP)    Dump remaining registers
        MOVE.L  USP,B
        MOVE.L  B,-(SP)
        MOVE.L  SP,T_SP(R)                 Dump SP in the task's TCB
        BSET    #B_INT,T_STATEB(R)         Set task's INT bit
        MOVE.L  T_ID(R),DBPTASK    Set the task's id in DBGPKT
        BRA.S   CALLDBG1
*
CALLDBG0
        MOVEM.L R-Z/D7-D0,DBPREGS          Dump the complete reg set
        MOVE.L  USP,B
        MOVE.L  B,DBPUSP           Including the USP
        MOVE.L  #-1,DBPTASK        Indicate no task was active
*
CALLDBG1
        MOVE.L  SP,DBPSP                   Plant SP in DBGPKT
        MOVEM.L DEBREGS,Z/P/G/S/R/SP     Set A registers to defaults
        MOVEA.L DEBTASK,B                  Find the DEBUG task
        MOVE.L  B,D0               Test if it exists
        BEQ.S   CALLDBG2                   J if it does not
*
* The DEBUG task does exist so use its global vector
*
        ADDA.L  B,B
        ADDA.L  B,B                B = MC addr of DEBUG's TCB
        MOVEA.L T_GBASE(B),G       Get the Gbase
        ADDA.L  G,G
        ADDA.L  G,G                G = MC addr of global vector
*
CALLDBG2
        MOVE.L  #DBPKT,D1
        ASR.L   #2,D1              D1 = BCPL ptr to DBGPKT
        MOVEQ.L #12,D0
        MOVEA.L 4(G),B
        JSR     (S)                Call START(pkt)
*
* At this point we have just returned from standalone DEBUG.
*
* The value of D1 determines the way execution resumes.
*
*    D1  = 0      Resume normal execution
*       ~= 0      Set the TRACE bit in the saved SR and
*                 then resume execution.  When the traced instruction
*                 is (eventually) executed a trace exception will occur
*                 and this will cause DEBUG to be reentered.
*
        MOVEA.L DBPSP,SP                   Restore SP
        TST.L   DBPTASK
        BGE.S   CALLDBG4                   J if debug task >= 0
*
        TST.L   D1
        BEQ.S   CALLDBG3                   J is normal resumption
*
        BSET    #B_TRACE,(SP)      Set old TRACE bit = 1
*
CALLDBG3
        MOVEA.L DBPUSP,B           Restore the registers
        MOVE.L  B,USP              USP
        MOVEM.L DBPREGS,D0-D7/Z-R  D0 - D7, A0 - A6
        RTE                                and return to a level (~=0)
*
CALLDBG4
        TST.L   D1
        BEQ.S   CALLDBG5                   J if normal resumption
*
        BSET    #B_TRACE,64(SP)    Set TRACE bit in old SR
*
CALLDBG5
        MOVEA.L TCBLIST,B                  Find the highest priority
        BRA     SRCHWK1            task and go to the scheduler
*
        CNOP    0,4
DEBREGS DC.L    0                          Z reg
        DC.L    DEBPPTR            P reg
        DC.L    DEBGPTR            Default G pointer
        DC.L    SAVE               S reg
        DC.L    RET                R reg
        DC.L    DSYSTKB            SP reg
*
DEBGPTR DC.L    0                          This is a global vector
        DC.L    DEBHLT             with containing START
*
DEBHLT  ADDQ.L  #1,D0              Come here if no DEBUG
        BRA.S   DEBHLT             loop for ever.
*
        PAGE
        TTL ** TRIPOS   Kernel  -   Interrupt Handlers **
****************************************************************
*                                                              *
*         Interrupt handlers                                   *
*                                                              *
****************************************************************
*
*
*
* BUS and ADDRESS exceptions
*
*
B_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_BUS,DBPCODE     Bus exception
        BRA.S   A_EXCPT1
*
A_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_ADDRESS,DBPCODE      Addressing exception
A_EXCPT1
        MOVE.W  (SP)+,DBPFCD       R/W, I/N and function code
        MOVE.L  (SP)+,DBPACCA      The faulting access address
        MOVE.W  (SP)+,DBPINS       The instruction register
        MOVE.L  2(SP),DBPPC        PC at the time of the fault
        MOVEM.L R/S/D1,-(SP)       Push R, S and D1
*
* SP now points to the old values of:
*
*         D1, S, R, SR, PC(uncorrected)
*
* Now try to guess the start address of the faulting instruction
* by stepping the old PC backwards until it points to a word
* matching DBPINS.
*
* NOTE that there is no way to make this completely reliable.
*
        MOVEA.L 14(SP),S                   Get the dumped PC
        MOVE.W  DBPINS,R                   Get the instruction register
        CMPA.W  -(S),R
        BEQ.S   A_EXCPT2                   Jump if match
        CMPA.W  -(S),R
        BEQ.S   A_EXCPT2                   Jump if match
        CMPA.W  -(S),R
        BEQ.S   A_EXCPT2                   Jump if match
        CMPA.W  -(S),R
        BEQ.S   A_EXCPT2                   Jump if match
        TST.W   -(S)               It must be the next
A_EXCPT2 MOVE.L S,14(SP)                   store the corrected PC
*
* Now check for ACCA = UNGLOB + 2*n for 1<=n<=10000
* Ie did the faulting access address look like an unset global.
*
        MOVE.L  DBPACCA,D1
        SUB.L   #UNGLOB,D1                 D1 = ACCA - UNGLOB
        BLE.S   A_EXCPT3                   J if n<1
        LSR.L   #1,D1                      D1 = (ACCA-UNGLOB)/2 (=n)
        CMP.L   #10000,D1                  Compare with 10000
        BGT.S   A_EXCPT3                   J if n> global vector size
*
* It was almost ceraintly an unset global variable.
*
        MOVE.L  D1,DBPARG                  Put n in the DEBUG pkt
        MOVE.L  #A_UNDEFGLOB,DBPCODE       Abort code (unset global)
*
A_EXCPT3 MOVEM.L (SP)+,D1/S/R      Pop D1, S and R  for CALLDBG
        BRA     EXCPT
*
* BREAKPOINTS enter here (from TRAP 13)
*
TRP13   MOVE    #INTSOFF,SR        Change to level 7
        SUBQ.L  #2,2(SP)                   Adjust the old PC
        MOVE.L  #2,DBPMODE                 Set the debug mode = 2
        MOVE.L  2(SP),DBPARG       Move brk pt addr into DBGPKT
        BRA     CALLDBG            Call debug
*
* T_EXCPT is reached just after an intruction has been executed
* with the TRACE bit set.
T_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        BCLR    #B_TRACE,(SP)      Set old TRACE bit = 0
        MOVE.L  #3,DBPMODE                 Set debug mode = 3
        MOVE.L  2(SP),DBPARG       Set arg in DBGPKT to old PC
        BRA     CALLDBG            Single step entry in DEBUG
*
*
I_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_ILLINSTR,DBPCODE        Illegal instruction
        BRA     EXCPT
*
D_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_DIVIDE,DBPCODE   Divide check
        BRA     EXCPT
*
C_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_CHECK,DBPCODE           CHECK instruction failed
        BRA     EXCPT
*
P_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_PRIV,DBPCODE    Privilige exception
        BRA     EXCPT
*
O_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_TRAPV,DBPCODE           TRAPV failed
        BRA     EXCPT
*
X_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_L1010,DBPCODE           L1010 exception
        BRA     EXCPT
*
Y_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_L1111,DBPCODE           L1111 exception
        BRA     EXCPT
*
S_EXCPT MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_SPURIOUS,DBPCODE Spurious interrupt
        BRA     EXCPT
*
* INT1          (used by the clock)
INT2
INT3
INT4
INT5
INT6
NODEVINT MOVE   #INTSOFF,SR        Change to level 7
        MOVE.L  #A_IOINT,DBPCODE           Unused interrupts
        BRA     EXCPT
*
INT7    MOVE    #INTSOFF,SR       Change to level 7
        MOVE.L  #A_CONSOLE,DBPCODE
        BRA     EXCPT

TRP0    MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  D0,DBPCODE                 KLIB and Driver aborts
        MOVE.L  D1,DBPARG                  Store code and arg in DBGPKT
        BRA     EXCPT
*
TRP1
TRP2
TRP3
TRP4
TRP5
TRP6
TRP7
TRP8
TRP9
TRP10
TRP11
TRP12
*TRP13    Used for break points
TRP14
TRP15
        MOVE    #INTSOFF,SR        Change to level 7
        MOVE.L  #A_UNUSEDTRAP,DBPCODE      Unused TRAPs
        BRA     EXCPT
*
SADEB   MOVE    #INTSOFF,SR        Change to level 7
        PEA.L   SADEB              Push an SP/PC pair
        MOVE.W  #$2700,-(SP)       on the system stack
        CLR.L   DBPMODE            Set DEBUG mode = 0
        BRA     CALLDBG            and call DEBUG
*
*
*
        PAGE
****************************************************************
*                                                              *
*                       JSR      TCBSET                        *
*                       JSR      TCBSET1                       *
*                                                              *
* TCBSET1 will find the TCB for a given taskid.                *
* TCBSET does the same having changed to level 7 and moving    *
*        its argument from D1 to D0.                           *
*                                                              *
* On entry: D1 = taskid (for TCBSET)  entered at level 0       *
*           D0 = taskid (for TCBSET1) entered at level 7       *
*                                                              *
* On exit:  B  = MC addr of the corresponding TCB if it exists *
*              = 0  otherwise                                  *
*                                                              *
* Changes:  D0, B                                              *
*                                                              *
****************************************************************

TCBSET  MOVE    #INTSOFF,SR     Interrupts      off
        MOVE.L  D1,D0        Move BCPL first arg to D0
*
TCBSET1 TST.L   D0                   Test Taskid
        BLE.S   TCBSET2      J if taskid<=0
        MOVEA.L TASKTAB,B            Get task table
        ADDA.L  B,B
        ADDA.L  B,B          B = MC addr of the tasktable
        CMP.L   (B),D0       Compare taskid with upb
        BGT.S   TCBSET2      J if taskid too large
        ASL.L   #2,D0
        MOVEA.L 0(B,D0.L),B      Get TCB (or possibly zero)
        ADDA.L  B,B
        ADDA.L  B,B          B = MC addr of TCB (or 0)
        RTS                          Return
*
TCBSET2 SUBA.L     B,B       Id error return with B = 0
        RTS

        PAGE
****************************************************************
*                                                              *
*                   JSR      MOVPKT                            *
*                                                              *
* This subroutine moves a packet to the end of of the          *
* destination task work Q. It sets the pasket recieved bit     *
* in the task status and compares the priority to that of the  *
* currently highest priority task that could run.  The id      *
* field of the pkt is set to the id of the sender.             *
* MOVPKT must be called at level 7                             *
*                                                              *
* On entry: D1 = BCPL pointer to the packet                    *
*           D2 = Id of the sender                              *
*           D6 = MC addr of original TCB (not used by MOVPKT)  *
*           D7 = MC addr of highest pri runnable TCB (HTCB)    *
*           Z  = 0                                             *
*           B  = MC addr of the packet (4*D1)                  *
* On exit:  D7 = the old value of D7                           *
*             or MC addr of destination TCB (if higher pri)    *
*           B  = MC addr of destination TCB (or 0 if id error) *
* Changes:  B, L, D0, D7                                       *
*                                                              *
****************************************************************
*
MOVPKT  MOVE.L  B,L          L = MC addr of pkt
        MOVE.L  P_ID(L),D0           Get the destination Id
        JSR     TCBSET1      Locate TCB
        MOVE.L  B,D0         B = MC addr of the dest TCB
        BEQ.S   MOVPKT3      Error (CC.Z is set)
        MOVE.L  D2,P_ID(L)           Record sender
        CLR.L   (L)          Clear link
        BSET    #B_PKT,T_STATEB(B)       and set PKT bit
        LEA.L   T_WKQ(B),L           L = MC addr of start of wkq
*
MOVPKT1 TST.L   (L)          Test the link field
        BEQ.S   MOVPKT2      J if empty
        MOVE.L  (L),L        L = BCPL ptr to next pkt
        ADDA.L  L,L
        ADDA.L  L,L          L = MC addr of next pkt
        BRA.S   MOVPKT1
*
MOVPKT2 MOVE.L  D1,(L)       Append the pkt
        MOVE.L  T_PRI(B),D0     D0      = pri of dest TCB
        CMP.L   T_PRI(Z,D7.L),D0        compare it with HTCB
        BLE.S   MOVPKT3      J if <=, ie no task swap
        MOVE.L  B,D7         otherwise update D7
*
MOVPKT3 RTS                          (CC.R only set if Id error)
*
        PAGE
******************************************************************
*                                                                *
*               JMP  INTRET1                                     *
*                                                                *
* This is the common return routines for interrupt routines that *
* have not caused the release of a packet and so have not caused *
* a higher priority task to be runnable.  It is, however,        *
* possible that some other interrupt routine interrupted the     *
* current interrupt routine and released a packet to a higher    *
* priority task.  If this has happend HTCB will contain the MC   *
* address of the higher priority task and this must be inspected *
* before returning to level 0.                                   *
*                                                                *
* On entry: SP = MC addr of SR and PC                            *
*                                                                *
******************************************************************
*
INTRET1 TST.L   HTCB
        BEQ.S   INTRTE              J if HTCB = 0 (and execute RTE)
        MOVE.W  (SP),WORKW                  Get the old status register
        ANDI.W  #$0700,WORKW        Inspect its level field
        BNE.S   INTRTE              J if non zero (and execute RTE)
        MOVEM.L R-Z/D7-D0,-(SP)     Dump all but the USP
*
INTSUSP MOVE.L  USP,B               Dump the USP
        MOVE.L  B,-(SP)
        MOVEA.L CRNTSK,B
        ADDA.L  B,B
        ADDA.L  B,B                 B = MC addr of CRNTSK
        MOVE.L  SP,T_SP(B)                  Dump SP in the TCB
        BSET    #B_INT,T_STATEB(B)          Mark the TCB INTERRUPTED
        MOVEA.L HTCB,B
        LEA.L   SAVE,S              Restore S
        LEA.L   RET,R               Restore R
        SUBA.L  Z,Z                 Clear Z
        MOVE.L  B,D1
        ASR.L   #2,D1               D1 = BCPL ptr to TCB to run
        MOVE.L  D1,CRNTSK
        MOVE.L  D1,OLDCT            *** Put in old root node too ***
        CLR.L   HTCB                (HTCB must be clear a level 0)
        BRA     SRCHWK3             Enter the scheduler
*
        PAGE
******************************************************************
*                                                                *
*         JMP        INTRET2                                     *
*                                                                *
* This is the common return routine for interrupt routines which *
* may have moved packets to tasks of higher priority than the    *
* current task.  If D7 differs from D6 then D7 is the MC address *
* of a TCB of higher priority than the current TCB, if the D7 TCB*
* is of higher priority than HTCB then HTCB is updated.  If the  *
* current interrupt interrupted a task and HTCB is non zero then *
* the return is made through the scheduler, otherwise the return *
* is made by a RTE instruction.                                  *
*                                                                *
* On entry: D6 = MC addr of the old TCB                          *
*           D7 = MC addr of a TCB of higher or equal priority    *
*            Z = 0                                               *
*           SP = MC addr of the complete register dump in the    *
*                old TCB (note that the USP is NOT yet dumped).  *
*        Level = 7                                               *
*                                                                *
******************************************************************

INTRET2 CMP.L   D6,D7
        BEQ.S   INTRET5             J if no re-scheduling rqd
        MOVE.L  HTCB,D5
        BEQ.S   INTRET3             J if HTCB=0
        MOVE.L  T_PRI(Z,D5.L),D1
        CMP.L   T_PRI(Z,D7.L),D1            Compare priorities
        BGE.S   INTRET4             J if HTCB pri >= D7 pri
*
INTRET3 MOVE.L  D7,HTCB             Update HTCB with higher pri TCB
*
INTRET4 MOVE.W  60(SP),WORKW        Get the old status register
        ANDI.W  #$0700,WORKW        Test the level field
        BEQ.S   INTSUSP             J if returning to level 0
*
INTRET5 MOVEM.L (SP)+,D0-D7/Z-R     Restore all but the USP
INTRTE  RTE                                 and return from the interrupt
*
        PAGE
        TTL ** TRIPOS   Kernel   -   Clock device **
***************************************************************************
*
CLKCNTL EQU     $FFE000+6*1024  CLOCK control word address
*
INITCLK MOVE.W  #1,CLKCNTL      Enable clock interrupts
        RTS
*
*
****************************************************************
*                                                              *
* Real time clock interrupt service routine                    *
* The absolute time is incremented and any expired packets     *
* on the timer WKQ are moved to the calling tasks. If any of   *
* the tasks has a higher priority than the current task then   *
* the task scheduler is entered.                               *
*                                                              *
****************************************************************

INT1    MOVE    #INTSOFF,SR     Set level 7 as soon as possible
*
        MOVE.L  R,-(SP)         Obtain a work register
*
        MOVEA.L #TICKS,R        R = MC addr of timer words
        ADDQ.L  #1,(R)          Inc TICKS
        CMPI.L  #MTICKS,(R)     End of minute?
        BLT.S   CLOCK1          No
        CLR.L   (R)             Yes reset the TICKS
        ADDQ.L  #1,-(R)         Inc MINS
        CMPI.L  #60*24,(R)      End of day?
        BLT.S   CLOCK1          No
        CLR.L   (R)             Clear the mins
        ADDQ.L  #1,-(R)         Inc days
*
CLOCK1
        MOVE.L  DAYS,OLDDAYS    **** Copy time to old root node ****
        MOVE.L  MINS,OLDMINS    **** Copy time to old root node ****
        MOVE.L  TICKS,OLDTICK   **** Copy time to old root node ****
        TST.L   CLKWQ
        BEQ.S   CLOCK2          J if the clock WKQ is empty
*
        MOVEA.L CLKWQ,R
        ADDA.L  R,R
        ADDA.L  R,R             R = MC addr of first pkt on WKQ
        SUBQ.L  #1,P_RES1(R)    Decrement ticks-left in first pkt
        BLE.S   CLOCK3          J if expired
CLOCK2  MOVEA.L (SP)+,R         Restore the work register
        BRA     INTRET1         and return from the interrupt
*
* A clock packet has expired and so will have to be sent back to its
* task.  The current task will likely to end up in an interrupted
* state, so optimise this case.
*
CLOCK3  MOVEM.L S-Z/D7-D0,-(SP)         Dump the remaining registers
*                                       into the old task's TCB
*
* Set up the registers for MOVPKT
*
        MOVE.L  R,D1            (R = MC addr of expired clk pkt)
        ASR.L   #2,D1           D1 = BCPL ptr to the pkt
        MOVEQ.L #-1,D2          D2 = the clock device id
        MOVE.L  CRNTSK,D6
        ASL.L   #2,D6           D6 = MC addr of the old TCB
        MOVE.L  D6,D7           D7 = MC addr of HTCB (the highest
*                                          priority runnable TCB)
        SUBA.L  Z,Z             Z = 0
        MOVEA.L R,B             B = MC addr of the pkt
*
* These are exactly the conditions required by MOVPKT
*
CLOCK4  MOVE.L  (B),CLKWQ       Remove the pkt from the clk WKQ
        JSR     MOVPKT          and send it back to its task
        MOVE.L  CLKWQ,D1        D1 = BCPL ptr to next clk pkt
        BEQ     INTRET2         Return from int if no more clock pkts
        MOVEA.L D1,B
        ADDA.L  B,B
        ADDA.L  B,B             B = MC addr of next pkt (not = 0)
        TST.L   P_RES1(B)
        BLE.S   CLOCK4          J if it too has expired
*
        BRA     INTRET2         J to return from interrupt rtn
        PAGE
        TTL ** TRIPOS   Kernel   -   Primitive routines **
******************************************************************
*                                                                *
*                         GLOBIN(SEG)                            *
*                                                                *
* This function initialises the globals defined in the given     *
* segment. It returns -1, or 0 if an error is detected - an      *
* attempt to initialise a global beyond the upperbound given in  *
* GLOBSIZE. GLOBIN is defined in KLIB since it is called from    *
* the scheduler in ACTIV.                                        *
*                                                                *
* GLOBIN must return via register R since this is assumed in     *
* ACTIV.                                                         *
*                                                                *
* GLOBIN changes:  D0, D1, D2, D3, B and L                       *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Globin '
*
GLOBIN  MOVEQ.L #-1,D0        Success flag initialized to TRUE
*
GLOBIN0 ASL.L   #2,D1
        BEQ.S   GLOBIN3       J if end of section list
        MOVEA.L D1,B          B  = MC addr of the section
        MOVE.L  (B)+,D1       D1 = BCPL ptr to next sect (or 0)
        MOVE.L  (B),D2        D2 = the section length in words
        ASL.L   #2,D2         Now in bytes
        LEA.L   -4(B,D2.L),L     L      = MC addr of MAXGLOB word
*
GLOBIN1 MOVE.L  -(L),D2       D2 = entry relative ptr
        BEQ.S   GLOBIN0       J if end of Gn/Ln pairs
        MOVE.L  -(L),D3       D3 = the global number (n say)
        BLE.S   GLOBIN2       Error if n < 0
        CMP.L   (G),D3
        BGT.S   GLOBIN2       Error if n too big
        ADD.L   B,D2          D2 = MC addr of entry
        ASL.L   #2,D3         D3 = Gvec subscript in bytes
        MOVE.L  D2,0(G,D3.L)     Put entry      address in global n
        BRA.S   GLOBIN1       Deal with next Gn/Ln pair
*
GLOBIN2 CLR.L   D0                    Indicate error in flag
        MOVE.L  #A_GLOBIN,G_RES2(G)   Set RESULT2
        JMP     GLOBIN1       Continue with the next pair
*
GLOBIN3 MOVE.L  D0,D1         Return flag as result
        JMP     (R)

        PAGE
******************************************************************
*                                                                *
*                 RES := GETVEC(UPPERBOUND)                      *
*                                                                *
* This function is BCPL callable.                                *
* Returns the BCPL pointer to a vector with at least the given   *
* upper bound. (In fact the upper bound is rounded up to the     *
* next even number) The word at offset -1 of the vector contains *
* the length of the store block and should not be touched by the *
* user. Runs at level 7 but returns to level 0 each time round   *
* the search loop, which can be lengthy.  It may be called       *
* from machine code using R as the return address.  If no global *
* vector has been set up then G must be zero.                    *
*                                                                *
* GETVEC must return via register R since this is assumed in     *
* ACTIV.                                                         *
*                                                                *
* GETVEC changes: D0, D1, D2, D3, D4 and L                       *
*                                                                *
* On return:                                                     *
*      RES ~= 0    OK                                            *
*      RES  = 0    Error                                         *
*                  RESULT2 = 103    Insufficient store           *
*                                                                *
* Abort 197        Block list corrupt                            *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Getvec '
*
GETVEC  ADDQ.L  #1,D1           True vector size
        BSET    #0,D1           Round up to odd number
        ADDQ.L  #1,D1           Block size = vec size + 1
        ASL.L   #2,D1           Block size in Bytes
        BLE     GVC7            Error if negative
        MOVE.L  CRNTSK,D0       D0 = CRNTSK throughout
        MOVE    #INTSOFF,SR     Change to level 7
*
GVCRTY  MOVE.L   D0,GVTSK       Record the caller task
        MOVE.L   BLKLIST,L
        ADDA.L   L,L
        ADDA.L   L,L            L = MC addr of BLKLIST
*
GVC1    MOVE     #INTSON,SR     Change to level 0 (briefly)

* At this point interrupts are enabled. If any other task is run
* and calls GETVEC then GVTSK will be reset, and the search must
* restart from the beginning of the block list in case it has
* been updated meanwhile.

        MOVE     #INTSOFF,SR    Disable interrupts
        CMP.L    GVTSK,D0       Test to see if another task has
        BNE.S    GVCRTY         called GETVEC, start again if so
*
* Search down the chain for a free block and
*        amalgamate any adjacent free areas.
*
        MOVE.L   (L),D2         D2 = size+marker of block
        BLE.S    GVC6           End of list (or error)
        BTST    #0,D2           Test the marker
        BNE.S    GVC2           J if the block is free
        ASL.L    #2,D2          D2 = size of block in bytes
        ADDA.L   D2,L           L = MC addr of next block
        BRA.S    GVC1           Continue down list
*
GVC2    MOVE.L   L,D3           D3 = MC addr of free blk
*
GVC3    ASL.L    #2,D2          D2 = size in bytes
        ADDA.L   D2,L           L  = MC addr of next blk
        MOVE.L   -(L),D2        Get size and marker of next block
        BMI.S    ERRSTORE       Jump if loop in free store
        BTST    #0,D2           Test the marker
        BNE.S    GVC3           Jump if block free



*
* Now D0 = CRNTSK
*     D1 = size required in bytes
*     D3 = MC addr of start of free area
*     L  = MC addr of end of area

GVC4    MOVE.L   L,D2
        SUB.L    D3,D2          D2 = amalgamated size in bytes
        MOVE.L   D2,D4
        ASR.L    #2,D4          D4 = amalgamated size in words
        ADDQ.L   #1,D4          Set marker
        MOVE.L   D4,0(Z,D3.L)   Amalgamate free blocks
*
        SUB.L    D1,D2          Split block
        BLT.S    GVC1           Can't be done
        BEQ.S    GVC5           Exact fit
        SUBA.L   D2,L           L = MC addr of upper part
        ASR.L    #2,D2
        ADDQ.L   #1,D2          D2 = size of upper part + marker
        MOVE.L   D2,(L)         Plant in upper block
*
GVC5    ASR.L    #2,D1          BCPL size of allocated block
        MOVE.L   D1,0(Z,D3.L)   Plant the size
        MOVE.L   D3,D1
        ASR.L    #2,D1
        ADDQ.L   #1,D1          D1 = BCPL ptr to allocated vec
*
        MOVE     #INTSON,SR     Change to level 0
        JMP      (R)            and return
*
GVC6    BMI.S    ERRSTORE       Loop in free store
*
GVC7    MOVE.L   G,D0
        TST.L    D0             If no global
        BEQ      ER_ULRET       then cannot set RESULT2
        MOVE.L   #A_GETVEC,D1   Insufficient store
        BRA      BCPLERROR      Error return
*
ERRSTORE
        MOVE     #A_STORECHAIN,D0       Abort code
        TRAP     #0             Error TRAP
        BRA      GVCRTY         Try again
        PAGE
******************************************************************
*                                                                *
*                           FREEVEC(V)                           *
*                                                                *
* This BCPL callable routine frees the vector V, which should    *
* have been obtained from GETVEC. It aborts the task if an error *
* is detected. If the vector is zero the call has no effect.     *
* No BCPL stack or Global vector are required.                   *
* It runs at any level.                                          *
*                                                                *
* FREEVEC must return via register R since this is assumed in    *
* ACTIV.                                                         *
*                                                                *
* Abort 199     Illegal FREEVEC (Even address given [it is       *
*               assumed elsewhere that GETVEC gives an ODD       *
*               result], or block not allocated).                *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Freevec'
*
FREEVEC TST.L   D1
        BEQ.S   FVC1            Return if V = 0
        BTST    #0,D1           Check argument is odd
        BEQ.S   FVC2            Illegal argument
        MOVEA.L D1,L
        ADDA.L  L,L
        ADDA.L  L,L             L = MC addr of word 0 of V
        MOVE.L  -(L),D1         D1 = size + marker
        ANDI.L  #$FFC00001,D1   Test that it is of form:
        BNE.S   FVC2            0000 0000 00dd dddd ... dddd ddd0
        ADDQ.L  #1,(L)          Set the marker to allocated
FVC1    JMP     (R)             and return
*
FVC2    MOVE    #A_ILLFREEVEC,D0        Illegal FREEVEC
        TRAP    #0              Error TRAP
        JMP     (R)

        PAGE
******************************************************************
*                                                                *
*                 ID :=  CREATEDEV(DCB)                          *
*                                                                *
* This function creates a device using the first free slot in the*
* device table. The DCB should have already been linked to a     *
* device driver.                                                 *
*                                                                *
* On return:                                                     *
*    ID = the device id (<0)                                     *
*       = 0      Error                                           *
*                RESULT2 = 104   Device table full               *
*                RESULT2 = 106   Failure to initialise device    *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Created'
*
CRDEV   MOVE    #INTSOFF,SR      Change to      level 7
        MOVE.L  DEVTAB,B              Get device table
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of DEVTAB
        MOVE.L  (B)+,D0       D0 = upb of DEVTAB
        ASL.L   #2,D0
        LEA.L   -4(B,D0.L),L     L      = MC addr of last entry
*
        MOVEQ   #-1,D2        Skip device 1(clock)
        TST.L   (B)+          B = MC addr of next entry
*
* At CRD1: D1 = BCPL ptr to the DCB
*          D2 = the id (<0) of an existing device
*          B  = MC addr of next entry in DEVTAB
*          L  = MC address of the last entry of DEVTAB
*
CRD1    CMPA.L  L,B           Test for end of DEVTAB
        BGT.S   CRD2          J if DEVTAB full
        SUBQ.L  #1,D2         D2 = id of the next device
        TST.L   (B)+          Test if the slot is empty
        BNE.S   CRD1          No - try again
*
        MOVE.L  D1,-(B)       Put the DCB in the slot
*
* Now call the device INIT routine
*
        MOVEA.L D1,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of the DCB
        MOVEA.L (B),L
        ADDA.L  L,L
        ADDA.L  L,L           L = MC addr of the driver
        MOVEA.L D_INIT(L),L      L      = MC addr of INIT routine
*
        MOVE.L  D2,D_ID(B)            Set id in DCB
        CLR.L   D_WKQ(B)              Clear work Q
*
* On entry to a device INIT routine:
*
*         Z = 0
*         B = MC addr of the DCB
*
* It must preserve D1, D2 Z, P, G, S and R
*
        JSR     (L)           Call the device INIT routine
*
        TST.L   D1
        BEQ.S   CRD3          J if unable to initialise the device
*
        MOVE.L  D2,D1         Set the result = the device id
        BRA     ULRET         Unlock and return
*
CRD2    MOVEQ   #A_DEVTABFULL,D1              Device table full
        BRA     BCPLERROR             Error
*
CRD3    MOVEQ   #A_DEVINIT,D1         Cannot initialise the device
        BRA     BCPLERROR

        PAGE
******************************************************************
*                   DCB := DELETEDEV(DEVID)                      *
*                                                                *
* This function deletes a device, which must have an empty WKQ.  *
* On return:                                                     *
*    DCB = BCPL ptr to the DCB (~=0)                             *
*    DCB = 0    Error                                            *
*               RESULT2 = 101      Invalid id                    *
*               RESULT2 = 107      Work queue not empty          *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Deleted'
*
DELDEV  MOVE    #INTSOFF,SR      Change to      level 7
        MOVE.L  DEVTAB,L              Get the device table
        ADDA.L  L,L
        ADDA.L  L,L           L = MC addr of DEVTAB
        NEG.L   D1                    D1 = the device number (>0)
        BLE     IDERROR         J if illegal id
        CMP.L   (L),D1        Compare with devtab UPB
        BGT     IDERROR         J if invalid id
        ASL.L   #2,D1
        MOVE.L  0(L,D1.L),D2     D2 = BCPL      ptr to DCB
        BEQ     IDERROR         No such device
        MOVEA.L D2,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of DCB
        TST.L   D_WKQ(B)              Examine the WKQ
        BNE.S   DELD1         J if it is not empty
        CLR.L   0(L,D1.L)             Clear the entry in DEVTAB
        MOVEA.L (B),L
        ADDA.L  L,L
        ADDA.L  L,L           L = MC addr of the driver
        MOVE.L  D_UNIN(L),L      L      = entry to UNIN routine
*
* On entry to a device UNIN routine:
*
*         Z = 0
*         B = MC addr of the DCB
*        D2 = BCPL ptr to the DCB
*
* The UNIN routine must preserve:
*
*         D2, Z, P, G, S and R
*
        JSR     (L)           Call the device UNIN routine
*
        MOVE.L  D2,D1         D1 = BCPL ptr to the DCB
        BRA     ULRET         Unlock and return
*
DELD1   MOVEQ   #A_WORKQ,D1           Device not deleteable
        BRA     BCPLERROR

        PAGE
******************************************************************
*                                                                *
*            ID := CREATETASK(SEGLIST,STSIZE,PRI)                *
*                                                                *
* This function creates a task using the first free slot in the  *
* task table. It gets space for a copy of the segment list and a *
* TCB and initialises them, and inserts the TCB in the task table*
* and priority chain.                                            *
*                                                                *
* On return:                                                     *
*    ID = the id of the created task (>0)                        *
*    ID = 0      Error                                           *
*                RESULT2 = 102   Invalid priority                *
*                RESULT2 = 103   Insufficient store              *
*                RESULT2 = 105   Task table full                 *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Createt'
*
CRTSK   MOVE.L  D1,D5         D5 = BCPL ptr to SEGL (or 0)
        MOVE.L  D2,D6         D6 = the stack size
        MOVE.L  D3,D7         D7 = the priority
        BLE     PRERR        J if priority <= 0

        ASL.L   #2,D5         D5 = MC addr of SEGL (or 0)
        BEQ.S   CRT2          A null segment list is OK
*
* Now make a new copy of SEGL
*
        MOVE.L  0(Z,D5.L),D1     D1 = the upb of SEGL
        MOVEQ   #20,D0        Make a BCPL call
        MOVEA.L G_GVEC(G),B
        JSR     (S)           D1 := GETVEC(upb)
*
* GETVEC does not change: D5, D6 or D7
*
        TST.L   D1                    Test the result
        BEQ     ER_RET        J if GETVEC failed
*
        MOVE.L  D5,B          B  = MC addr of old SEGL
        MOVE.L  (B),D0        upb (in words)
        ASL.L   #2,D0
        ADD.L   B,D0          D0 = MC addr of last entry
*
        MOVE.L  D1,D5         D5 = BCPL ptr to new SEGL
        MOVEA.L D5,L
        ADDA.L  L,L
        ADDA.L  L,L           L  = MC addr of new SEGL
*
CRT1    MOVE.L  (B)+,(L)+             Copy a SEGL entry
        CMP.L   B,D0          Test for end
        BGE.S   CRT1          J if more to copy
*
CRT2    MOVE.L  #TCBSIZE,D1      TCB size in words
        MOVEQ   #20,D0        Make a BCPL call
        MOVEA.L G_GVEC(G),B
        JSR     (S)           Call GETVEC(tcb.upb)
*
        TST.L   D1                    D1 = BCPL ptr to new TCB (or =0)
        BEQ     CRT7          J if allocation failed
*
* Search the TASKTAB for an empty slot.
*
        MOVE.W  #INTSOFF,SR      Change to      level 7
        MOVEA.L TASKTAB,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of TASKTAB
        MOVE.L  (B)+,D0       D0 = the upb in words
        CLR.L   D4                    Clear taskid counter
*
CRT3    ADDQ.L  #1,D4         D4 = next task id to consider
        CMP.L   D0,D4         Compare with upb
        BGT.S   CRT8          J if TASKTAB is full
        TST.L   (B)+          Test the slot
        BNE.S   CRT3          J if the slot is in use
*
* Fill the slot and initialise the TCB
*
CRT4    MOVE.L  D1,-(B)       Plant ptr to TCB into TASKTAB
*
        MOVE.L  D1,D2
        ASL.L   #2,D2         D2 = MC addr of new TCB
        MOVEA.L D2,B          B = MC addr of new TCB
*
        CLR.L   (B)+          Link
        MOVE.L  D4,(B)+       Id
        MOVE.L  D7,(B)+       Priority
        CLR.L   (B)+          Work Q
        MOVE.L  #S_DEAD,(B)+     State
        CLR.L   (B)+          Flags
        MOVE.L  D6,(B)+       Stsize
        MOVE.L  D5,(B)+       Seglist
        CLR.L   (B)+          Gbase
        CLR.L   (B)+          Sbase
        CLR.L   (B)+          SP (not set for a DEAD task)
        CLR.L   (B)+          Private exception handler
*
* Now link the task into the (priority ordered) TCBLIST.
*
        LEA.L   TCBLIST,B             B = MC addr TCBLIST 1st link word
*
CRT5    MOVEA.L B,L           MC addr of current link word
        MOVEA.L (L),B         B = BCPL ptr to next TCB (or 0)
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of next TCB
        CMP.L   T_PRI(B),D7      Compare priorities
        BLT.S   CRT5          J if requested pri is lower
        BEQ.S   CRTX          Disallow equal priorities
*
        MOVE.L  (L),0(Z,D2.L)    Insert into TCBLIST
        MOVE.L  D1,(L)        (D1 is BCPL ptr to TCB)
*
        MOVE.L  D4,D1         Resultis id
        JMP     ULRET         Unlock and return
*
CRTX    MOVE.L  TASKTAB,D3            Find task table entry
        ADD.L   D4,D3         Add in the taskid
        ASL.L   #2,D3         D3 = MC addr of TASKTAB entry
        CLR.L   0(Z,D3.L)             Clear the slot
        MOVE.L  #A_INVALIDPRIO,G_RES2(G)
*
CRT6    MOVEQ   #20,D0        (D1 = BCPL ptr to new TCB)
        MOVEA.L G_FVEC(G),B
        JSR     (S)           Call FREEVEC(the new tcb)
*
CRT7    MOVE.L  D5,D1         D1 = the new SEGL
        MOVEQ   #20,D0
        MOVEA.L G_FVEC(G),B
        JSR     (S)           Call FREEVEC(the new segl)
*
        JMP     ER_ULRET              Error return
*
CRT8    MOVE.L  #A_TASKTABFULL,G_RES2(G)   Task table full
        BRA.S   CRT6
*
PRERR   MOVEQ   #A_INVALIDPRIO,D1             Invalid priority
        JMP     BCPLERROR
        PAGE
******************************************************************
*                                                                *
*               RES := DELETETASK(TASKID)                        *
*                                                                *
* This function deletes a task which must have an empty work Q   *
* and either be the current task, or be dead. Its segment list   *
* is freed and the TCB removed from the task table and the       *
* priority chain and then freed. If it was the current task then *
* the task deactivation code is entered to free the stack and    *
* global vector.                                                 *
*                                                                *
* On return:                                                     *
*    RES ~= 0   OK                                               *
*    RES  = 0   Error                                            *
*               RESULT2 = 101   Invalid id                       *
*               RESULT2 = 108   Task not deletable               *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Deletet'
*
DELTSK  JSR     TCBSET        B  = MC addr of the TCB
*                                     D1 = taskid (still)
        MOVE.L  B,D0          D0 = MC addr of the TCB
        BEQ     IDERROR       J if invalid task id
        BTST    #B_PKT,T_STATEB(B)
        BNE.S   DELT4         J if WKQ not empty
        MOVE.L  B,D7
        LSR.L   #2,D7         D7 = BCPL ptr to TCB
        CMP.L   CRNTSK,D7
        BEQ.S   DELT1         J if it is the current task
        CMPI.W  #S_DEAD,T_STATEW(B)
        BNE.S   DELT4         J if held or not dead
*
* Unlink the tcb and free it
*
DELT1   ADD.L   TASKTAB,D1            (D1 was the taskid)
        ASL.L   #2,D1         D1 = MC addr of TASKTAB entry
        CLR.L   0(Z,D1.L)             Clear task table slot
*
        LEA.L   TCBLIST,B             Top of TCB chain
*
DELT2   MOVEA.L B,L           L = MC addr of latest link word
        MOVEA.L (B),B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of next TCB
        CMPA.L  D0,B          Compare with TCB being deleted
        BNE.S   DELT2         J if not yet found
*
DELT3   MOVE.L  (B),(L)       Remove it from the TCBLIST
*
        MOVE.L  T_SEGL(B),D1 D1 = BCPL ptr      to SEGL
        MOVEQ   #20,D0
        MOVEA.L G_FVEC(G),B
        JSR     (S)           BCPL call of FREEVEC(segl)
*
        MOVE.L  D7,D1         D1 = BCPL ptr to TCB
        MOVEQ   #20,D0
        MOVEA.L G_FVEC(G),B
        JSR     (S)           BCPL call of FREEVEC(tcb)
*
        MOVEQ   #-1,D1        Set non zero (success result)
        CMP.L   CRNTSK,D7             Deleting current task?
        BNE     ULRET         No  - unlock and return
*
* The current TCB has just been returned to freestore, but it
* is safe from corruption until execution returns to level 0.
*
        ASL.L   #2,D7
        MOVEA.L D7,B            B = MC addr of the current
        MOVE.L  (B),CRNTSK      (the link field is still valid)
        MOVE.L  (B),OLDCT       *** Put in old root node too ***
*
* We now go to the scheduler via DEACT, freeing the global vector
* and stack on the way.  BCPL pointers to these vector are in
* the (deleted but temporally uncorruptible) old current TCB.
*
        JMP     DEACT         Deactivate
*
DELT4   MOVEQ   #A_TASKDELETE,D1              Task not deletable
        BRA     BCPLERROR
*
        PAGE
******************************************************************
*                                                                *
*                RES := CHANGEPRI(TASKID,PRI)                    *
*                                                                *
* This routine alters the priority of a task. Its TCB is moved to*
* the new position in the priority chain, and the task scheduler *
* entered if necessary.                                          *
*                                                                *
* On return:                                                     *
*    RES ~= 0     OK                                             *
*    RES  = 0     Error                                          *
*                 RESULT2 = 101    Invalid id                    *
*                 RESULT2 = 102    Invalid priority              *
*                                                                *
******************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Changep'
*
CHNGPRI JSR     TCBSET        B = MC addr of the TCB
        MOVE.L  B,D0          Test whether the TCB exists
        BEQ     IDERROR       J if invalid id
        TST.L   D2                    Check valid priority
        BLE     PRERR         Invalid priority
*
* Find the TCB in TCBLIST (and its previous link word)
*
        LEA.L   TCBLIST,B             B = MC addr of start of TCBLIST
*
CHNGP1  MOVEA.L B,L           L = MC addr of latest link word
        MOVEA.L (B),B         Chain down one
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of next TCB
        CMP.L   B,D0
        BNE.S   CHNGP1        J if not found yet
*
        MOVE.L  (B),(L)       Remove TCB from TCBLIST
        MOVE.L  L,D7          Save old position

        LEA.L   TCBLIST,B             Top of TCB chain
*
* At this point:
*
*     D0 = MC addr of TCB
*     D1 = taskid
*     D2 = new priority
*     D7 = MC addr of TCB
*      B = MC addr of first link word of TCBLIST
*
* Now insert the TCB in correct position in the TCBLIST
*
CHNGP2  MOVE.L  B,L           L = MC addr of latest link word
        MOVE.L  (B),B         Chain down one
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of next TCB
        CMP.L   T_PRI(B),D2      Compare priorities
        BLT.S   CHNGP2        J if new pri is less than its pri
*
        BEQ     CHNGP5        Equal priorities are NOT allowed
*
        MOVE.L  T_PRI(Z,D0.L),D6 D6 = old priority
        MOVE.L  D2,T_PRI(Z,D0.L) Set new priority
*
        MOVE.L  (L),0(Z,D0.L)    Link into      the chain
        LSR.L   #2,D0         D0 = BCPL ptr to TCB
        MOVE.L  D0,(L)        Complete insertion
*
        MOVEA.L CRNTSK,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of the current TCB
        MOVE.L  T_PRI(B),D3      D3 = current priority
*
* At this point:
*
*         D1 = the taskid of the TCB whose priority has been changed
*              (a suitable non zero result for CHANGEPRI)
*         D2 = the new priority
*         D3 = the (new?) priority of the current task
*         D6 = the old priority
*         D7 = MC addr of the link word in the TCBLIST that used to
*                 contains a ptr to the changed TCB
*          B = MC addr of the current task
*          L = MC addr of the link word in the TCBLIST that now
*                 contains a ptr to the changed TCB
*
        CMP.L   D3,D2
        BEQ.S   CHNGP3        J if new pri = current pri
*
* We have just changed the priority of a task other than CRNTSK
* There a six possible cases to consider (using N, O and C to denote
* the new, current task, and old priorities respectively):
*
* The only case that may causes a suspension is: N > C > O
*
        BLT     ULRET         J if new pri < curr pri (no swap)
*
        CMP.L   D3,D6
        BGT     ULRET         J if old pri > curr pri (no swap)
*
* The current task must be suspended and the scheduler entered.
*
* At this point: L = MC addr of the link word that now contains a
* pointer to the changed TCB.
*
        BRA.S   CHNGP4        Suspend self and enter scheduler
*
* At CHNGP3 we have just changed the priority of the current task
*
CHNGP3  CMP.L   D6,D2
        BGE     ULRET         J if newpri >= oldpri   (no swap)
*
* The current task is now at a lower priority than it was, so suspend
* it and enter the scheduler searching the TCBLIST from its old link
* word position.  The suspension may turn out not to be necessary, but
* this case is not worth optimising.
*
        MOVEA.L D7,L
*
*         L  = MC addr of a link word that used contain a pointer to
*                 the current task
*         B  = MC addr of the current TCB
*
CHNGP4  MOVEM.L G/P/D1,-(SP)     Dump D1, P and G
        MOVE.L  SP,T_SP(B)            and SP in the old TCB
        MOVEA.L (L),B         B = BCPL ptr to the highest
*                                         priority TCB that can
*                                         run unless it is held.
        BRA     SRCHWK1       Go to the scheduler
*
CHNGP5  LSR.L   #2,D0         Relink
        MOVE.L  D0,0(Z,D7.L)     At old position
        BRA     PRERR
*
*
        PAGE
*****************************************************************
*                                                               *
*                 RES := SETFLAGS(TASKID,FLAGS)                 *
*                                                               *
* Sets TCB flags of the specified task.                         *
*                                                               *
* On return:                                                    *
*    RES ~= 0    OK                                             *
*    RES  = 0    Error                                          *
*                RESULT2 = 101    Invalid id                    *
*                                                               *
*****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Setflag'
*
SETFLG  JSR     TCBSET        Set B = MC addr of the TCB
        MOVE.L  B,D1          Test for taskid error
        BEQ.S   IDERROR       J if bad taskid
        OR.L    D2,T_FLAGS(B)    OR in the      flags
        BRA     ULRET         Unlock and return

IDERROR MOVEQ   #A_INVALIDID,D1       Can't find the task given
        BRA     BCPLERROR             Put in the RES2 and return


        PAGE
*****************************************************************
*                                                               *
*               RES := TESTFLAGS(FLAGS)                         *
*                                                               *
* Tests and clears the flags of the current task.               *
* On return:                                                    *
*    RES  = FALSE (=0)  None of the specified flags were set    *
*    RES  = TRUE (-1)   At least one specified flag was set     *
*    RESULT2 = the flags that were cleared                      *
*                                                               *
*****************************************************************

        CNOP    0,4
        DC.L    LIBWORD       BCPL header
        DC.B    7,'Testfla'
*
TSTFLG  MOVE.W  #INTSOFF,SR      Interrupts off
        MOVEA.L CRNTSK,B              Get current task
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of current TCB
        MOVE.L  T_FLAGS(B),D2    Save the flags
        NOT.L   D1
        AND.L   D1,T_FLAGS(B)    Clear specified bits
        NOT.L   D1
        AND.L   D2,D1         Get the cleared bits
        MOVE.L  D1,G_RES2(G)     Store them in RES2
        BEQ     ULRET         Return -1 or 0
        MOVE.L  #-1,D1
        BRA     ULRET

        PAGE
*****************************************************************
*                                                               *
*                          ABORT(CODE,ARG)                      *
*                                                               *
* This BCPL callable routine aborts the current task and enters *
* debug in standalone mode with arguments CODE, ARG.            *
*                                                               *
*                                                               *
*****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Abort  '
*
ABORT   MOVE.L  D1,D0         This TRAP is specially for
        MOVE.L  D2,D1         aborts.
        TRAP    #0
        JMP     (R)

        PAGE
****************************************************************
*                                                              *
*                  RES := HOLD(TASKID)                         *
*                                                              *
* This function sets the HOLD bit in the TCB of the specified  *
* task.  It enters the scheduler if it holds itself.           *
*                                                              *
* On return:                                                   *
*    RES ~= 0    OK                                            *
*    RES  = 0    Error                                         *
*                RESULT2 = 110   Task already held             *
*                                                              *
****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Hold   '
*
HOLD    JSR     TCBSET        Set B = MC addr of TCB
        MOVE.L  B,D0          Test if it exists
        BEQ     IDERROR       Invalid id
        BSET    #B_HOLD,T_STATEB(B)  Test and set the HOLD      bit
        BNE.S   HOLD1         J if already held
        MOVE.L  CRNTSK,L
        ADDA.L  L,L
        ADDA.L  L,L           L = MC addr of the current TCB
        CMPA.L  L,B           Compare current with held TCB
        BNE     ULRET         J if not holding self
*
        MOVEM.L G/P/D1,-(SP)     Suspend self
        MOVE.L  SP,T_SP(B)
        BRA     SRCHWK        and search for lower pri work
*
HOLD1   MOVEQ   #A_TASKHELD,D1        The task was already held
        BRA     BCPLERROR
*
        PAGE
****************************************************************
*                                                              *
*                RES := RELEASE(TASKID)                        *
*                                                              *
* This function releases a held task. The task scheduler is    *
* used to select the next task to run.                         *
*                                                              *
* On return:                                                   *
*    RES ~= 0    OK                                            *
*    RES  = 0    Error                                         *
*                RESULT2 = 101   Invalid id                    *
*                                                              *
****************************************************************


        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Release'
*
RELEASE JSR     TCBSET        Locate the TCB
        MOVE.L  B,D0          B = MC addr of TCB (or 0)
        BEQ     IDERROR       J if taskid error
        BCLR    #B_HOLD,T_STATEB(B)  Clear      the HOLD bit
*
        MOVEA.L CRNTSK,B              Now suspend the current task
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of current TCB
        MOVEM.L G/P/D1,-(SP)     Dump D1,P,G
        MOVE.L  SP,T_SP(B)            and SP in current TCB
        MOVEA.L TCBLIST,B             (Not worth optimising)
        BRA     SRCHWK1       Enter the scheduler

        PAGE
****************************************************************
*                                                              *
*                PKT := TASKWAIT()                             *
*                                                              *
* This is a BCPL callable function of no arguments. The current*
* task is suspended as long as it has an empty work queue.     *
* When the task resumes execution (which may be immediately    *
* the result (PKT) will be the (dequeued) first packet of the  *
* task's work queue.                                           *
*                                                              *
****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Taskwai'
*
TASKWAI MOVE    #INTSOFF,SR      Change to      level 7
        MOVEA.L CRNTSK,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of the current TCB
        MOVE.L  T_WKQ(B),D1      Test the WKQ
        BNE     UNWAIT1       J if there is a packet
*
* A task which voluntarily suspends itself in TASKWAIT need only dump P and G
* in the current TCB. All the other registers are permitted to have
* different values when the procedure eventually resumes.
*
        BSET    #B_WAIT,T_STATEB(B)  Set the WAIT bit = 1
        MOVEM.L G/P,-(SP)             Dump P and G in current TCB
        MOVE.L  SP,T_SP(B)            Dump task's SP (state now = 0100)
        BRA     SRCHWK        Find a lower pri task to run
*
        PAGE
****************************************************************
*                                                              *
*                 RES := QPKT(PKT)                             *
*                                                              *
* This BCPL  callable function queues the pkt onto the work Q  *
* of its destination task or device.                           *
* Packet offset P_ID > 0 -> destination is a task              *
*                    = -1->     ..      .. clock               *
*                    < -1->     ..      .. a device            *
* If the pasket is Qed successfully then the task # of the     *
* sender is inserted in this field.                            *
*                                                              *
* On return:                                                   *
*    RES ~= 0    OK                                            *
*    RES  = 0    Error                                         *
*                RESULT2 = 101   Invalid id                    *
*                                                              *
****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Qpkt   '
*
QPKT    MOVE    #INTSOFF,SR      Interrupts off
        MOVE.L  D1,D5
        ASL.L   #2,D5         D5 = MC addr of the pkt
        CMPI.L  #NOTINUSE,P_LINK(Z,D5.L)
        BNE     ERRQPKT       J unless pkt not in use
        MOVE.L  CRNTSK,D6
        ASL.L   #2,D6         D6 = MC addr of current TCB
        MOVE.L  D6,D7         D7 = highest pri runnable TCB
        MOVE.L  T_ID(Z,D6.L),D2  D2 = the taskid of sender
        MOVE.L  P_ID(Z,D5.L),D3  D3 = the destination id
*
* At this point:
*
*         D1 = BCPL ptr to the packet
*         D2 = the current task's id (the sender's id)
*         D3 = the destination id
*         D5 = MC addr of the packet
*         D6 = MC addr of the current TCB
*         D7 = D6 (the highest priority runnable TCB)
*         Z, P, G, R and S are set
*
        CMPI.L  #-1,D3        Examine destination
        BGT.S   QPTSK         > -1 is a task
        BLT.S   QPDEV         < -1 is a device

*
* At QPCLK a packet for the clock is processed.  The packet must be
* inserted at the correct place in the clock WKQ.  Clock packets
* requesting delays of <=0 ticks are returned immediately.
* case : the pkt is returned  immediately. The RES1 field is set
* to contain the number of ticks that must elapse between the
* previous packet on the CLKWKQ being released and this one.
*
*
QPCLK   MOVE.L  D2,P_ID(Z,D5.L)  Record sender
        MOVE.L  P_A1(Z,D5.L),D4  D4 = the tick count
        BLE.S   QPCLK4        Delay <= 0 return pkt now
        LEA.L   CLKWQ,B       B = MC addr of first WKQ link word
*
QPCLK1  MOVE.L  B,L           L = MC addr of latest link word
        MOVEA.L (B),B         Chain down one
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of next clock pkt
        MOVE.L  B,D0
        BEQ.S   QPCLK3        J if end of list reached
*
        SUB.L   P_RES1(B),D4     Subtract this packet's ticks
        BGE.S   QPCLK1        J if ticks to go is still >=0
*
        ADD.L   P_RES1(B),D4     Add the ticks back in again
*
* Prepare to insert the clock packet at this point in the list by
* correcting the ticks count of the packet that is here.
*
        SUB.L   D4,P_RES1(B)     Correct ticks count of next pkt
*
QPCLK3  MOVE.L  D4,P_RES1(Z,D5.L) Plant ticks count (<=0)
        MOVE.L  (L),0(Z,D5.L)    Link the packet in at the      point
        MOVE.L  D1,(L)
*
        BRA     ULRET         Unlock and return

QPCLK4  MOVE.L  D4,P_RES1(Z,D5.L) Plant calculated      ticks count
        MOVEQ   #-1,D2        Send pkt back to the sender
*                                     immediately as if from the clock
*
* destination is a task.invalid destination 0 will be trapped in MOVPKT
*
QPTSK   MOVEA.L D5,B          B = MC addr of the packet
        JSR     MOVPKT        Send the packet to a task
*
* At this point:
*
*         D1 = BCPL ptr to the pkt
*         D6 = BC addr of the current TCB
*         D7 = MC addr of the highest priority TCB that in
*                 runnable (if its not held)
*         B  = MC addr of the destination TCB (or 0 if iderror)
*
        MOVE.L  B,D0
        BEQ     IDERROR       J if invalid taskid
        CMP.L   D6,D7
        BEQ     ULRET         Return if no task change required
*
QPTSAV  MOVEM.L G/P/D1,-(SP)     Suspend the current TCB
        MOVE.L  SP,T_SP(Z,D6.L)  by dumping D1,P, G and SP
        LSR.L   #2,D7
        MOVEA.L D7,B          B = BCPL ptr to higher pri TCB
        BRA     SRCHWK1
*
* At QPDEV the destination is a device, and the registers are:
*
*         D1 = BCPL pointer to the packet
*         D2 = the id of the current TCB
*         D3 = the device id
*         D5 = MC addr of the packet
*         D6 = MC addr of the current TCB
*         D7 = MC addr of the highest priority TCB that is
*                 runnable (if it is not held)
*         Z, P, G, R and S are set
*
QPDEV   MOVEA.L DEVTAB,B
        ADDA.L  B,B
        ADDA.L  B,B           B = MC addr of DEVTAB
        MOVE.L  D3,D0
        NEG.L   D0                    Deviceids are -ve
        CMP.L   (B),D0        compare with table UPB
        BGT     IDERROR       J if invalid id
        ASL.L   #2,D0
        MOVE.L  0(B,D0.L),D0     D0 = BCPL      ptr to the DCB
        BEQ     IDERROR       J if invalid id
        ASL.L   #2,D0
        MOVEA.L D0,B          B = MC addr of DCB
        LEA.L   D_WKQ(B),L            L = MC addr of first link word
*
        MOVE.L  D2,P_ID(Z,D5.L)  record sender
        CLR.L   P_LINK(Z,D5.L)   clear link field
*
        TST.L   (L)           Test the device WKQ
        BNE.S   QPDEV1        J if it is not empty
        MOVE.L  D1,(L)        Put pkt on WKQ (at the head)
        MOVE.L  D3,D2         D2 = dev id (for MOVPKT)
*
* The packet was sent to a device with an empty WKQ and so the
* device start routine must be called.
*
        MOVEA.L D_START(B),L    L = MC addr of the start rtn
*
* The registers are now suitable for the device start routine.
*
*         D1 = BCPL ptr to the pkt
*         D2 = the device id (in case START calls MOVPKT)
*         D6 = MC addr of the current TCB
*         D7 = MC addr of the highest priority runnable TCB
*         Z  = 0
*         B  = MC addr of the DCB
*         L  = MC addr of the device start routine
*
        JSR     (L)             Start the device
*
* Even if the device sent back the packet immediately, the current
* task is still the one to run.
*
        MOVEQ   #-1,D1          Return success value
        BRA     ULRET           Return from QPKT
*
*
* The device WKQ was not empty so append the packet to it.
*
QPDEV1  MOVEA.L (L),L
        ADDA.L  L,L
        ADDA.L  L,L             L = MC addr of next link word
        TST.L   (L)
        BNE.S   QPDEV1          J unless end of WKQ reached
*
        MOVE.L  D1,(L)          Plant the pkt in last link word
*
        BRA     ULRET           Unlock and return
*
ERRQPKT MOVE.W  #INTSON,SR              Change to level 0
        MOVE.L  #A_PKTINUSE,D0          packet in use
        TRAP    #0                      Error TRAP
*
        JMP     (R)

         PAGE
****************************************************************
*                                                              *
*                 ID :=    DQPKT(ID,PKT)                       *
*                                                              *
* Attempts to dequeue PACKET from the work Q of the specified  *
* device or task. If not found there then it attempts to remove*
* the pkt from the work Q of the calling  task.                *
*                                                              *
* On return:                                                   *
*    ID (~=0) = Id of device or task whose WKQ contained the   *
*               packet                                         *
*    ID = 0     Error                                          *
*               RESULT2 = 101   Invalid id                     *
*               RESULT2 = 109   Packet not found               *
* (The ID field of the packet is set to the id of the WKQ on   *
* in which the packet was found provided that this is not the  *
* id of the current task.)                                     *
*                                                              *
****************************************************************

        CNOP    0,4
        DC.L    LIBWORD
        DC.B    7,'Dqpkt  '
*
DQPKT   MOVE    #INTSOFF,SR     Interrupts      off
        CMPI.L  #-1,D1  Device clock task?
        BGT.S   DQPTSK          > - 1 for a task
        BEQ.S   DQPCLK          = - 1 for clock
*
* Packet expected to be on device work Q
*
DQPDEV  MOVE.L  DEVTAB,B
        ADDA.L  B,B
        ADDA.L  B,B             B = MC addr of DEVTAB
        MOVE.L  D1,D0   Make devid      +ve
        NEG.L   D0              D0      = positive device number
        CMP.L   (B),D0          Compare this with table UPB
        BGT     IDERROR         J if invalid device id
        ASL.L   #2,D0           D0      = byte offset in DEVTAB
        MOVE.L  0(B,D0.L),D3    Get the DCB
        BEQ     IDERROR         J if invalid id
        ASL.L   #2,D3           D3      = MC addr of DCB
        LEA.L   D_WKQ(Z,D3.L),B B = MC addr to WKQ      head
        BRA.S   PKTDQ           Search in device WKQ
*
        PAGE
*
* packet expected to be on the clock work Q
*
DQPCLK  LEA.L   CLKWQ,B         B = MC addr of clock WKQ head
        CLR.L   D3              No      TCB or DCB
        BRA.S   PKTDQ
*
* packet expected to be on the task work Q
*
DQPTSK  MOVE.L  D1,D0   D0      = taskid
        JSR     TCBSET1         Locate the      TCB
        MOVE.L  B,D3            D3      = MC addr of the TCB
        BEQ     IDERROR         J if invalid id
        LEA.L   T_WKQ(B),B              B = MC addr of WKQ      head
*
*
* Now try to find the pkt on the WKQ.
*
* At PKTDQ:  D1 = id of device or task
*       D2      = BCPL ptr to the packet
*       D3      = MC addr of the DCB or TCB (=0 for the clock)
*        B      = MC addr of WKQ head
*
*        Z, P, G, R and S are set
*
PKTDQ   MOVE.L  (B),D0  Get next pkt
        BEQ.S   DQPCNT          J if no more packets
        CMP.L   D0,D2           Compare with the pkt we want
        BEQ.S   PKTFND          J if pkt found
        ASL.L   #2,D0
        MOVEA.L D0,B            B = MC addr of non-matching pkt
        BRA.S   PKTDQ
*
* pkt not found. Try the current task, unless we were  looking at
* the current task's work Q already.
*
DQPCNT  MOVE.L  CRNTSK,D0
        ASL.L   #2,D0           D0      = MC addr of current TCB
        MOVE.L  T_ID(Z,D0.L),D1 D1      = id of current task
        CMP.L   D0,D3           Were we searching CRNTSK's      WKQ?
        BNE.S   DQPTSK          No      - try current task
*
        MOVEQ   #A_PKTNOTFOUND,D1               DQPKT failed to find the packet
        BRA     BCPLERROR               Plant error number      in RESULT2
*
*
* The packet has been found.  Reset the pkt id field unless it was
* found on the WKQ of the current task.
*
PKTFND  MOVE.L  D2,D4
        ASL.L   #2,D4           D4      = MC addr of pkt
        MOVE.L  CRNTSK,D0
        ASL.L   #2,D0           D0      = MC addr of current TCB
        CMP.L   D0,D3           Were we searching CRNTSK's      WKQ?
        BEQ.S   PKTF1           J if yes and do not change      id
        MOVE.L  D1,P_ID(Z,D4.L) Reset id in the packet
*
PKTF1   CMPI.L  #-1,D1          Task clock      device?
        BGT.S   DQFTSK          Task
        BEQ.S   DQFCLK          Clock
*
* found on a  device Q .  If it was the head pkt the device stop routine
* is called, the pkt unlinked, and if there are any more pkts the device
* start routine is called.
*
DQFDEV  CMP.L   D_WKQ(Z,D3.L),D2 Compare pkt with WKQ head      pkt
        BNE.S   DQPRET          J unless it was the head pkt
        EXG     D1,D2
        MOVEA.L    D3,B         B = MC addr of DCB
        MOVEA.L    D_STOP(B),L     L = MC addr of DEV.STOP rtn
*
* At this point:
*
*         D1 = BCPL pointer to the packet
*         D2 = devid
*         B  = MC addr of the DCB
*         L  = MC addr of stop routine
*
        JSR     (L)             Stop the device
*
* D1, D2 and B are not changed by device stop routines.
*
        ASL.L   #2,D1           D1      = MC addr of the pkt
        MOVE.L  0(Z,D1.L),D3    D3      = BCPL ptr to next pkt
        MOVE.L  #NOTINUSE,0(Z,D1.L)  Mark the pkt not in use
        MOVE.L  D3,D_WKQ(B)     Unlink the      pkt
        BNE.S   DQFDEV1         J if more pkts
        MOVE.L  D2,D1   D1      = the device id
        BRA     ULRET
* DQFDEV1 move from here ....
*
* found on the clock Q. The next pkt must be corrected.
*
DQFCLK  MOVE.L  0(Z,D4.L),D3    D3 = BCPL ptr to next clock pkt
        BEQ.S   DQPRET          J if no clock pkt to correct
        ASL.L   #2,D3           D3 = MC addr of the next pkt
        MOVE.L  P_RES1(Z,D4.L),D0       Correct the
        ADD.L   D0,P_RES1(Z,D3.L)       ticks to go field
*
DQPRET  MOVE.L  0(Z,D4.L),(B)           Unlink the pkt and
        MOVE.L  #NOTINUSE,0(Z,D4.L)     mark it not in use
        BRA     ULRET
*
*  found on a task work Q. If it was the only pkt then the pkt bit
*  must be cleared in the task state
*
DQFTSK  MOVE.L  0(Z,D4.L),(B)           Unlink the      packet and
        MOVE.L  #NOTINUSE,0(Z,D4.L)     mark it not in use
        TST.L   T_WKQ(Z,D3.L)           Check if the WKQ now empty
        BNE     ULRET                   J if not
        BCLR    #B_PKT,T_STATEB(Z,D3.L) Clear the PKT bit
        BRA     ULRET
* to here ...
*
* There are more packet(s) on the device WKQ, so the device start
* routine must be called.
*
DQFDEV1 MOVE.L  D3,D1   D1      = BCPL ptr to the pkt
        MOVE.L  CRNTSK,D6
        ASL.L   #2,D6           D6      = MC addr of the CRNTSK
        MOVE.L  D6,D7   and so is D7 (for MOVPKT)
        MOVE.L  D_START(B),L    L = MC addr of device start rtn
*
        JSR     (L)             Restart the device
*
        MOVE.L  D2,D1
        CMP.L   D6,D7           Check whether to enter the      scheduler
        BEQ     ULRET           J if CRNTSK is to continue      running
        BRA     QPTSAV          Suspend CRNTSK and      enter the scheduler
        PAGE
**********************************************************************
*                                                                    *
*                       Globals to be initialised                    *
*                                                                    *
**********************************************************************


        CNOP    0,4
GLOBEND DC.L    0                           End of the global list

        DC.L    G_GLOBIN/4,(GLOBIN-KLIB)
        DC.L    G_GVEC/4,(GETVEC-KLIB)
        DC.L    G_FVEC/4,(FREEVEC-KLIB)
        DC.L    G_CDEV/4,(CRDEV-KLIB)
        DC.L    G_DDEV/4,(DELDEV-KLIB)
        DC.L    G_CTASK/4,(CRTSK-KLIB)
        DC.L    G_DTASK/4,(DELTSK-KLIB)
        DC.L    G_CPRI/4,(CHNGPRI-KLIB)
        DC.L    G_SFLAGS/4,(SETFLG-KLIB)
        DC.L    G_TFLAGS/4,(TSTFLG-KLIB)
        DC.L    G_ABORT/4,(ABORT-KLIB)
        DC.L    G_HOLD/4,(HOLD-KLIB)
        DC.L    G_RELEASE/4,(RELEASE-KLIB)
        DC.L    G_TWAIT/4,(TASKWAI-KLIB)
        DC.L    G_QPKT/4,(QPKT-KLIB)
        DC.L    G_DQPKT/4,(DQPKT-KLIB)

        DC.L    G_GLOBMAX/4                     Highest referenced global

KEND    END


