INCLUDE  "SS0302S_SSOWNF"
! %RECORDFORMAT SSOWNF(%INTEGER SSMONAD,DIAGMON)
! %EXTRINSICRECORD(SSOWNF) SSOWN
! 
!
! Template primitives.
! ======== ==========
!
! The following entities are recognised:
! a) Routine/fn parameters.
! I - Integer, print value in decimal
! i - Integer, print value in hex
! L - Longinteger, print value in decimal
! l - Longinteger, print value in hex
! S - String or stringname
! N - %NAME parameter, integer or longinteger, print decimal
! n - %NAME parameter, integer or longinteger, print hex
! V - Byte vector (records), print first 72 bytes hex if record>72
! F - Integername to be treated as ss error flag, print flag (dec) followed
!     by failure message.
! 
! b) Function results. (These are template terminators)
! R - Function result, treated as N if integer or longinteger function,
!     S if a string function
! r - Function result, treated as n if integer or longinteger function,
!     S if a string function
! Q - Integer function result which is to be treated as ss error flag, output
!     as F
! U - Function result to be treated as byte vector, i.e. %RECORD()%FN, output
!     as V
! 
! c) Others.
! 4 - Skip 4 words on stack, e.g. %routinename or %arrayname parameters
! 2 - Skip 2 words on stack, e.g. unwanted %record or other %name parameter.
! - (or anything else) - Skip 1 word on stack, e.g. uninteresting %integer etc.
! 
!
CONSTBYTEINTEGERARRAY  ONE CASE(0 : 127) =   C 
       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
      16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,
      32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
      48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,
      64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,
      96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,
      80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127;
!
CONSTINTEGER  MAXLL=132
!
!
RECORDFORMAT  HDRF(INTEGER  DATAEND,DATASTART,SIZE,TYPE,PASS1,DATETIME, C 
   NEXTCYC,SEMA)
