Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/19/simds3.mac
There are 2 other files named simds3.mac in the archive. Click here to see a list.
PRINTX SIMDS3.MAC
SUBTTL DSRB, SIMDDT subroutines
Comment;
Purpose: Release all linked ZBE entries
Entries: DSRB release all linked entries
DSRBD release all ZBE entries for dummy breakpoint
Input argument: XDZBE first ZBE entry in chain
Only for DSRB entry
Normal exit: DRETUR
Error exit: NONE
Output argument:NONE
Call format: Normal
Used subroutines:none
;
PROC
DSRBD: ;Release all ZBE entries for dummy breakpoint
LI XDZBE,LABB(YDSBRD)
SKIPN ,LABB(YDSBRD)
DRETUR ;Already released
MDSNB ;First real entry
SETZM ,LABB(YDSBRD)
DSRB: ;Release all linked ZBE ENTRIES
JUMPGE XDZBE,LAB(DSIE)
LF X0,ZBRZBE(XDZBR,QZBRUN) ;Empty link
HRRZ X1,XDZBE
LOOP
;DECREMENT ONLY
AS
AOBJN XDZBE,TRUE
SA
SUBI XDZBE,QZBEL
IF ;Part of ZBE
CAMN XDZBE,X1
GOTO FALSE
THEN
LF X1,ZBEZBE(XDZBE)
JUMPN X1,LAB(L1()) ;Release complete ZBE entries
DRETUR ;Exit when no complete ZBE released
FI
;Release complete ZBE entries
SUBI X1,(XDZBR) ;Calculate offset
L1():!
SF X1,ZBRZBE(XDZBR,QZBRUN)
LOOP
JUMPLE X1,LAB(DSIE)
CAMN X0,X1
DRETURN ;Already released
ADDI X1,(XDZBR)
L XDT2,X1
LF X1,ZBEZBE(X1) ;Find new link
AS
JUMPN X1,TRUE
SA
;Last linked ZBE found
SF X0,ZBEZBE(XDT2)
DRETUR
EPROC
SUBTTL DSNB and DSFB, SIMDDT subroutines
Comment;
Purpose: DSNB to find already reserved ZBE entries
DSFB to find free ZBE entries and reserve them
Entries: DSNBW find next reserved ZBE word
DSNB find next reserved ZBE entry
DSFBW reserve one more ZBE word
DSFB reserve one more ZBE entry
Input argument: XDZBE pointer to ZBE entry, current word
Left part of XDZBE contains negative counter
of number of unused words within ZBE entry
Normal exit: DRETUR if DSNB call
Skip DRETUR if DSFB call
Error exit: DRETUR if no more ZBE entries free to be reserved at DSFB call
Output argument:XDZBE new value of ZBE pointer
Call format: Normal
Used subroutines:DSOEM
Errors generated:All breakpoint work space used, release some
;
PROC
;Subroutines for using ZBE records
DSNBW: ;Next word within ZBE record
;If ZBE overflow find linked entry
IF
AOBJP XDZBE,FALSE
THEN
DRETUR
FI
SUBI XDZBE,QZBEL ;Restore XDZBE to first ZBE word
DEXEC DSNB
GOTO LAB(DSNBW)
DSNB: ;Find next reserved ZBE record
LF XDZBE,ZBEZBE(XDZBE)
IF
JUMPE XDZBE,FALSE
THEN
ADDI XDZBE,(XDZBR) ;Calculate ZBE address
HRLI XDZBE,-QZBEL ;Construct counter
DRETUR
FI
BRANCH LAB(DSIE) ;Implementation error
DSNBC: ;Find next command if any
;At entry XDZBE may point within command
;AT exit XDZBE is address of next command or 0 if none present
IF
JUMPG XDZBE,FALSE
THEN
;Find start of ZBE
LOOP
AS
AOBJN XDZBE,TRUE
SA
SUBI XDZBE,QZBEL
FI
IF
LF X0,ZBEZBE(XDZBE)
JUMPE X0,FALSE
THEN
DEXEC DSNB
LF X0,ZBETYP(XDZBE)
CAIN X0,QBECON
GOTO LAB(DSNBC)
ELSE
SETZ XDZBE,
FI
DRETUR
DSFBW: ;Next word within ZBE record
;If ZBE overflow reserve new ZBE record
IF
AOBJP XDZBE,FALSE
THEN
AOS (XDSTK) ;Skip return
DRETUR
FI
SUBI XDZBE,QZBEL
DEXEC DSFB
DRETUR ;Error
GOTO LAB(DSFBW)
DSFB: ;Find free ZBE record and link to previous entry
LF X1,ZBRZBE(XDZBR,QZBRUN) ;First empty ZBE record
IF
JUMPE X1,FALSE ;No more ZBE records
THEN
SF X1,ZBEZBE(XDZBE)
ADDI X1,(XDZBR)
LF X0,ZBEZBE(X1) ;Next empty
SF X0,ZBRZBE(XDZBR,QZBRUN)
SETZM ,(X1)
AOS ,(XDSTK) ;Skip return
GOTO LAB(DSNB)
FI
;No more ZBE entries left
MDSOEM QMFBOV
;Release all true breakpoints in error mode and set
;Switch to indicate this
;Skip return
DRETUR
EPROC
SUBTTL DSPS, SIMDDT subroutines
Comment;
Purpose: Put symbol or identifier in outtext
Entries: DSPS put symbol from symbol table in outtext
DSPSK put symbol from keyword table in outtext
DSPSKB put keyword symbol + blank in outtext
DSPSC put class identifier in outtext
DSPSP put class or procedure name from symbol table
in outtext
Input arguments:XDZBE symbol table entry if DSPS
X1 keyword table entry if DSPSK or DSPSKB
Symbol table name entry if DSPSC
XDZPR prototype address if DSPSP
Normal exit: DRETUR
Error exit: NONE
Output argument:NONE
Call format: Normal
Used subroutines:DSOCH
;
PROC
DSPS: ;Put symbol in text variable
LF X1,ZBEZSD(XDZBE) ; Symbol address in X1
DSPSK: ;Keyword symbol address in X1
LI XDT2,^D6
SKIPGE ,(X1)
L1():! ;Entry from DSPSP always 12 letters
DSPSC: ;Class identifier to outtext call from DSPB
LI XDT2,^D12
DSTACK X1
HRLI X1,600 ;Create byte pointer
LOOP
ILDB X0,X1
JUMPE X0,FALSE ;Blank found end of symbol
ADDI X0,040
OUTCHA
AS
DECR XDT2,TRUE
SA
DUNSTK X1
DRETUR
DSPSP: ;Output symbol ZSMRNM
;Input is prototype address in XDZPR
LF X1,ZPRSYM(XDZPR)
IF
LF X0,ZSMTYP(X1)
CAIE X0,QPROCB
CAIN X0,QCLASB ;Name exists
GOTO FALSE
;Name exists if qcext,qpext,qmext,qfext,qsyscl
CAIL X0,QCEXT
CAILE X0,QSYSCL
GOTO TRUE
GOTO FALSE ;Name exists
THEN
LI X1,3+LAB(ZKWBLOCK)
CAIE X0,QPBLOCK
GOTO FALSE
L X1,@YDSZLA(XLOW)
LF X0,ZLNADF(X1)
LI X1,3+LAB(ZKWMAIN)
CAMN X0,XDZPR ;Main block
GOTO FALSE
DSTACK XDZPR
MDSPM QMPSPB
LF XDZPR,ZCPZCP(XDZPR) ;Prefix class prototype
DEXEC DSPSP
DUNSTK XDZPR
DRETUR
FI
SUBI X1,3
GOTO LAB(L1())
DSPSKB: ;Put keyword symbol +blank in outtext
DEXEC DSPSK
DEXEC DSOCB
DRETUR
EPROC
SUBTTL DSPI, SIMDDT subroutines
COMMENT;
Purpose: Put identification in output text variable
ZBE entries contain description of identification
Entry: DSPI
Input argument: XDZBE pointer to start entry in ZBE for
identification
Normal exit: DRETUR
Error exit: none
Output arguments:XDZBE unchanged
X0 last referenced ZBE word
Call format: MDSPI (normal)
Used subroutines:DSPS,DSOCH,DSNB,DSTXPI
;
PROC
DSPI: ;Put identification in output text variable
;Input XDZBE
DSTACK XDT5
DSTACK XDZBE
DSTACK XDADR
DSTACK XDTYP
SETOFA YDSLIST
IFON ZBEIDL(XDZBE)
SETONA YDSLIST
LOOP
DSTACK XDZBE
;[41]
IF
IFOFF ZBESTAR(XDZBE)
GOTO FALSE
THEN
;OUTPUT *
LI X0,"*"
OUTCHA
ELSE
IF ;"THIS"
IFOFF ZBETHIS(XDZBE)
GOTO FALSE
THEN LI X1,LAB(ZKWTHIS)
DEXEC DSPSKB
LI XDZPR,ZBEZSD(XDZBE)
MDSPSP
ELSE
IF ;[166] Start of change
LF X1,ZBEZSD(XDZBE)
CAIE X1,LABB(YDSPZSD)
GOTO FALSE
THEN ;Procedure identifier
MDSNBW
LF X1,ZBEZSD(XDZBE) ;Address of procedure name
SUBI X1,1 ;Dummy control word before name
DEXEC DSPSC ;Output name
EXCH XDZBE,(XDSTK)
ELSE
;[166] End of change
MDSPS ;Put identifier
LF X1,ZBESUN(XDZBE)
IF
JUMPE X1,FALSE ;No subscripts
THEN ;Process subscripts
ST X1,LABB(YDST1)
LI X0,"["
LOOP OUTCHA
MDSNBW
LF XWAC3,ZBEVSU(XDZBE)
MTXPI
AS
LI X0,","
SOSLE ,LABB(YDST1)
GOTO TRUE
SA
LI X0,"]"
OUTCHA
EXCH XDZBE,0(XDSTK) ;Restore identifier entry address
FI FI ;[166]
FI FI
IF ;[41] QUA
IFOFF ZBEQUA(XDZBE)
GOTO FALSE
THEN
DEXEC DSOCB
LI X1,LAB(ZKWQUA)
DEXEC DSPSKB
EXCH XDZBE,(XDSTK)
MDSNBW
L XDZPR,ZBEZSD(XDZBE)
MDSPSP
EXCH XDZBE,(XDSTK)
FI
;Check for dot
AS
IFOFF ZBEIDD(XDZBE)
GOTO FALSE ;No more identifers
DUNSTK XDZBE
LI X0,"."
OUTCHA
MDSNBW
GOTO TRUE ;Next identifier
SA
;Exit, XDZBE contains address of first identifier entry
DUNSTK
L X1,XDZBE ;Save address of last identifier entry
DUNSTK XDTYP
DUNSTK XDADR
DUNSTK XDZBE
DUNSTK XDT5
DRETUR
EPROC
SUBTTL DSNI, SIMDDT subroutines
Comment;
Purpose: Get next identification from input text
Entries: DSNI normal entry
DSNIS one identifier has already been fetched
from input
Input arguments:XDZLN entry in ZLN table pointing to current
block, that gives the
starting point for symbol table search
XDZBE last used ZBE entry, identification if any
valid found must be placed in following
ZBE entries
YDSOCOM switch on if scanning output command
and subscripts may be skipped
Normal exit: DRETUR
Error exit: Skip DRETUR
Output arguments:XDZLN unchanged
XDZBE last used ZBE entry
YDSOAI switch on if array identifier without subscripts found
YDSSTP type of identifier returned in variable field
Call format: MDSNI (normal call) or
BRANCH LAB(DSNI) (special call)
Used subroutines:DSOEM,DSGI,DSSS,DSSSP,DSSSR,DSCT,DSFB,DSSK,DSTXGI,DSO,DSRB
Errors generated:
All messages with error constant starting qmni
see page assembly time constants
;
DSNI: PROC
;Get new identification from input text
;Input XDZLN
; XDZBE
;Return when input not correct
;Skip return if ok
DSTACK XDZBE
DSTACK XDZLN
ASSERT <
LI XDMN,QMAS01
JUMPE XDZLN,3+LAB(.)
SKIPL ,(XDZLN)
GOTO LAB(DSIE) ;Implementation error
>
IF
LI XDMN,QMNIII
MDSGI
GOTO LAB(DSNI01) ;[41] No identifier found in input
DSNIS: ;Entry point when identifier already located in input
THEN
IF ;[41] THIS was found
CAME XDSYM1,1+LAB(ZKWTHI)
GOTO FALSE
THEN LI XDMN,QMNICI
MDSGI
GOTO LAB(L4()) ;Error no class identifier follows
L XDZLN,(XDSTK)
LI X0,LAB(DSNI02)
L XDZLN,(XDSTK)
MDSSS
LI XDMN,QMNICI
GOTO LAB(L4())
DSNI02: ;Subroutine in DSNI called from DSSS
IF
L XDZPR,-1(XDSTK) ;Fetch prototype
LF X1,ZPRSYM(XDZPR)
LF X0,ZSMTYP(X1)
CAIE X0,QCEXT
CAIN X0,QCLASB
GOTO TRUE ;Class found
CAIE X0,QSYSCL
GOTO FALSE ;No class
THEN
IF
LF X0,ZLNTYP(XDZLN)
CAIN X0,QPBLOCK
GOTO FALSE ;Prefixed block not valid
THEN
LD X0,-2(X1) ;Fetch class name
CAMN X0,LAB(YDSSYM)
CAME X1,1+LAB(YDSSYM)
FI
FI DRETUR ;Try next if any
;Right prototype found
L XDT3,XDZPR
ST XDZPR,LABB(YDSSQU) ;Save qualification
SETONA ZBETHI(XDT3) ;Indicate "THIS"
LI XDTYP,QREF
DEXEC DSSSR
GOTO LAB(DSNI03)
FI
L XDZLN,(XDSTK) ;Restore
LI X0,LAB(L9()) ;Parameter to DSSS subroutine address
MDSSS ;Call DSS to search all visible symbol tables
;Error, identifier not found in symbol tables
IF ;[151] Start of change
L XDT3,LABB(YDSSYM)
CAMN XDT3,LAB([ SIXBIT "SYSIN" ])
GOTO TRUE ;Sysin requested
SKIPN X0,1+LABB(YDSSYM) ;Last part of name must be 0
CAME XDT3,LAB([ SIXBIT "SYSOUT" ])
GOTO FALSE ;No
THEN
L XDZLN,YDSZLA(XLOW) ;Fetch main line number table
LF XDZLN,ZLNADF(XDZLN) ;Start of table
LI X0,LAB(L9())
MDSSS
FI ;[151] End of change
LI XDMN,QMNINV
GOTO FALSE
L9():! ;Subroutine in DSNI called from DSSS
IF ;[166] Start of change
;Procedure requested?
LF X0,ZLNTYP(XDZLN)
CAIE X0,QPROCB
GOTO FALSE ;No procedure block
IFOFFA YDSCHG ;Procedure not allowed after IFCHANGED
IFONA YDSIFF ;or relation in breakpoints
GOTO FALSE
THEN
L XDT3,-1(XDSTK) ;Fetch prototype
LF XDT3,ZPRSYM(XDT3)
L X0,-2(XDT3)
L XDT4,-1(XDT3) ;Fetch name of procedure
IF
CAMN X0,LABB(YDSSYM)
CAME XDT4,1+LABB(YDSSYM)
GOTO FALSE ;Procedure not requested
THEN
LI X0,-2(XDT3)
ST X0,LABB(YDSSSA) ;Save symbol address for DSPI
LI X1,LABB(YDSPZSD)
GOTO LAB(L7()) ;dummy ZSD entry
;Exit DSSS
FI
FI ;[166] End of change
LD XDT3,LABB(YDSSYM) ;Fetch symbol
SKIPE ,X1
WHILE
SKIPN ,(X1)
DRETUR ;No more ZSD entries for this block
DO
IF
CAME XDT3,1(X1)
GOTO FALSE ;No match
THEN
IF
SKIPL ,(X1)
GOTO FALSE
THEN
CAMN XDT4,2(X1)
GOTO LAB(L7()) ;Match
ELSE
;Last six letters blank
JUMPE XDT4,LAB(L7())
FI
FI
LF X0,ZSDTYP(X1)
SKIPGE ,(X1)
AOJ X1,
ADDI X1,2
CAIN X0,QREF
AOJ X1,
OD
;[41]
DSNI01: ;Check for * in input
DEXEC DSSKBN
CAIE XDBYTE,"*"
GOTO LAB(L4()) ;Error no identifier found
;Check if * allowed
LI XDMN,QMNIST
IFOFFA YDSOCO
GOTO LAB(L4())
;* Ok
DEXEC DSSKB
MDSFBW
GOTO LAB(L3())
SETZM ,(XDZBE)
SETON ZBESTA(XDZBE)
GOTO LAB(L2()) ;Return
L7():! ;Match symbol found
;Exit from DSSS, restore stack!
DEXEC DSSSR ;Return from DSNI L9() subroutine
;Remove stack entries for DSSS routine
IF ;Symbol was accepted
L8():! ;[2] Main text attribute found
MDSCT ;Check type, kind and mode of symbol
JUMPL XDTYP,FALSE
THEN
IF ;[41] REF
CAIE XDTYP,QREF
GOTO FALSE
THEN ;Save prototype
LF X0,ZSDZPR(X1,-1)
SKIPGE ,(X1) ;Six letters
LF X0,ZSDZPR(X1)
ST X0,LABB(YDSSQU)
FI
L XDT3,X1 ;Save X1
DSNI03: ;Jump here if THIS found [41]
MDSFBW
GOTO LAB(L3()) ;No free ZBE entry?
ST XDTYP,LABB(YDSSTP) ;Save type, used in DSAT
WSF XDT3,ZBEZSD(XDZBE)
MOVM X1,LABB(YDSEBL) ;Effective block level
SF X1,ZBEEBL(XDZBE)
L XDT4,XDZBE ;Save
IF ;Not Lastitem
DEXEC DSSKBN
JUMPE XDBYTE,FALSE
THEN
IF ;Left bracket
CAIN XDBYTE,"["
GOTO TRUE
CAIE XDBYTE,"("
GOTO FALSE ;. (dot) may follow
THEN ;Find subscripts
LOOP
MTXGI
GOTO LAB(L3()) ;Error
;XWAC1 contains integer
MDSFBW
GOTO LAB(L3()) ;If no ZBE entries
ST XWAC1,(XDZBE)
LF X0,ZBESUN(XDT4)
AOJ X0,
SF X0,ZBESUN(XDT4)
AS
DEXEC DSSKB
CAIE XDBYTE,"]"
CAIN XDBYTE,")"
GOTO FALSE ;Check for .
CAIN XDBYTE,","
GOTO TRUE
LI XDMN,QMNISE
GOTO LAB(L4())
SA
MDSSKB
FI
FI
;Error if array and no subscripts
;Error if no array and subscripts present
SETOFA YDSOAI ;[41] No array identifier
L XDT2,XDT4
LF X1,ZBEZSD(XDT2) ;Fetch symbol entry
LF X1,ZSDKND(X1)
LF XDT5,ZBESUN(XDT2)
IF ;ARRAY
CAIE X1,QARRAY
GOTO FALSE
THEN ;Subscripts should follow except in OUTPUT command
LI XDMN,QMNINS
IF ;No subscripts present
JUMPN XDT5,FALSE
THEN ;Could be error
IFOFFA YDSOCOM
GOTO LAB(L4()) ;Error if no subscripts
;not output command
SETONA YDSOAI ;Indicate this
GOTO LAB(L2()) ;Output of complete
;array possible
FI
ELSE
LI XDMN,QMNINA
JUMPN XDT5,LAB(L4())
FI
IF ;QUA is allowed here
L X0,LABB(YDSSTP) ;[41]
CAIE X0,QREF
GOTO FALSE
THEN
DSTACK XDT2
DSTACK LABB(YDSIPO)
DSTACK 1(XDINT)
DSTACK LABB(YDSTIC)
IF ;[41] QUA is used
MDSGIS
GOTO FALSE
CAME XDSYM1,1+LAB(ZKWQUA)
GOTO FALSE
THEN
DUNSTK
DUNSTK
DUNSTK
;Find class identifier
LI XDMN,QMNICI
MDSGI
GOTO LAB(DSNI05)
;Check if valid class identifier
L XDT2,LABB(YDSSQU)
LOOP
IF
LF X1,ZPRSYM(X2)
CAME XDSYM1,-2(X1)
GOTO FALSE ;Not found
CAME XDSYM2,-1(X1)
GOTO FALSE
THEN
GOTO LAB(DSNI04) ;Class in prefix chain
FI
AS
LF XDT2,ZCPZCP(XDT2)
JUMPN XDT2,TRUE
SA
;Not found in prefix chain
SETZ XDT4,
DEXEC DSLPR ;Find any class with name XDSYM1,XDSYM2
;and YDSSQU in its prefix chain
IF
JUMPE XDT2,FALSE ;Not found
THEN
LF XDT2,ZLNADF(XDT2)
GOTO LAB(DSNI04)
FI
LI XDMN,QMNICI
DSNI05: DUNSTK XDT2
GOTO LAB(L4()) ;Qualification not ok
DSNI04: ;Qualification ok
MDSFBW
GOTO LAB(DSNI05)
WSF XDT2,ZBEZSD(XDZBE) ;Save prototype
ST XDT2,LABB(YDSSQU)
DUNSTK XDT2
SETON ZBEQUA(XDT2)
ELSE
DUNSTK ,LABB(YDSTIC)
DUNSTK ,1(XDINT)
DUNSTK ,LABB(YDSIPO)
DUNSTK XDT2
FI
FI
IF ;Dot
DEXEC DSSKBN
CAIE XDBYTE,"."
GOTO FALSE
THEN
IF ;[41] not (after THIS or REF var or TEXT var)
IFON ZBETHI(XDT2)
GOTO FALSE
LI XDMN,QMNINR
LF XDT3,ZBEZSD(XDT2)
;[2]
IFEQF (XDT3,ZSDTYP,QREF)
GOTO FALSE
THEN
IFNEQF (XDT3,ZSDTYP,QTEXT)
GOTO LAB(L4()) ;Error, no ref or text
; variable
FI
SETON ZBEIDD(XDT2)
LI XDMN,QMNIID
MDSGI
GOTO LAB(DSNI01) ;No identifier in input after .
IF ;[2] REF
L X0,LABB(YDSSTP) ;[41]
CAIN X0,QREF
GOTO FALSE
THEN ;Check for Main
LI XDMN,QMNINM
CAME XDSYM1,1+LAB(ZKWMAIN) ;Only Main allowed
GOTO LAB(L4()) ;Error
LI X1,LAB(DSZSDM) ;Address
;of ZSD entry
;for main
GOTO LAB(L8())
FI
;Find class prototype
L X1,LABB(YDSSQU) ;[41]
;Change XDZLN to outermost block
;Only class and prefix classes may be searched
L XDZLN,LABB(YDSCZS)
LI X0,LAB(L9())
DEXEC DSSSP ;Look for symbol match
;Special entry only
;Class and prefix classes
;searched
LI XDMN,QMNIIA
GOTO LAB(L4()) ;Attribute identifier not found
;in symbol table
FI
L2():!
IF ;[166] Start of change
LF X0,ZBEZSD(XDZBE)
CAIE X0,LABB(YDSPZSD)
GOTO FALSE
THEN
MDSFBW ;Procedure id
GOTO LAB(L3())
L X0,LABB(YDSSSA) ;Symbol address
WSF X0,ZBEZSD(XDZBE)
FI ;[166] End of change
AOS ,-2(XDSTK) ;Skip return correct identification
GOTO LAB(L5())
FI
FI
L4():! ;Error found
MDSOEM ;Create error message
L3():! ;Error but message already created
;Release any ZBE entries
L XDZBE,-1(XDSTK) ;Fetch input ZBE
MDSRB
L5():! ;Exit
DUNSTK XDZLN
DUNSTK ;XDZBE updated, X0 holds calling XDZBE
DRETUR
EPROC
SUBTTL DSSS, SIMDDT subroutines
Comment;
Purpose: Search all blocks accessible via current display
Entry: DSSS normal entry all symbol tables are searched
DSSSP entry if only classes and its prefix
classes is to be searched, used to find
class attributes (called from DSNI)
DSSSR exit DSSS subroutine
Input arguments:X0 address of subroutine to be called when
a ZSD entry located
XDZLN pointer to block type entry in ZLN
See DSNI
Normal exit: DRETUR
Error exit: none
Output arguments:XDZLN unchanged
Used subroutines:Input subroutine is called when valid
ZSD entry located
Stack contains prototype address
X1 points at ZSD entry
;
PROC
DSSS: ;
;Search all blocks acessible via current display
;Input X0 address of subroutine to be called
; when a ZSD entry located
; XDZLN pointer to block type entry in ZLN
;
IF
JUMPE XDZLN,FALSE ;No block structure entry identified
THEN
DSTACK X0
DSTACK XDZLN
LOOP
;Symbol in YDSSYM
LF X1,ZLNTYP(XDZLN)
IF
CAIN X1,QPROCB
GOTO TRUE ;Block with prototype
CAIN X1,QPBLOCK
GOTO TRUE
CAIN X1,QCLASB
GOTO TRUE
CAIN X1,QUBLOCK
GOTO TRUE
CAIE X1,QRBLOCK
GOTO LAB(L1())
;Reduced block
HLRZ X0,(XDSTK)
IF
JUMPE X0,FALSE ;Innermost subblock
THEN
;[2]
SKIPN LABB(YDSNLN)
ST XDZLN,LABB(YDSNLN) ;Save address of entry
;for innermost block
;but one
;[2]
ELSE
SETZM LABB(YDSNLN)
ST XDZLN,LABB(YDSSLN) ;Save address of entry
;for innermost block
LF X0,ZLNADF(XDZLN)
HRLM X0,(XDSTK) ;Save state
FI
GOTO FALSE ;Next ZLN entry
L1():!
CAIE X1,QEBLOCK
GOTO LAB(L2())
;End of block(s)
LF XDZLN,ZLNADF(XDZLN)
GOTO FALSE ;Skip all inner blocks
L2():!
CAIGE X1,QCEXT
GOTO LAB(L9())
CAIG X1,QFEXT
GOTO FALSE ;External module, try next entry
L9():!
;Inspect block
ASSERT <
LI XDMN,QMAS02
CAIE X1,QINSPEC
GOTO LAB(DSIE) ;Implementation error
>
HRRE X0,0(XDZLN) ;Fetch right level
;for inspect block
SOJ XDZLN,
LF X1,ZLNADF(XDZLN)
GOTO 1+LAB(L7())
THEN ;Symbol table address via prototype address in ZLN
LF X1,ZLNADF(XDZLN) ;Prototype address
L7():!
LFE X0,ZPREBL(X1)
ST X0,LABB(YDSEBL) ;Save level
L8():! DSTACK X1 ;Save prototype
L6():! ;Search symbol table
HLRZ XDT2,-1(XDSTK)
LF X1,ZPRSYM(X1)
JUMPE X1,LAB(L3()) ;No symbol table
;Calculate start address in ZSM
LSHC XDT2,-1
ADD XDT2,X1
IF
JUMPL XDT3,FALSE
THEN
;Even state number
LF X1,ZSMZSR(XDT2)
ELSE
;Odd
LF X1,ZSMZSL(XDT2,1)
FI
L3():! ;Call subroutine given as input parameter
PUSHJ XDSTK,@-2(XDSTK)
;Return from subroutine, find next ZSD entry
L X1,(XDSTK) ;Fetch prototype address
IF ;Reduced block
IFONA YDSOSB ;[41]
GOTO FALSE ;[41] Only one block
HLRZ XDT2,-1(XDSTK)
JUMPE XDT2,FALSE
THEN
LF XDT3,ZPRMAP(X1) ;Find map
L X0,XDT2
IMULI X0,ZMP%S
ADD XDT3,X0
LF XDT3,ZMPZMP(XDT3)
LF XDT2,ZPRMAP(X1)
SUB XDT3,XDT2
IDIVI XDT3,ZMP%S
HRLM XDT3,-1(XDSTK) ;Save new state number
GOTO LAB(L6()) ;New subblock
FI
LF XDT2,ZPRSYM(X1)
LF X0,ZSMTYP(XDT2)
IF
CAIE X0,QSYSCL
CAIN X0,QCLASB
GOTO TRUE
CAIN X0,QCEXT
GOTO TRUE
CAIE X0,QPBLOCK
GOTO FALSE
HLRZ X0,-1(XDSTK) ;[41]
IFONA YDSOSB
JUMPN X0,FALSE ;Not outer block
THEN ;Block may be prefixed
LF X1,ZCPZCP(X1) ;Prototype address if
;Prefix exists
JUMPE X1,FALSE
DUNSTK
GOTO LAB(L8()) ;Symbol is prefix
;attribute
FI
DUNSTK X0 ;Remove prototype address
FI ;Try enclosing block if any
AS
LI XDZLN,(XDZLN) ;Remove any block state variable
CAMN XDZLN,LABB(YDSCZS)
GOTO FALSE ;No more blocks
LF XDZLN,ZLNBLK(XDZLN)
ADD XDZLN,LABB(YDSCZS)
GOTO TRUE
SA
DUNSTK XDZLN
DUNSTK ;Subroutine address
FI
DRETUR
DSSSP: ;Entry into DSSS when search of only prefix classes is to be performed
;from DSNI
DSTACK X0
DSTACK XDZLN
GOTO LAB(L7())
DSSSR: ;Exit DSSS from subroutine given in call to DSSS
DUNSTK ;Exit DSSSR address
ST X0,-4(XDSTK)
DUNSTK ;Exit subroutine address
DUNSTK XDZPR
DUNSTK XDZLN
DUNSTK ;Subroutine address
DRETUR
EPROC
SUBTTL DSCT, SIMDDT subroutine
Comment/
Purpose: Check symbol table entry
Check if kind, mode and type of symbol
can be handled by SIMDDT
Entry: DSCT
Input argument: X1 addresses ZSD entry
Exit: DRETUR
Output: XDTYP is -1 if symbol not valid
otherwise it contains ZSDTYP
X0 is ZSDKND
XDMN is message number if symbol is not valid
/
DSCT: PROC
LI XDMN,QMNITL
LF XDTYP,ZSDTYP(X1)
IF ;Not label, name param
CAIN XDTYP,QLABEL
GOTO FALSE
LI XDMN,QMNIMN
IFEQF (X1,ZSDMOD,QNAME)
GOTO FALSE
THEN
LF X0,ZSDKND(X1)
IF ;[2] Procedure
CAIE X0,QPROCEDURE
GOTO FALSE
THEN ;Standard procedure ?
LF XDMN,ZSDSPI(X1)
JUMPN XDMN,FALSE ;Ok, standard proc
LI XDMN,QMNIKP
GOTO LAB(L1()) ;Not standard procedure
FI
LI XDMN,QMNIKC
CAIN X0,QCLASS
GOTO LAB(L1()) ;[242] Class not possible
LI XDMN,QMNIUN
CAIN X0,QUNDEF
FI
L1():! SETO XDTYP, ;-1 signals error return
DRETUR
EPROC
SUBTTL DSLV, SIMDDT subroutines
Comment/
Purpose: Locate value address
Entry: DSLV
Input arguments:
XDZBE pointer into ZBE entry which
starts an identification
XCB from RTS, current block pointer
Normal exit: DRETUR
Error exit: DRETUR
Output arguments:
Normal return:
XDADR address of value
XDTYP type of value
XDZBE unchanged
XDT5 address of ZSD entry
Switch YDSOAI set if array identifier without subscripts found
Error return:
XDADR 0
Call format: Normal
Used subroutines:DSOEM,DSNB,DSCSQU
/
DSLV: PROC
DSTACK XDZBE
SETOFA YDSOAI ;[41]
;[2]
L X1,YDSSXCB(XLOW) ; [2] Find current block
IF
IFON ZBESTAR(XDZBE) ;[41]
GOTO FALSE ;[41] * found
LF X0,ZBEEBL(XDZBE) ;[41] Block level
LF XDMN,ZBIZPR(X1)
LFE XDMN,ZPREBL(XDMN) ;Find effective level of block
ADD XDMN,X0
JUMPE XDMN,FALSE ;X1 valid
THEN
;Find block instance address
DSTACK X0 ;Save level
IF ;Terminated block or without display vector
IFOFF ZDNTER(X1)
GOTO FALSE
IFON ZDNKDP(X1)
GOTO FALSE
THEN ;Error
LI XDMN,QMLVET
GOTO LAB(L1())
FI
DUNSTK
SUB X1,X0
L X1,(X1)
FI
SETZ XDT2, ;[41]
LOOP
DSTACK XDZBE
;[41] Check for *
IF ;* found
IFOFF ZBESTAR(XDZBE)
GOTO FALSE
THEN ;X1 points at block
LI XDT5,"*"
GOTO LAB(L4()) ;Exit DSLV
FI
IF ;[41] THIS
IFOFF ZBETHIS(XDZBE)
GOTO FALSE
THEN ;Create dummy entry for THIS
MOVSI X0,000701 ;Simple declared REF variable
ST X0,LABB(YDSTHD)
ST X1,1+LABB(YDSTHD) ;Save class block address
LI X1,1+LABB(YDSTHD) ;Update address
LF XDT2,ZBEZSD(XDZBE)
ST XDT2,2+LABB(YDSTHD) ;Save class prototype
LI XDT2,LABB(YDSTHD)
GOTO LAB(L5())
FI
IF ;[2] System procedure handled by SIMDDT
LF XDT2,ZBEZSD(XDZBE)
IFNEQF (XDT2,ZSDKND,QPROCEDURE)
GOTO FALSE
THEN
IF ;[166] Type procedure
CAIE XDT2,LABB(YDSPZSD)
GOTO FALSE
THEN
LF X0,ZDNTYP(X1)
CAIE X0,QZBP
GOTO LAB(DSTERM)
LF XDMN,ZBIZPR(X1) ;Fetch prototype
LF X0,ZPCTYP(XDMN)
LI XDMN,QMLVNP
CAIN X0,QNOTYPE ;Type procedure
GOTO LAB(L1()) ;No, error
LI XDT2,LABB(YDSTPZSD) ;Type proc entry
LSH X0,6 ;Construct ZSD entry
ADDI X0,1 ;Simple var
HRLM X0,LABB(YDSTPZSD) ;Insert type
GOTO LAB(L9()) ;Treat like ordinary symbol
FI ;[166] End of change
DEXEC DSSPV
JUMPN XDMN,LAB(L1()) ;Error in evtime
ELSE
L9():! ;[166]
LF X0,ZSDOFS(XDT2)
ADD X1,X0 ;Address of variable
FI
IF
IFNEQF (XDT2,ZSDKND,QARRAY)
GOTO FALSE
THEN ;ARRAY
HRRZ XDT5,(X1) ;Fetch array address
;[1] Only in rh
;Check if array initialized
LI XDMN,QMPVRI
JUMPE XDT5,LAB(L1())
CAIN XDT5,NONE
GOTO LAB(L1())
LF X0,ZARSUB(XDT5)
LF XDT3,ZBESUN(XDZBE)
SETONA YDSOAI
JUMPE XDT3,FALSE ;[41] Array identifier
SETOFA YDSOAI
L X1,XDT5 ;Array address to X1
;Array identifier specified
;in output command
LI XDMN,QMLVSN
CAME X0,XDT3
GOTO LAB(L1()) ;Error wrong number of subscripts
DSTACK X1
LOOP
;Get next ZBE word
MDSNBW
LF X0,ZBEVSU(XDZBE)
LI XDMN,QMLVSL
CAMGE X0,ZARLOO(X1)
GOTO LAB(L3()) ;Error
LI XDMN,QMLVSU
CAMLE X0,ZARUPO(X1)
GOTO LAB(L3())
IF ;First subscript
JUMPL XDT3,FALSE
THEN
L XDT2,X0
MOVN X0,XDT3
ASH XDT3,1
ADDI XDT3,3(X1)
HRL XDT3,X0
;XDT3 is [-n,,address of first dope vector]
ELSE
IMUL X0,0(XDT3)
ADD XDT2,X0
FI
AS
ADDI X1,2
AOBJN XDT3,TRUE ;Next subscript
SA
DUNSTK XDT3 ;XDT3 contains variable address
EXCH XDZBE,(XDSTK)
L X1,XDT2
LF XDT2,ZBEZSD(XDZBE)
LF X0,ZSDTYP(XDT2)
CAIE X0,QLREAL
CAIN X0,QTEXT
ASH X1,1 ;Size of element is 2
ADD X1,ZARBAO(XDT3)
FI
;XDZBE points at last identifier entry
;Stack points at last referenced ZBE entry
;XDT2 points at ZSD entry
;X1 points at element
L5():! ;[41] THIS found
IF ;QUA found
IFOFF ZBEQUA(XDZBE)
GOTO FALSE
THEN EXCH XDZBE,(XDSTK)
MDSNBW
LF X0,ZBEZSD(XDZBE) ;Fetch prototype
ST X0,2+LABB(YDSTHD)
L XDT2,(XDT2) ;Fetch ZSD entry
TLZ XDT2,400000 ;Force name length to 6 letters
ST XDT2,LABB(YDSTHD)
LI XDT2,LABB(YDSTHD)
EXCH XDZBE,(XDSTK)
FI
AS
IFOFF ZBEIDD(XDZBE)
GOTO FALSE
;Dot notation in identification
IF ;[2] not TEXT
LF X0,ZSDTYP(XDT2)
CAIN X0,QTEXT
GOTO FALSE ;Text attribute main
THEN
HLLOI X0,0 ;NONE not valid but subclass ok
MCSQU ;Check qualif
GOTO LAB(L2()) ;Error
FI
DUNSTK XDZBE ;Skip any subscripts
MDSNBW
CAIE X0,QTEXT ;[2] Ref to text variable in X1 if text
L X1,(X1) ;Object address
GOTO TRUE ;Next identifier
SA
;End of identification found
LF XDT5,ZSDTYP(XDT2)
IF
IFOFFA YDSOAI ;Not possible to check
;qualification if array output
CAIE XDT5,QREF
GOTO FALSE
THEN
SETO X0, ;Both NONE and subclass ok
MCSQU
GOTO LAB(L2()) ;Error
FI
L4():! ;[41]
EXCH XDT5,XDTYP ;At exit XDTYP loaded
;XDT5 contains ZSD pointer
L XDADR,X1
GOTO 1+LAB(L2()) ;Normal return
L3():! DUNSTK
L1():! ;Error
MDSOEM
L2():! SETZB XDADR,XDTYP
DUNSTK
DUNSTK XDZBE
DRETUR
EPROC
SUBTTL DSSPV, SIMDDT subroutines
Comment;[2] new SIMDDT facility
Purpose: To get system procedure value address for
MAIN, SYSIN, SYSOUT, FIRST, LAST, SUC, PRED,PREV,
EVTIME, NEXTEV,TIME and CURRENT
Entry: DSSPV
Input arg.: X1 points at block instance
X2=XDT2 points at ZSD entry
Normal exit: DRETURN
Error exit: DRETURN
Output arg.: X1 address of variable
XDMN = 0 if no error
= Error number if error in evtime
Call format: DEXEC DSSPV
Used subroutines: TXMN, SUNE
;
DSSPV: PROC
DSTACK X2 ;Save X2
SETZ XDMN, ;Indicate no error
LF X2,ZSDSPI(X2)
ADDI X2,-1(XDBAS) ;DSMAIN first entry at offset 0 from DSSPVT
;DSMAIN has ZSDSPI=QIMAIN=1
GOTO @DSSPVT-DSSTAR(X2) ;Jump to the routine given by index ZSDSPI
DSSPVT: ;Jump table
LAB(DSMAIN)
LAB(DSSYSIN)
LAB(DSSYSOUT)
LAB(DSFIRST)
LAB(DSLAST)
LAB(DSSUC)
LAB(DSPRED)
LAB(DSPREV)
LAB(DSEVTIME)
LAB(DSNEXTEV)
LAB(DSTIME)
LAB(DSCURRENT)
DSMAIN: LD X1,(X1)
STD X1,LABB(YDSSPV)
LI XTAC,LABB(YDSSPV)
MTXMN
L X1,XTAC ;Text ref in X1
GOTO LAB(DSSPVX)
DSSYSIN:
LI X1,YSYSIN(XLOW)
GOTO LAB(DSSPVX)
DSSYSOUT:
LI X1,YSYSOUT(XLOW)
GOTO LAB(DSSPVX)
DSFIRST:
LF X0,ZLGSUC(X1)
L2():! CAMN X0,X1
LI NONE
L3():! ST X0,LABB(YDSSPV)
LI X1,LABB(YDSSPV)
GOTO LAB(DSSPVX)
DSLAST:
LF X0,ZLGPRE(X1)
GOTO LAB(L2())
DSSUC: LF X0,ZLGSUC(X1)
L4():! L X1,X0
IF
CAIN X1,NONE
GOTO FALSE
THEN
L X2,(XDSTK) ;ZSD entry
L X2,OFFSET(ZSDZPR)-1(X2) ; .SSLK
; ZSDNM2 not present for
; SUC or PRED
LF X1,ZBIZPR(X1)
WHILE
JUMPE X1,FALSE
DO
CAMN X2,X1
GOTO LAB(L3())
LF X1,ZCPZCP(X1)
OD
LI X0,NONE
FI
GOTO LAB(L3())
DSPRED: LF X0,ZLGPRE(X1)
GOTO LAB(L4())
DSPREV: LF X0,ZLGPRE(X1)
GOTO LAB(L3())
DSEVTIME: ;If the process is idle i.e. has no event notice,
; give error message number in XDMN
LF X1,ZPSZEV(X1)
IF
JUMPN X1,FALSE
THEN
SETZ X0, ;Set evtime to 0 = initial value
; not visible after var command
IFONA YDSOCOM ;[237] No error in VAR, ALL or OUTPUT * commands
SETONA YDSERE
LI XDMN,QSUENO+2 ;ZYQ145 = SUERR 2
GOTO LAB(L3())
ELSE
LI X1,OFFSET(ZEVTIM)(X1)
GOTO LAB(DSSPVX)
FI
DSNEXTEV:
DSTACK XWAC1 ;Save XWAC1
LI XTAC,XWAC1
L XWAC1,X1
MSUNE
L X0,XWAC1
DUNSTK XWAC1 ;Restore XWAC1
GOTO LAB(L3())
DSTIME: ;Simulation block address in X1
LF X1,ZSUFT(X1)
LI X1,OFFSET(ZEVTIM)(X1)
GOTO LAB(DSSPVX)
DSCURRENT: ;Simulation block address in X1
LF X1,ZSUFT(X1)
LF X0,ZEVZPS(X1)
GOTO LAB(L3())
DSSPVX: ;Exit from DSSPV
DUNSTK X2
DRETURN
EPROC
SUBTTL DSCSQU, SIMDDT subroutines
Comment/
Purpose: Call RTS routine CSQU
Entry: DSCSQU
Input arguments:X1 address of ref variable
XDT2 ZSD entry
X0 qualification parameter to CSQU
Normal exit: Skip DRETURN if ok
Error exit: DRETUR if qualification error
Message already created
Call format: normal
Used subroutines:DSOBM and CSQU
/
;
DSCSQU: PROC
DSTACK XWAC1
DSTACK XSAC
n==2
L XWAC1,(X1) ;Fetch object reference
;Check if address initialized
LI XDMN,QMPVRI
JUMPE XWAC1,LAB(L1()) ;Error
JUMPE XDT2,LAB(L2()) ;[166] Procedure values lacks ZSD reference
;Find prototype address
LF XSAC,ZSDZPR(XDT2,-1)
SKIPGE ,(XDT2)
LF XSAC,ZSDZPR(XDT2) ;2 words for symbol
JUMPE XSAC,LAB(L2()) ;[166] Skip test
EXEC CSQU
IF ;Qualification error
JUMPN XWAC1,FALSE
THEN LI XDMN,QMCSQE
L1():! MDSOEM
GOTO LAB(L9()) ;Return
FI
L2():! ;[166]
AOS -n(XDSTK) ;Skip return
L9():! DUNSTK XSAC
DUNSTK XWAC1
n==0
DRETUR
EPROC
SUBTTL DSNILV, SIMDDT subroutine
PROC
Comment/
Purpose:Call DSNI and DSLV
Called from DSOP, DSPC [2] and DSIP command routines
Dummy ZBE entries used
Entry: DSNILV
Input arguments:-
Normal exit: Skip DRETURN
Error exit: DRETURN
Branch DSCM if no free ZBE entries
Output arguments:See DSLV
Dummy ZBE entries built
Used subroutines:DSNB,DSFB,DSLV and DSNI
/
DSNILV:
IF
SETZM ,LABB(YDSBRD)
LI XDZBE,LABB(YDSBRD)
MDSFB
GOTO LAB(L1())
L XDZLN,LABB(YDSCZL) ;Fetch right environment
MDSNI
GOTO FALSE
LI XDZBE,LABB(YDSBRD)
MDSNB
MDSNBW
MDSLV
JUMPE XDADR,FALSE
THEN
AOS ,(XDSTK) ;Normal return
FI
DRETUR
L1():! ;Exit to DSCM if no free ZBE entries
DUNSTK
BRANCH LAB(DSCM)
EPROC
SUBTTL DSPV, SIMDDT subroutines
PROC
Comment/
Purpose: Put value in output text preceded by = or ==
Entries: DSPVT put tab assign value
DSPV put blank assign value
DSPVN put value
DSPVS put text constant
Input arguments:XDADR address of value
XDTYP type of value
XDZSD if ref variable
Normal exit: DRETUR
Error exit: -
Output arguments:-
Used subroutines:DSOC,CSQU,TXPI,TXPR,DSPM,DSPLO,TXST,DSPSK,DSFA
/
DSPVT: ;Put value preceded by tab assign characters
DEXEC DSOCT
SKIPA
DSPV: ;Put value preceded by blank assign characters
DEXEC DSOCB
LI XDMN,QMOPAS
LI X0,"="
CAIE XDTYP,QREF
CAIN XDTYP,QTEXT
OUTCHA
MDSPM ;Create = or ==
DSPVN: ;Put value in output text no assign characters
SETONA YDSSTRING ;Text variable
DSPVNS: ;Text constant output
LD XWAC3,(XDADR) ;Load value
IF
CAIE XDTYP,QINTEGER
GOTO FALSE
THEN
;Treat integer
MTXPI
DRETUR
FI
IF ;REAL
CAIE XDTYP,QREAL
GOTO FALSE
THEN SETZ XWAC4,
LI XWAC5,QNSDR ;Number of significant digits for real
GOTO LAB(L1())
FI
IF
CAIE XDTYP,QLREAL
GOTO FALSE
THEN
LI XWAC5,QNSDLR ;Number of significant digits for long real
L1():! ;From real
MTXPR
DRETUR
FI
IF CAIE XDTYP,QBOOLEAN
GOTO FALSE
THEN
LI X1,LAB(ZKWFALSE)
JUMPE XWAC3,LAB(L2()) ;Put FALSE in text
LI X1,LAB(ZKWTRUE)
GOTO LAB(L2()) ;Put TRUE in text
FI
IF
CAIE XDTYP,QCHARACTER
GOTO FALSE
THEN
IF ;Possible special char
CAIL XWAC3,40
GOTO FALSE
THEN ;Output CHAR i instead
MDSPM QMPVCH ;CHAR
MTXPI
OUTCHB
ELSE ;Output 'c'
LI X0,"'"
OUTCHA
L X0,XWAC3
CAIE X0,0 ;Skip if delete char
OUTCHA
LI X0,"'"
OUTCHA
FI
DRETUR
FI
IF ;TEXT
CAIE XDTYP,QTEXT
GOTO FALSE
THEN
IF ;NOTEXT
JUMPN XWAC3,FALSE
THEN
LI X1,LAB(ZKWNOTEXT)
GOTO LAB(L2())
FI
IF ;Not a string
IFOFFA YDSSTRING
GOTO FALSE
THEN
;Output octal address of text variable
HRRZ XDSTA,XWAC3
DEXEC DSPLO
DEXEC DSOCB
DSTACK XWAC4
DSTACK XWAC3
LI XTAC,XWAC3
MTXST ;Strip
DUNSTK XWAC3
EXCH XWAC4,(XDSTK) ;Save new length
FI
;Create byte pointer to first character
HLRZ X0,1(XWAC3) ;[51] Check for subtext by comparing Main.Length
HLRZ X1,XWAC4 ;[51] to Length
SUB X0,X1 ;[51] Difference
HLRZ X1,XWAC3 ;Offset within Main text
IF ;Subtext
JUMPE X0,FALSE ;[51]
THEN ;Output position where subtext starts
MDSPM QMPVST
DSTACK XWAC3
LI XWAC3,1(X1) ;[51] Add 1 to start pos
MTXPI
OUTCHB
DUNSTK XWAC3
HLRZ X1,XWAC3
FI
IDIVI X1,5
ADDI XWAC3,ZTE%S(X1)
HRLI XWAC3,(POINT 7,0)
WHILE
SOJL X2,FALSE
DO
IBP ,XWAC3
OD
ST XWAC3,LABB(YDST2)
HRRZ X1,XWAC4 ;Save length
IF ;Not a string
IFOFFA YDSSTRING
GOTO FALSE
THEN
;Output length
MDSPM QMPVLE
HLRZ XWAC3,XWAC4
MTXPI
OUTCHB
;Output pos
MDSPM QMPVPO
HRRZ XWAC3,XWAC4
AOJ XWAC3, ;Calculate user pos value
MTXPI
OUTCHB
HLRZ X1,XWAC4 ;Save original length
DUNSTK XWAC4 ;Fetch length of stripped text
FI
IFONA YDSSKT ;[41]
DRETURN ;[41] /-TEXT was given in command, skip characters
LI X0,QTEXTQ
OUTCHA
;Output characters
HLRZ XWAC3,XWAC4 ;Number of characters
SUB X1,XWAC3 ;Calculate length difference
LOOP
ILDB X0,LABB(YDST2)
;[41][2]
IF
;[41] DO NOT SKIP 0
THEN
IF ;Special character
CAIL X0," " ;[41]
GOTO FALSE
THEN ;Output ^ plus alphanumeric char.
DSTACK X0
LI X0,"^"
OUTCHA
DUNSTK
ADDI X0,100
FI
OUTCHA
FI
AS
IFON YDSSUP(XLOW) ;[41]
DRETURN ;[41] Do not output characters if ^C - REENTER given
DECR XWAC3,TRUE
SA
LI X0,QTEXTQ
IFONA YDSSTRING ;[51]
SKIPN ,X1 ;Blanks found at the end, omit "
OUTCHA
DRETUR
FI
IF ;REF
CAIE XDTYP,QREF
GOTO FALSE
THEN
HRRZS XWAC3 ;[1] zero lh
IF ;NONE
CAIE XWAC3,NONE
GOTO FALSE
THEN ;Output NONE
LI X1,LAB(ZKWNONE)
L2():! ;Output symbol
MDSPSK
DRETUR
FI
IF ;REF var uninitialized
JUMPN XWAC3,FALSE
THEN
MDSPM QMPVRI ;Ref variable 0
DRETUR ;[242]
FI
;Valid ref variable
;Check qualification
LI X1,XWAC3
L XDT2,XDZSD
SETO X0, ;Both NONE and subclass ok
;[66] No ZSD check, moved to DSCSQU
MCSQU
SKIP ;Ignore error
L XDSTA,XWAC3
MDSFA ;Output class identifiction
DRETUR
FI
;SIMDDT implementation error, invalid type
GOTO LAB(DSIE)
EPROC
SUBTTL DSPVS, SIMDDT subroutine
Comment/
Purpose:
Treat output of array identifier and complete blocks
Input arguments see DSPV
Normal exit: DRETUR if array or * found
SKIP DRETUR if no action
/
PROC
DSPVS: ;[41]
IF ;ARRAY output enabled
IFOFFA YDSOAI
GOTO FALSE
THEN
;Output array
;That is name plus array bounds and
;all elements that do not have their initial values
ST XDTYP,LABB(YDSTYP) ;Save type
L X1,XDT5 ;Address of ZSD entry
;XDADR=address of array
DSTACK X1 ;
DEXEC DSPAE ;Output elements
DUNSTK
GOTO LAB(DSPVS1)
FI
IF
CAIE XDTYP,"*"
GOTO FALSE
THEN
;Output all variables in block
;* or .* found
LF X0,ZTVCP(XDINT,ZTV%S)
SKIPE X0,X0
MDSVO ;Start on new line
SETONA YDSOSB
DSTACK XDSTA
ST XDADR,LABB(YDSSBA)
L XDSTA,XDADR
DSTACK XDT5
MDSFA
MDSVO ;Output block identification
DUNSTK XDT5
L XDZLN,LABB(YDSCZS)
IF
JUMPE XDT5,FALSE ;*
THEN ;Reference.*
LF X1,ZSDZPR(XDT5,-1)
SKIPGE ,(XDT5)
LF X1,ZSDZPR(XDT5)
ELSE ;Current block output
DEXEC DSPCL ;Output line identification
L XDZLN,LABB(YDSCZS)
L X1,LABB(YDSCZL)
JUMPE X1,LAB(L3()) ;[154] No line found
WHILE
LF X0,ZLNTYP(X1)
CAIGE X0,QCEXT
GOTO LAB(L2())
CAIG X0,QFEXT
GOTO LAB(L1())
L2():! CAIE X0,QEBLOCK
GOTO FALSE
DO
LF X1,ZLNADF(X1)
L1():!
LI X1,(X1)
CAMN X1,LABB(YDSCZS)
BRANCH LAB(DSTERM)
LF X1,ZLNBLK(X1)
ADD X1,LABB(YDSCZS)
OD
;Fetch prototype or subblock state
IF ;Reduced subblock
CAIE X0,QRBLOCK
GOTO FALSE
THEN
LF X1,ZLNADF(X1)
HRL XDZLN,X1 ;Insert sublock level
L X1,LABB(YDSSBA)
LF X1,ZBIZPR(X1) ;Fetch prototype
ELSE
IF ;INSPECT block
CAIE X0,QINSPEC
GOTO FALSE
THEN
HRRE XDSTA,(X1) ;Fetch display level
ADD XDSTA,LABB(YDSSBA)
L XDSTA,(XDSTA)
ST XDSTA,LABB(YDSSBA)
SOJ X1,
FI
LF X1,ZLNADF(X1) ;Fetch prototype
IF ;Unreduced subblock
CAIE X0,QUBLOCK
GOTO FALSE
THEN
LFE XDSTA,ZPREBL(X1)
ADD XDSTA,LABB(YDSSBA)
L XDSTA,(XDSTA)
ST XDSTA,LABB(YDSSBA)
FI
FI
FI
L4():! ;[154]
Li X0,LAB(DSVA01)
DEXEC DSSSP
DUNSTK XDSTA
SETOFA YDSOSB
DSPVS1: IFONA YDSCSTOP
SETONA YDSTOP ;Control stop if breakpoint processing
DRETUR
FI
AOS ,(XDSTK)
DRETUR
;Skip return normal case with no action
L3():! ;[154] Find prototype and level from current block
;[154] when no line number table exists
L X1,LABB(YDSSBA) ;[154]
LF X0,ZBIBNM(X1) ;[154]
LF X1,ZBIZPR(X1) ;[154]
HRL XDZLN,X0 ;[154]
GOTO LAB(L4()) ;[154]
EPROC
SUBTTL DSFA, SIMDDT subroutines
Comment/
Purpose:
Put class,procedure or block identification
in outtext
Find reactivation address in ZDRARE and
call DSPL to locate line and put line
identification in output buffer
Entry: DSFA
Input argument: XDSTA block instance address
Normal exit: DRETUR
Error exit: -
Output argument:-
Used subroutines:DSPSP,DSPLO,DSOC,DSPM and DSPL
/
DSFA: PROC
DSTACK XDSTA
SETOFA YDSACB
LF XDZPR,ZBIZPR(XDSTA)
MDSPSP ;Put name or block type
OUTCHB ;Output octal address of block instance
DEXEC DSPLO
OUTCHB
OUTCHB
;[2]
LF X0,ZDNTYP(XDSTA)
CAIE X0,QZBI ;Subblocks and
CAIN X0,QZPB ;prefixed blocks have
GOTO LAB(L1()) ;no valid return address
IF ;Terminated block
IFOFF ZDNTER(XDSTA)
GOTO FALSE
THEN
MDSPM QMFAAT ;Terminated class
ELSE
SETONA YDSACB ;Assume active block
IF ;Detached
IFOFF ZDNDET(XDSTA)
GOTO FALSE
THEN
SETOFA YDSACB
MDSPM QMFADE ;DETACHED CLASS
FI
LF XDSTA,ZDRARE(XDSTA)
MDSPL ;Put line ident.
FI
L1():! ;[2]
DUNSTK XDSTA
DRETUR
EPROC
SUBTTL DSVIV, SIMDDT subroutines
Comment/
Purpose: Check if variable value is initial value
Entry: DSVIV
Input arguments:
XDADR address of variable
XDTYP variable type
Normal exit: DRETURN if initial value
Error exit: Skip DRETURN
Output arguments:-
Used subroutines:-
/
DSVIV: PROC
IF ;LONG REAL
CAIE XDTYP,QLREAL
GOTO FALSE
THEN ;Check second word first, fall into false branch if zero
SKIPN 1(XDADR)
GOTO FALSE
ELSE
IF ;[1] Not REF
CAIN XDTYP,QREF
GOTO FALSE
THEN ;Initial value is zero
SKIPN (XDADR)
GOTO LAB(L1())
ELSE ;Must clear left half for REF
HRRZ X0,(XDADR) ;[1]
CAIE X0,NONE
FI
FI
AOS (XDSTK) ;Skip return if not initial value
L1():! DRETUR
EPROC
SUBTTL DSVAR, SIMDDT subroutines
Comment/
Purpose: Fetch subscript, dope vector and base address for
array element
Entry: DSVAR
Input argument:Array address in -3(XDSTK )
Normal exit: DRETUR
Error exit: -
Output arguments:XDT5 last subscript
XDT3 last dope vector
XDT4 number of subscripts
X0 -start address of zero element
Used subroutines:-
/
DSVAR: PROC
L XDT3,-3(XDSTK) ;Fetch array address
MOVN X0,ZARBAO(XDT3)
LF XDT4,ZARSUB(XDT3)
ADDI XDT3,(XDT4)
ADDI XDT3,2(XDT4)
L XDT5,XDT3
ADDI XDT3,(XDT4)
DRETUR
EPROC
SUBTTL DSGS, SIMDDT subroutines
Comment/
Purpose: Get next string character from input
Entry: DSGS
Input arguments:Current input pointer
Normal exits: DRETUR if end of input
Skip DRETUR if final " found
Double skip DRETUR if normal character found
Output argument:XDBYTE current character
Used subroutines:DSSCI
/
DSGS: PROC
LI XDMN,QMGSSE
MDSSCI ;Get next input byte
IF ;Not end of input
JUMPE XDBYTE,FALSE
THEN
AOS ,(XDSTK)
IF ;Text quote
CAIE XDBYTE,QTEXTQ
GOTO FALSE
THEN ;Check next char also
MDSSCI
IF ;Not also a quote
CAIN XDBYTE,QTEXTQ
GOTO FALSE
THEN ;We have the final quote
LI XDBYTE,QTEXTQ
GOTO LAB(L9())
FI
FI
AOS ,(XDSTK)
FI
L9():! DRETUR
EPROC
SUBTTL DSGL, SIMDDT subroutines
Comment/
Purpose: Get statement identification <line> from input.
Return address of corresponding line number table entry
Entry: DSGL
Input arguments:
Input pointer
Current module in YDSZLN
Normal exit: Skip DRETUR if <line> ok
[2] or call from DSDP and
<line> not located in ZLN table
Error exit: DRETUR
Output arguments:
See DSLL subroutine
YDSNDL new line number
Used subroutines:DSGI,DSSKB,DSEZLN,DSSCIR,DSLL,DSOEM
/
DSGL: PROC
DSTACK YDSZLN(XLOW) ;Current module
n==1
DEXEC DSSKBN ;[242]
IF ;Identifier follows
DEXEC DSGIS ;[242]
GOTO FALSE
THEN ;Module name
DEXEC DSSKBN
LI XDMN,QMGLCM ;Colon missing
IF ;[242] No colon found
CAIN XDBYTE,":"
GOTO FALSE
THEN ;Check for end of line, ok if so
DEXEC DSSKBN
LI XDMN,QMGLCM ;Missing colon after module
JUMPN XDBYTE,LAB(L1())
ELSE
DEXEC DSSKB
FI ;[242]
L X1,YDSZLA(XLOW)
IF ;Not "MAIN"
CAMN XDSYM1,1+LAB(ZKWMAIN)
GOTO FALSE ;MAIN FOUND
THEN ;Probably external module
LOOP ;Through main ZLN table
DEXEC DSEZLN
LI XDMN,QMGLEM
IF ;[242] Not found
JUMPN X1,FALSE
THEN ;Check against program name
HRROI X0,3
GETTAB X0,
GOTO LAB(L1())
CAME X0,XDSYM1
GOTO LAB(L1()) ;No match
L X1,YDSZLA(XLOW) ;OK, use MAIN
GOTO LAB(L5())
FI
AS
CAMN XDSYM1,OFFSET(ZSMRN1)(XDT2)
CAME XDSYM2,1+OFFSET(ZSMRN1)(XDT2)
GOTO TRUE ;Try next
SA
;Valid external module name
FI
L5():! ST X1,(XDSTK)
FI
DEXEC DSSCIR ;Back up one input character
IF ;[242] Called from DSDP
HRRZ X0,-n(XDSTK)
CAIE X0,LAB(DSDPGL)
GOTO FALSE
THEN ;Allow extended line no format
L X0,1-n(XDSTK) ;Line no table address determined
DEXEC DSGLEL
GOTO LAB(L2())
ST XWAC1,LABB(YDSNDL) ;New display line
ELSE ;Accept only an integer
MTXGI
GOTO LAB(L2()) ;Error already given
FI
L XDLIN,XWAC1
L XDT2,(XDSTK) ;Fetch module entry in main ZLN
IF ;External module
CAMN XDT2,YDSZLA(XLOW)
GOTO FALSE
JUMPE XDT2,FALSE ;[154]
THEN
LF XDT2,ZLNADR(XDT2)
LF XDT2,ZPRSYM(XDT2)
LF XDT2,ZSMZLN(XDT2)
ELSE ;[154] assume main prog
L XDT2,YDSZLA(XLOW)
FI
MDSLL
GOTO LAB(L3()) ;Error found
L4():! AOS -n(XDSTK) ;Normal return
L2():!
DUNSTK
SKIPN ;[242]
L YDSZLA(XLOW) ;[242]
DRETUR
L3():! HRRZ X0,-n(XDSTK) ;Fetch return address
CAIN X0,LAB(DSDPGL) ;[2]
GOTO LAB(L4()) ;[2] Skip error message if called from DSDP
LI XDMN,QMGLIL ;Invalid line number
L1():! MDSOEM
GOTO LAB(L2())
EPROC
SUBTTL DSGLEL, SIMDDT internal subroutine ;[242]
Comment/
Purpose: Interpret a line definition in one of the following forms:
a) n
b) n+k (not implemented)
n is normally a decimal number, but may be replaced by:
. to denote the current display line + 1
^ to denote the first line of the file
* to denote the last line of the file
n may be omitted to denote last displayed line + 1
(same as .)
n+k designates the kth line following the line numbered n
Input: YDSCDL current display line
YDSDZLN current display file or zero
X0 module name of new display file
Output: Line number in XWAC1 ...
No valid spec is interpreted as ".",
but YDSLDL is set to -1 to flag this.
Normal return: Skip
Error return: No skip
Uses: DSTXG1
/
DSGLEL: PROC
DSTACK X0
n==1 ;One stack item
MDSSCI ;Next character
IF ;A digit follows
CAIL XDBYTE,"0"
CAILE XDBYTE,"9"
GOTO FALSE
THEN ;Get the value
DEXEC DSSCIR ;Back up to previous char
DEXEC DSTXGI
GOTO LAB(L9()) ;Should not happen
GOTO LAB(L8()) ;No error, we have an integer
FI
;There was no integer, check for other valid characters
SETZ XWAC1,
CAIN XDBYTE,"^" ;Treat "^" like zero
GOTO LAB(L8())
IF ;"*"
CAIE XDBYTE,"*"
GOTO FALSE
THEN ;Return maxint
HRLOI XWAC1,377777
GOTO LAB(L8())
FI
IF ;"."
CAIE XDBYTE,"."
GOTO FALSE
THEN ;Current line + 1 if same module, otherwise 0
L7():! L (XDSTK) ;New module line no table
IF ;Same as any current display module line no table
CAME LABB(YDSCDZLN)
GOTO FALSE
THEN ;Take current line + 1
L XWAC1,LABB(YDSCDL)
ADDI XWAC1,1
FI
GOTO LAB(L8())
FI
;None of the valid characters, return current line no
SETOM LABB(YDSLDL) ;Flag "no line no"
DEXEC DSSCIR ;Back up one char
GOTO LAB(L7()) ;Join code for "."
L8():! AOS -n(XDSTK)
L9():! DUNSTK
DRETURN
EPROC
SUBTTL DSGV, SIMDDT subroutines
Comment/
Purpose: Get <value> from input text
and save information in ZBE entries
Entry: DSGV
Input arguments:
XDZBE first free ZBE entry
XDZLN current block stack entry in ZLN
XDTYP type of value which must match new value
Normal exit: Double skip DRETUR if identifier value
Skip DRETUR if constant value found
Error exit: DRETUR
Output arguments:
XDZLN and XDZBE unchanged
XDTYP type of constant or identification found
YDST1 constant value if any
Used subroutines:DSGI,DSFKI,DSNIS,DSSCIR,DSGS,DSRAT,TXCY,DSTXG,
DSSKB,DSFBN,DSGVTP,DSOEM
/
DSGV: PROC
;Input
; XDZBE
; XDZLN
; XDTYP
;Saving of accumulators is dependent on DSNI coding!
DSTACK XDTYP
DSTACK XDZBE
DSTACK XDZLN
IF ;Identifier found
MDSGI
GOTO FALSE
THEN
IF ;Not a keyword or not a constant
MDSFKI
JUMPE XDZKW,TRUE ;No match
IFEQF (XDZKW,ZKWTYP,QZKWTQ)
GOTO FALSE ;Constant
THEN ;Normal identification must follow
;Call DSNI
L XDZBE,-1(XDSTK)
LI X0,LAB(DSGVR)
EXCH X0,-2(XDSTK) ;Store return address
ST X0,LABB(YDSTYP)
BRANCH LAB(DSNIS) ;Special entry
DSGVR: ;Return from DSNI
DRETUR ;Error found, return
L XDZBE,X0 ;Identifier XDZBE
L XDTYP,LABB(YDSTYP)
;Restore stack
DSTACK XDTYP
DSTACK XDZBE
DSTACK XDZLN
DEXEC DSGVTP ;Check type
AOS ,-3(XDSTK)
BRANCH LAB(L4()) ;Exit correct
FI ;identification found
;Constant found
DEXEC DSSCIR ;Back one char.
L7():! ;"" Found
SETZ X1,
LF X0,ZKWVAL(XDZKW)
CAIN X0,1
SETO X0, ;TRUE found
LF XDTYP,ZKWCOD(XDZKW)
L XDZBE,-1(XDSTK)
GOTO LAB(L3())
FI
;No start of identifier
LDB XDBYTE,LABB(YDSIPO)
JUMPE XDBYTE,LAB(L5())
IF ;Character constant
CAIE XDBYTE,"'"
GOTO FALSE
THEN
MDSSCI ;Character
L X1,XDBYTE ;Save
MDSSCI ;Should be closing '
LI XDMN,QMGVCE
CAIE XDBYTE,"'"
GOTO LAB(L2()) ;Error final ' missing
LI XDTYP,QCHARACTER
L X0,X1 ;RESTORE VALUE
GOTO LAB(L3())
FI
IF ;Text string
CAIE XDBYTE,QTEXTQ
GOTO FALSE
THEN
SETZ X1,
;Initiate extra input buffer
L X0,LAB(<[POINT 7,ZTE%S-1+2*<QDSION+5>/5+LABB(ZDSZTE),34]>)
ST X0,LABB(YDSIPE)
ZF ZTVCP(XDINT,<ZTV%S+ZTV%S>)
LOOP ;Get string contents
MDSGS
AS
GOTO LAB(L2()) ;Error exit
GOTO FALSE ;End of text input
IDPB XDBYTE,LABB(YDSIPE) ;New character
AOJA X1,TRUE
SA
IF ;NOTEXT
JUMPN X1,FALSE
THEN LI XDZKW,LAB(ZKWNOT)
GOTO LAB(L7())
FI
;Correct string found
SF X1,ZTVLNG(XDINT,<2*ZTV%S>)
DMOVE X0,2*ZTV%S(XDINT)
IF ;AT command
HRRZ XDT2,-3(XDSTK)
CAIE XDT2,LAB(DSAT02)
GOTO FALSE
THEN
DEXEC DSCHGC ;[41]
GOTO LAB(L1()) ;[41] Not allowed if GC inhibited
;String must be copied and saved
DEXEC DSRAT ;Reserve array element
JUMPE X1,LAB(L2())
ST X1,LABB(YDST1) ;Save
DUNSTK XDZLN ;Not to be relocated
LD XWAC1,2*ZTV%S(XDINT)
MTXCY ;Copy string
DSTACK XDZLN
L X2,YDSTXT(XLOW)
LF X2,ZARBAD(X2)
ADD X2,LABB(YDST1)
ADD X2,LABB(YDST1) ;2 Words per element
SUBI X2,2
STD XWAC1,(X2) ;Save string copy
; reference in array
L X0,LABB(YDST1)
FI
LI XDTYP,QTEXT
GOTO LAB(L3())
FI
;Integer or real constant
L XDTYP,-2(XDSTK)
SETOFA YDSTXR ;Assume integer
IF ;Not integer
CAIN XDTYP,QINTEGER
GOTO FALSE
THEN ;Must be (long) real
IF ;Not (long) real
CAIE XDTYP,QLREAL
CAIN XDTYP,QREAL
GOTO FALSE
THEN ;Error
GOTO LAB(L5())
FI
SETONA YDSTXR
FI
;Call TXGI or TXGR
DEXEC DSSCIR ;Back one char.
DEXEC DSTXG
GOTO LAB(L1()) ;Error
L XDTYP,-2(XDSTK)
DMOVE X0,XWAC1 ;Fetch value
L3():! ;Return constant
DMOVEM X0,LABB(YDST1)
DEXEC DSSKB
SETON ZBETCI(XDZBE)
MDSFBW
GOTO LAB(L1())
L X0,LABB(YDST1)
SF X0,ZBEVAL(XDZBE) ;Save value
IF
CAIE XDTYP,QLREAL
GOTO FALSE
THEN
MDSFBW
GOTO LAB(L1())
L X1,1+LABB(YDST1)
SF X1,ZBEVAL(XDZBE)
FI
DEXEC DSGVTP
L4():!
AOS ,-3(XDSTK)
L1():! ;Exit
DUNSTK XDZLN
DUNSTK XDZBE
DUNSTK
DRETUR
L5():! LI XDMN,QMGVEL ;CONSTANT OR VALUE EXPECTED
L2():! ;Create message
MDSOEM
GOTO LAB(L1())
DSGVTP: ;Internal subroutine
;XDTYP and YDSSTP
IF
CAMN XDTYP,LABB(YDSSTP)
GOTO FALSE
THEN
LI X1,LAB(L2()) ;Address of error exit
LI XDMN,QMGVTD ;Possible type error
CAIE XDTYP,QREAL
CAIN XDTYP,QLREAL
SKIPA
ST X1,(XDSTK) ;Change return address on error
L X0,LABB(YDSSTP)
CAIE X0,QREAL
CAIN X0,QLREAL
SKIPA
ST X1,(XDSTK)
FI
DRETUR
EPROC
SUBTTL DSRL, SIMDDT subroutine
PROC
Comment/
Purpose: Remove breakpoint commands
Entries: DSRLB removes all information from one breakpoint command
DSRLBA same as DSRLB but error has occurred
while scanning command
DSRLBI removes a breakpoint instruction from user code
Does not remove ZBE entries
DSRL removes information from all breakpoint commands
that refer to the same breakpoint line
Input arguments:
XDZBE start of breakpoint ZBE entry
for DSRLB and DSRLBA calls
Start of ZBR entry for DSRL call
X1 ZBR entry if DSRLBI call
-1(XDSTK) ZBR entry for breakpoint on DSRLB and DSRLBA calls
Normal exit: DRETUR
Error exit: -
Output arguments:-
Used subroutines:
DSNB,DSPI,DSONL,DSFAT,DSFAR
/
DSRLB: ;Reset for one breakpoint only
;Release breakpoint instruction if no more commands left
;-1(XDSTK)contains ZBR entry
;XDZBE contains start of breakpoint
DSTACK XDZBE
LF XDT2,ZBETYP(XDZBE)
IFON ZBESTB(XDZBE)
MDSNBW
IF ;AT ... <relation> or AT ... IFCHANGED command
CAIN XDT2,QBEATR
GOTO TRUE
CAIE XDT2,QBEATC
GOTO FALSE
THEN
LOOP
MDSNBW
MDSPI
L XDZBE,X0 ;Last referenced ZBE entry
LI XDT3,QREF ;Assume THIS
IF ;[41] THIS
IFON ZBETHI(X1)
GOTO FALSE
THEN
LF X1,ZBEZSD(X1) ;Last referenced identifier
LF XDT3,ZSDTYP(X1)
FI ;[41] End
DEXEC DSONL ;Remove identification
MDSNBW
IF ;AT nnn <relation>
CAIE XDT2,QBEATR
GOTO FALSE
THEN
IFOFF ZBETCI(XDZBE)
SETZ XDT3, ;No interesting ZBE
CAIN XDT3,QREF
SETZ XDT3,
MDSNBW ;Skip operator entry
FI
L X1,(XDZBE) ;Element number
CAIN XDT3,QLREAL
MDSNBW
CAIN XDT3,QREF
DEXEC DSFAR ;Release element
IF
CAIE XDT3,QTEXT
GOTO FALSE
DEXEC DSFAT
CAIE XDT2,QBEATC
GOTO FALSE
THEN
MDSNBW
L X1,(XDZBE)
DEXEC DSFAT
FI
AS
IFONA YDSLIST
GOTO TRUE ;Check next identification
SA
FI
;QBEAT and QBEATL no special processing
DUNSTK XDZBE
DSRLBA: ;Reset from DSAT if error occurred
;Array elements for text and ref released already
DSTACK XDZBE
IF JUMPE XDZBE,FALSE
THEN
LOOP ;Find all continuation entries
LF XDT2,ZBEZBE(XDZBE)
AS
JUMPE XDT2,FALSE ;No more continuation entries
ADDI XDT2,(XDZBR)
LF X1,ZBETYP(XDT2)
CAIE X1,QBECON
GOTO FALSE
L XDZBE,XDT2
HRLI XDZBE,-QZBEL ;Build ZBE pointer
GOTO TRUE
SA
SETZM ,(XDZBE) ;Indicate end of chain
;XDT2 is 0 or points at new command ZBE entry after the one to be released
;Complete chain again
L XDZBE,-2(XDSTK) ;Fetch ZBR entry
LOOP
L X1,XDZBE
MDSNB ;Next ZBE
AS
CAME XDZBE,0(XDSTK)
GOTO TRUE
SA
;X1 points at ZBR entry or last ZBE before
;the one to be released
SKIPE ,XDT2
SUBI XDT2,(XDZBR) ;Calculate link
SF XDT2,ZBEZBE(X1)
FI
IF ;All commands for the line are not reset
L X1,-2(XDSTK) ;Fetch ZBR pointer
LF X0,ZBRZBE(X1)
JUMPN X0,FALSE ;More break commands left
THEN
DEXEC DSRLBI ;Remove breakpoint
FI
IF
JUMPE XDZBE,FALSE
;XDZBE contains start of breakpoint command
;to be reset
THEN
MDSRB
FI
DUNSTK
DRETUR
EPROC
PROC
DSRLBI: ;Remove breakpoint instruction if any
;X1 points at ZBR entry
IF
LF XDT2,ZBRZLN(X1)
JUMPE XDT2,FALSE
THEN
LF XDT2,ZLNADR(XDT2) ;Fetch instruction address
HLRZ X0,(XDT2)
IF ;There is a breakpoint instr in the code
CAIE X0,(BREAK)
GOTO FALSE
THEN ;Restore original instr
LF X0,ZBRINS(X1)
ST X0,(XDT2)
FI FI
SETZM (X1) ;Clear breakpoint entry
DRETUR
EPROC
PROC
DSRL: ;Remove all commands for one breakpoint line
;XDZBE points at ZBR entry
DSTACK XDZBE
WHILE
L XDZBE,(XDSTK)
DEXEC DSNBC
JUMPE XDZBE,FALSE ;All commands treated
DO
MDSRLB
OD
DUNSTK XDZBE
DRETUR
EPROC
SUBTTL DSPB, SIMDDT subroutine
Comment/
Purpose: Reconstruct breakpoint command in output buffer
Entries: DSPBS reconstruct upto first identifier
DSPBT reconstruct complete command
Input arguments:XDZBE start of command ZBE entry
-2(XDSTK) ZBR entry for command
Normal exit: DRETUR
Error exit: -
Output arguments:
X0 XDZBE given in call
XDZBE last referenced ZBE entry
Used subroutines:
DSPSKB,DSPL,DSOC,DSNBW,TXPI,DSPSC,DSFCV,DSPVNS
/
PROC
IF
THEN
DSPBS:
DSPB:
SETOFA YDSPBT
ELSE
DSPBTS:
DSPBT:
SETONA YDSPBT
FI
DSTACK XDZBE
;Put stop in text
LI X1,LAB(ZKWSTOP)
IFON ZBESTO(XDZBE)
DEXEC DSPSKB
;Put AT in text
LI X1,LAB(ZKWAT)
DEXEC DSPSKB
LF XDT2,ZBETYP(XDZBE)
L X1,-2(XDSTK) ;Fetch ZBR addresss
ST XDT2,LABB(YDSTIP) ;Save command type
LF XDZLN,ZBRZLN(X1)
LF XDSTA,ZLNADR(XDZLN)
DEXEC DSPL ;Put line identification in text
DEXEC DSOCB
L XDZBE,(XDSTK)
IF
IFOFF ZBESTB(XDZBE)
GOTO FALSE
THEN
L X1,LAB(<[POINT 7,(XDZBE),34]>)
LI X0,QTEXTQ
OUTCHA
WHILE
ILDB XDBYTE,X1
TRNE X1,2
GOTO FALSE ;All 5 characters moved
DO
OUTCHA
OD
LI X0,QTEXTQ
OUTCHA
OUTCHB
MDSNBW
FI
MDSNBW
IF
L XDT2,LABB(YDSTIP) ;Fetch type
CAIE XDT2,QBEAT
GOTO FALSE
THEN
;Simple AT
L XDZBE,(XDSTK)
LF XWAC3,ZBENIN(XDZBE,2)
CAIN XWAC3,1
GOTO LAB(L1()) ;Exit if default 1
LI X0,","
OUTCHA
MTXPI ;Output counter
GOTO LAB(L1())
FI
SETOFA YDSCHG
L XDT2,LABB(YDSTIP)
CAIN XDT2,QBEATC
SETONA YDSCHG
IFOFFA YDSPBT
GOTO LAB(L1()) ;Exit if not total
LI X1,LAB(ZKWIF)
CAIN XDT2,QBEATR
DEXEC DSPSKB
LI X1,LAB(ZKWIFC)
IFONA YDSCHG
DEXEC DSPSKB
;Output identification
LOOP
MDSPI
L XDZBE,X0 ;Last referenced ZBE entry
LI XDT3,QREF ;Assume THIS
IF ;[41] THIS
IFON ZBETHI(X1)
GOTO FALSE
THEN
LF X1,ZBEZSD(X1) ;Last referenced identifier entry
LF XDT3,ZSDTYP(X1) ;Fetch variable type
FI ;[41] End
AS
IFOFFA YDSLIST
GOTO FALSE
LI X0,","
OUTCHA
;Skip ZBE value entries if changed
IF
IFOFFA YDSCHG
GOTO FALSE
THEN
MDSNBW
CAIE XDT3,QTEXT
CAIN XDT3,QLREAL
MDSNBW
FI
MDSNBW
GOTO TRUE
SA
L XDT2,LABB(YDSTIP)
CAIE XDT2,QBEATR
GOTO LAB(L1()) ;Exit if not relational
OUTCHB
MDSNBW
LF X1,ZBEROP(XDZBE)
ADDI X1,(XDBAS) ;[102] Use relative address in ZBE
DEXEC DSPSKB ;Put relational operator
LF XDT2,ZKWCOD(X1)
WLF X1,ZBEROP(XDZBE)
MDSNBW
IF ;IS or IN class identifier follows
CAIE XDT2,QOOP
GOTO FALSE
THEN
L XDT4,(XDZBE)
MDSNBW
L XDT5,(XDZBE) ;Fetch class identifier
LI X1,XDT4-1
DEXEC DSPSC
ELSE
IF
IFOFFA ZBETCI(X1)
GOTO FALSE
THEN ;Value follows
L XDTYP,XDT3
DEXEC DSFCV
L XDADR,XDARR
SETOFA YDSSTRING
DEXEC DSPVNS ;Put value in outtext
ELSE ;Identification follows
MDSPI
FI FI
L1():! ;EXIT
DUNSTK
DRETUR
EPROC
SUBTTL DSLB, SIMDDT subroutine
PROC
Comment/
Purpose: Scan the ZBR records and match the entries
against an input statement identification
Entry: DSLB
Input argument:XDZLN ZLN table entry
Normal exit: Skip DRETUR if match found
Error exit: DRETUR if no match
Output arguments:
XDZBE matching ZBR entry
X1 last free ZBR entry if no match
0 if no free ZBR entries
Used subroutines:-
/
DSLB: ;Locate breakpoint
SETZ X1,
LI XDT2,QBRN
LI XDZBE,LABB(DSZBRF)
LOOP
IF ;Unused
LF X0,ZBRZBE(XDZBE)
JUMPN X0,FALSE
THEN
L X1,XDZBE ;Save unused entry
ELSE
IF ;This is it
LF X0,ZBRZLN(XDZBE)
CAME XDZLN,X0
GOTO FALSE
THEN
AOS,(XDSTK)
DRETUR ;Skip return if entry found
FI
FI
AS
ADDI XDZBE,2
DECR XDT2,TRUE
SA
DRETUR ;Not found exit
EPROC
SUBTTL DSRAT, DSRAF, DSFAT and DSFAR, SIMDDT subroutines
Comment/
Purpose: Reserve or release elements in YDSREF or YDSTXT
Entries: DSRAF reserve any free element in array YDSREF
DSRAT reserve any free element in array YDSTXT
DSFAR release element in YDSREF array
DSFAT release element in YDSTXT array
Input arguments:
X1 contains element to be released if DSFAR or DSFAT
Normal exit: DRETUR
Error exit -
Output arguments:
X1 element number if DSRAF or DSRAT entries
0 if none available
Used subroutines:DSBPRA,DSBPTA
/
PROC
DSRAF: ;Reserve any free ref array element
MOVNI X1,QDSRN
LI X3,LABB(YDSRRA)
LI XDARR,LAB(DSBPRA) ;Address of get address of element
;routine
;Used to initialize element
GOTO LAB(DSRAC)
DSRAT: ;Reserve any free text array element
MOVNI X1,QDSTN
LI X3,LABB(YDSTRA)
LI XDARR,LAB(DSBPTA) ;See above
DSRAC: ;Common part
LI X0,1
ROT X0,(X1)
MOVN X1,X1
WHILE
JUMPE X0,LAB(L1())
TDNN X0,(X3)
GOTO FALSE ;Free element found
DO
SOJ X1,
LSH X0,1
OD
IORM X0,(X3) ;Reserve element
SKIPA
L1():!
LI XDMN,QMRANE
;X1=0 if no free found
;Otherwise X1 is element number
DRETUR
EPROC
PROC
DSFAR: ;Free ref array element
LI XDT3,LABB(YDSRRA)
SKIPA
DSFAT: ;Free text array element
LI XDT3,LABB(YDSTRA)
;Common part, X1 contains array element number
IF
JUMPE X1,FALSE
THEN
LI X0,1
MOVN X1,X1
ROT X0,(X1)
IORM X0,(X3)
XORM X0,(X3)
FI
DRETUR
EPROC
SUBTTL DSFCV, SIMDDT subroutine
PROC
Comment/
Purpose: Load address of constant to accumulator
Entry: DSFCV
Input argument: XDZBE ZBE entry to constant value
XDTYP type of constant
Normal exit: DRETUR
Error exit: -
Output arguments:XDARR address of constant value
Used subroutines:DSNBW,DSBPTAE
/
DSFCV:
;Find address of constant
;XDARR contains address of constant value at exit
L XDARR,XDZBE
IF
CAIE XDTYP,QLREAL
GOTO FALSE
THEN
;Handle real
L X0,(XDARR)
MDSNBW
L X1,(XDZBE)
STD X0,LABB(YDST1)
LI XDARR,LABB(YDST1)
FI
CAIN XDTYP,QTEXT
DEXEC DSBPTAE
DRETUR
EPROC