xROMID 810
xTITLE SURAK :System&User Rpl Algorithms Kernel
xCONFIG KERNELCnfg
EXTERNAL xKERNEL
EXTERNAL xNEWPROCESS
EXTERNAL xTRANSFER
EXTERNAL xTERMINATE
EXTERNAL InsertCall
EXTERNAL InitRSTK
EXTERNAL PopRSTK
EXTERNAL PushRSTK
EXTERNAL InitTempEnv
EXTERNAL PopTempEnv
EXTERNAL PushTempEnv
EXTERNAL StopKernel

DEFINE RROLL PTR 14F2A

LABEL KERNELCnfg
::
 #32A
 XEQSETLIB
;

ASSEMBLE
	CON(1)  8
RPL
xNAME KERNEL
::
 CKN
 NULL{}
 DUP
 NULL::
 >TCOMP
 >TCOMP
 ONEONE
 NULL{}
 DUPONE
 >TCOMP
 '
 {
  LAM ProcList
  LAM ActiveProc
  LAM TimeRef
  LAM TempEnvList
  LAM PIDList
 }
 BIND
 ZERO_DO
 xNEWPROCESS
 LOOP
 InitRSTK
 InitTempEnv
 LAM TempEnvList
 PopTempEnv
 DUPUNROT
 >TCOMP
 '
 LAM TempEnvList
 STO
 PushTempEnv
 BEGIN
 ONE
 LAM PIDList
 LAM ActiveProc
 #1+DUP
 LAM PIDList
 LENCOMP
 ::
  #>case
  ::
   DROP
   TWO
  ;
 ;
 DUP'
 LAM ActiveProc
 STO
 NTHCOMDDUP
 #0=ITE
 2DROP
 ::
  xTRANSFER
 ;
 LAM PIDList
 INNERCOMP
 ONE_DO
 #+
 LOOP
 #1=
 UNTIL
 StopKernel
;

ASSEMBLE
	CON(1)  8
RPL
xNAME NEWPROCESS
::
 CK1&Dispatch
 EIGHT
 ::
  NULL{}
  SWAP
  >TCOMP
  NULL::
  >TCOMP
  LAM ProcList
  SWAP
  >TCOMP
  '
  LAM ProcList
  STO
  InitTempEnv
  LAM TempEnvList
  PopTempEnv
  >TCOMP
  '
  LAM TempEnvList
  STO
  LAM PIDList
  DUPLENCOMP
  #1+DUP
  UNROT
  >TCOMP
  '
  LAM PIDList
  STO
  ONESWAP
  '
  ::
   SysTime
   LAM TimeRef
   bit-
   HXS 3 003
   HXS>=HXS
   %0<>
  ;
  InsertCall
 ;
 SIX
 ::
  SAFE@_HERE
  NcaseSIZEERR
  COLA
  xNEWPROCESS
 ;
;

ASSEMBLE
	CON(1)  8
RPL
xNAME TRANSFER
::
 CK2
 ::
  DUPTYPEBINT?
  OVER
  TYPEBINT?
  ANDNOTcase
  ::
   $ "Error:\nInvalid Process Index"
   DO$EXIT
  ;
  LAM ProcList
  LENCOMP
  #1+
  2DUP
  #<
  4PICK
  ROT
  #<
  ANDNOTcase
  ::
   $ "Error:\nUndefined Process"
   DO$EXIT
  ;
 ;
 SysTime
 '
 LAM TimeRef
 STO
 PopTempEnv
 3PICK
 LAM TempEnvList
 PUTLIST
 '
 LAM TempEnvList
 STO
 LAM TempEnvList
 OVER
 NTHCOMPDROP
 PushTempEnv
 '
 {
  LAM Origen
  LAM Destino
 }
 BIND
 PopRSTK
 {}N
 LAM Origen
 LAM ProcList
 PUTLIST
 DUP'
 LAM ProcList
 STO
 LAM Destino
 NTHCOMPDROP
 INNERCOMP
 PushRSTK
 ABND
;

ASSEMBLE
	CON(1)  8
RPL
xNAME TERMINATE
::
 CK0
 ZERO
 LAM ActiveProc
 LAM PIDList
 PUTLIST
 '
 LAM PIDList
 STO
 NULL{}
 NULL::
 >TCOMP
 LAM ActiveProc
 LAM ProcList
 PUTLIST
 '
 LAM ProcList
 STO
 LAM ActiveProc
 ONE
 xTRANSFER
;

NULLNAME InsertCall
::
 ZEROZERO
 '
 {
  LAM Origen
  LAM Destino
  LAM Condicion
  LAM RDepth
  LAM LMeta
 }
 BIND
 '
 LAM ProcList
 SAFE@_HERE
 NcaseSIZEERR
 LAM Condicion
 LAM Destino
 >TCOMP
 LAM Origen
 >TCOMP
 '
 ROT
 >TCOMP
 '
 case
 >TCOMP
 '
 xTRANSFER
 >TCOMP
 '
 2DROP
 >TCOMP
 '
 LAM Condicion
 STO
 LAM Destino
 NTHCOMPDROP
 INNERCOMP
 DUP
 '
 LAM RDepth
 STO
 ZERO_DO
 DUPNULLCOMP?
 ?SKIP
 ::
  INNERCOMP
  DUP
  '
  LAM LMeta
  STO
  ZERO_DO
  LAM LMeta
  ROLL
  DUP'
  {
   BEGIN
   AGAIN
   LOOP
   x<<
   x>>
   xNEXT
  }
  matchob?
  ITE
  ::
   LAM Condicion
   SWAP
   LAM LMeta
   #1+
   '
   LAM LMeta
   STO
  ;
  DROP
  LOOP
  LAM LMeta
  ::N
 ;
 ISTOP@
 ROLL
 LOOP
 LAM RDepth
 {}N
 LAM Destino
 LAM ProcList
 PUTLIST
 '
 LAM ProcList
 STO
 ABND
;

NULLNAME InitRSTK
::
 NULL::
 >R
 RSWAP
;

NULLNAME PopRSTK
::
 ZERO
 1LAMBIND
 BEGIN
 THREE
 PTR 14F2A
 R>
 1GETLAM
 #1+
 1PUTLAM
 DUPNULLCOMP?
 UNTIL
 1GETABND
;

NULLNAME PushRSTK
::
 ZERO_DO
 >R
 THREE
 DUP
 PTR 14F2A
 PTR 14F2A
 LOOP
;

NULLNAME InitTempEnv
::
 ZERO
 '
 {
  LAM StopTempEnv
 }
 BIND
;

NULLNAME PopTempEnv
::
 ZERO
 BEGIN
 ::
  NULL{}
  DUP
  TEN
  BEGIN
  GETLAMPAIR
  NOT
  WHILE
  ::
   4ROLLSWAP
   >HCOMP
   UNROT
   4ROLLSWAP
   >HCOMP
   UNROT
   TEN
   #+
  ;
  REPEAT
  DROP
  ABND
  ROT#1+
 ;
 UNROTDUP
 '
 {
  LAM StopTempEnv
 }
 EQUAL
 4ROLLSWAP
 UNTIL
 #2*
 {}N
;

NULLNAME PushTempEnv
::
 INNERCOMP
 #2/
 ZERO_DO
 SWAPINCOMP
 #1+ROLL
 BIND
 LOOP
;

NULLNAME StopKernel
::
 PopRSTK
 NDROP
 PopTempEnv
 DROP
 ABND
 $ "Kernel Terminated"
 FlashMsg
;