SYSTEMROUTINESPEC  CHOPLDR(STRINGNAME  A, INTEGER  I)
SYSTEMROUTINESPEC  MOVE(INTEGER  LEN,FROM,TO)
SYSTEMSTRINGFNSPEC  FAILUREMESSAGE(INTEGER  I)
SYSTEMSTRING (8)FNSPEC  HTOS(INTEGER  VALUE,PLACES)
SYSTEMSTRINGFNSPEC  ITOS(INTEGER  I)
EXTERNALINTEGERFNSPEC  DDELAY(INTEGER  SECS)
EXTERNALINTEGERFNSPEC  UINFI(INTEGER  I)
EXTERNALSTRINGFNSPEC  DATE
EXTERNALSTRINGFNSPEC  TIME
!
stringfn  LITOS ( longinteger  I )
! Same as ITOS but for long integers
string (1) SIGN
string (63) S
  if  I < 0 then  I = -I and  SIGN = "-" else  SIGN = ""
  S = ""
  S = TOSTRING ( I - I // 10 * 10 + '0' ).S and  I = I // 10 until  I = 0
  result  = SIGN.S
end  ; ! of stringfn LITOS
!
!
{%EXTERNAL}SYSTEMROUTINE  WRLOG(STRING (255) ENTRY)
RECORD (HDRF)NAME  H
INTEGER  FLAG,SSMONAD,ASEMA,LEN,AD,AVAIL,MAXTRIES
SSMONAD=SSOWN_SSMONAD
H==RECORD(SSMONAD)
AD=ADDR(ENTRY)
LEN=BYTEINTEGER(AD);   ! Entry length
AD=AD+1;               ! 1st byte of ENTRY
MAXTRIES=3
! Try to claim the semaphore
! Construct a descriptor to it
ASEMA=SSMONAD+28;  ! Address of the semaphore.
AGAIN:
*LDTB_X'28000001';  ! Load descriptor type and bound 
*LDA_ASEMA;         ! Load descriptor address
*INCT_(DR );        ! Increment and test descriptor
*JCC_7,<WAIT>;      ! Jump to label WAIT on condition code 7 i.e. H_SEMA>0
! Got the semaphore if here.
! See if there is room for ENTRY without wrapround
AVAIL=H_DATAEND-H_NEXTCYC
IF  AVAIL>=LEN THEN  START 
   MOVE(LEN,AD,SSMONAD+H_NEXTCYC)
   H_NEXTCYC=H_NEXTCYC+LEN
FINISH  ELSE  START 
   ! Wrapround required
   MOVE(AVAIL,AD,SSMONAD+H_NEXTCYC)
   H_NEXTCYC=H_DATASTART
   MOVE(LEN-AVAIL,AD+AVAIL,SSMONAD+H_NEXTCYC)
   H_NEXTCYC=H_NEXTCYC+LEN-AVAIL
   H_PASS1=0;   ! To show that wrapround has occurred at least once
FINISH 
! Now release the semaphore
*LDTB_X'28000001'
*LDA_ASEMA
*LSS_-1;      ! Load ACC with -1
*ST_(DR );    ! Store it in H_SEMA
RETURN 
WAIT:
RETURN  IF  MAXTRIES=0; ! Give up meantime - Think about this
! Wait for 1 second then try again
FLAG=DDELAY(1)
MAXTRIES=MAXTRIES-1
->AGAIN
END ;  ! OF WRLOG
!
!
{%EXTERNAL}SYSTEMROUTINE  SSTRACE(NAME  FNRESULT, STRING (63) TEMPLATE)
STRING (63) STEM
INTEGER  LNB,LNBHERE,GLA,BASE,J,AD,CH,UC,SIZECODE,ADE,ADR,AVAIL,FN
INTEGER  W,W1,I,L
LONGINTEGERNAME  LW
BYTEINTEGERARRAY  E,R(0:255)
STRINGNAME  ENTRY,RES
BYTEINTEGERNAME  LE,LR
SWITCH  PARMTYPE(0:127)
RETURN  IF  TEMPLATE="NIL"
FN=0; ! This is set to -1 if E is found in the template
LW==LONGINTEGER(ADDR(W))
ADE=ADDR(E(0))
ENTRY==STRING(ADE)
LE==BYTEINTEGER(ADE)
ADE=ADE+1
ADR=ADDR(R(0))
RES==STRING(ADR)
LR==BYTEINTEGER(ADR)
ADR=ADR+1
E(133)=X'0A'
*STLN_LNBHERE;  ! LNB of SSTRACE
LNB=INTEGER(LNBHERE);    ! LNB of the routine to be monitored
BASE=LNB+16
GLA=INTEGER(BASE);       ! Pointer to GLA
STEM="DT: ".DATE." ".TIME." ".ITOS(UINFI(11))."/".ITOS(UINFI(13)).": "
! Recover routine name
AD=INTEGER(LNB+12)&X'00FFFFFF'+INTEGER(GLA+12)+12
ENTRY=STEM.STRING(AD)
J=0
WHILE  J<LENGTH(TEMPLATE) CYCLE 
   EXIT  IF  FN#0
   BASE=BASE+4
!   PRINTSTRING("*BASE* ".HTOS(BASE,8)."
!   ")
   LE=LE+1
   IF  J=0 THEN  E(LE)=' ' ELSE  E(LE)=','
   LE=LE-1 IF  FN<0
   J=J+1
   CH=CHARNO(TEMPLATE,J)
   UC=ONE CASE(CH)
   W=INTEGER(BASE)
   W1=INTEGER(BASE+4)
   RES=""
   ->PARMTYPE(UC)
   PARMTYPE('U'):      ! Result of fn to be treated as byte vector
   PARMTYPE('Q'):      ! Result of fn to be treated as ss error flag
   PARMTYPE('R'):      ! Result of function
   FN=-1
   BASE=LNBHERE+20;   ! Fn result is the first parm to SSTRACE
   E(LE)=' '
   RES="%res="
   W=INTEGER(BASE)
   W1=INTEGER(BASE+4)
   IF  UC='Q' THEN  UC='F' AND  ->PARMTYPE('F') ELSE  C 
   IF  UC='U' THEN  ->PARMTYPE('V') ELSE  ->PARMTYPE('N')
   PARMTYPE('4'):      ! Skip 4 words i.e. Array or Routinename
   ! Note that arrays have 2 descriptors one to the array, one to the
   ! dope vector, whereas routines have a descriptor followed by 2 words
   BASE=BASE+12
   CONTINUE 
   PARMTYPE('2'):      ! Skip 2 words i.e. Record or unwanted %name param
   BASE=BASE+4
   CONTINUE 
   PARMTYPE('F'):      ! Subsystem %integername flag params
   CH=UC
   PARMTYPE('N'):      ! Other %name parameters
   ! Find out what type first
   SIZECODE=(W>>27)&7
   IF  FN#0 AND  SIZECODE=3 THEN  {%result of stringfn} ->PARMTYPE('S') ELSE  C 
   IF  SIZECODE=5 THEN  START 
      ! Integername
      W=INTEGER(W1)
      BASE=BASE+4
      ->PARMTYPE('I')
   FINISH  ELSE  IF  SIZECODE=6 THEN  START 
      ! Longintegername
      W=INTEGER(W1)
      W1=INTEGER(W1+4)
      ->PARMTYPE('L')
   FINISH  ELSE  START 
      ! Anything else
      BASE=BASE+4
      CONTINUE 
   FINISH 
   PARMTYPE('I'):        ! Integer
   IF  CH=UC THEN  RES=RES.ITOS(W) ELSE  RES=RES."X".HTOS(W,8)
   IF  CH='F' THEN  START 
      IF  W>0 THEN  RES=RES.FAILUREMESSAGE(W) ELSE  C 
      IF  W=0 THEN  RES=RES." OK"
   FINISH 
   ->ADD
   PARMTYPE('L'):      ! Longinteger
   IF  CH=UC THEN  RES=RES.LITOS(LW) ELSE  RES=RES."X".HTOS(W,8)." ".HTOS(W1,8)
   BASE=BASE+4
   ->ADD
   PARMTYPE('S'):      ! String and stringname
   RES=RES.STRING(W1)
   BASE=BASE+4
   ->ADD
   PARMTYPE('V'):      ! Byteinteger vector (for records)
   L=W&X'00FFFFFF';  ! Vector len
   L=72 IF  L>72
   FOR  I=0,1,L-1 CYCLE 
      RES=RES.HTOS(BYTEINTEGER(W1+I),2)
   REPEAT 
   BASE=BASE+4
   ->ADD
   ADD:
   !PRINTSTRING("*LE*/*LR* ".ITOS(LE)."/".ITOS(LR)."
   !")
   WHILE  LE+LR>=MAXLL CYCLE 
      AVAIL=MAXLL-LE
   !PRINTSTRING("*AVAIL* ".ITOS(AVAIL)."
   !")
      MOVE(AVAIL,ADR,ADE+LE)
      LE=133
      WRLOG(ENTRY)
      ENTRY=STEM
      CHOPLDR(RES,AVAIL)
   REPEAT 
   ENTRY=ENTRY.RES
   PARMTYPE(*):
REPEAT 
ENTRY=ENTRY.TOSTRING(10)
WRLOG(ENTRY)
RETURN 
END ;  ! OF SSTRACE
ENDOFFILE