Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/20/simds2.mac
There are 2 other files named simds2.mac in the archive. Click here to see a list.
PRINTX SIMDS2.MAC
SUBTTL DSFK SIMDDT subroutine
COMMENT;
Purpose: To look for a symbol in the keyword table
Entries: DSFKI exact match must be found
DSFK A match is accepted if all nonblank
input characters are found in one and
only one table entry
Input arguments:XDSYM1 and XDSYM2 contain symbol identifier
Normal exit: DRETUR
Error exit: none
Output arguments:
XDZKW address of matching keyword entry
or
zero if no match
Call format: DEXEC DSFKI
DEXEC DSFK
Used subroutines:none
;
DSFKI: PROC
MDSFK ;Call DSFK to find possible match
SKIPGE X0 ;[242]
SETZ XDZKW, ;[242] No match
DRETURN
EPROC
DSFK: PROC
LI XDZKW,LAB(ZKW)
SETZ X0,
DSTACK X0 ;Assume no match initially
LOOP
LDB X0,[POINT 6,XDSYM1,5]-$$RELO($$BAS)
LDB X1,[POINT 6,1(XDZKW),5]-$$RELO($$BAS)
IF ;First 6 char's could match
CAMLE X0,X1
GOTO FALSE
THEN ;This must be a match or we have no full match
CAME X0,X1
GOTO LAB(L2()) ;No more match possible
IF ;More than 6 char's
L X1,1(XDZKW)
L X0,XDSYM1
JUMPE XDSYM2,FALSE
THEN
IFOFF ZKWLNE
GOTO LAB(L1()) ;No match possible if table
;entry is six letters only
;Try next entry
CAME XDSYM1,1(XDZKW)
GOTO LAB(L1()) ;No match possible
;First six letters must match
L X0,XDSYM2
L X1,2(XDZKW)
FI
;Compare part of first or last six letters
IF ;Exact match
CAME X0,X1
GOTO FALSE
THEN ;Signal exact match to DSFKI
DUNSTK X0
DRETUR
FI
DSTACK X0 ;Save XDSYM1 or XDSYM2
LI X0,77
LOOP ;Try to match symbol against part of table entry
IOR X1,X0
XOR X1,X0
AS
CAMN X1,(XDSTK)
GOTO FALSE ;Match found
LSH X0,6
JUMPN X0,TRUE ;Blank next table character
DUNSTK X0
GOTO LAB(L1()) ;All letters blank, try next entry
SA
;Partial match found
DUNSTK X0
IF ;A previous match exists
SKIPN ,(XDSTK)
GOTO FALSE
THEN ;Ambiguous keyword, failure
SETZM ,(XDSTK)
GOTO LAB(L2()) ;Exit, no match found
FI
;The right entry may have been found, check rest
ST XDZKW,(XDSTK) ;Save table entry in stack
FI
AS
;Try next entry
L1():!
IFON ZKWLNE
AOJ XDZKW, ;Table entry has 12 letters in name
ADDI XDZKW,2
CAIG XDZKW,LAB(ZKWL)
GOTO TRUE ;Next table entry exists
SA
L2():! ;Exit, stack is 0 or table entry address
DUNSTK XDZKW ;Return value
SETO X0, ;Signal no exact match to DSFKI
DRETUR
EPROC
SUBTTL DSTC SIMDDT subroutines
Comment;
Purpose: To check if an input ascii character is valid
If so convert character to sixbit code
Entries:
DSTCR Relational characters and characters in
SIMULA identifiers are accepted
DSTCS Only characters in SIMULA identifiers are accepted
Input arguments:XDBYTE holds input ascii character
Normal exit: Skip DRETURN
Error exit: DRETUR, input not accepted
Output argument:XDBYTE holds sixbit character if valid
otherwise
XDBYTE unchanged
X1 address of valid character in table, used in DSGI
CALL FORMAT: DEXEC DSTCR
DEXEC DSTCS
SUBROUTINES: NONE
;
PROC
DSTCSR: ;Accept relational characters
DSTCR:
LI X1,LAB(L3())
GOTO LAB(DSTC.1)
DSTCL: ;[304] Accept letters and '_' only
LI X1,LAB(L4())
GOTO LAB(DSTC.1)
DSTCS: ;Accept characters in symbols
DSTC:
LI X1,LAB(L1())
DSTC.1: ST XDBYTE,LABB(YDST1)
LOOP
IF
HLRZ X0,(X1)
CAMLE X0,LABB(YDST1)
GOTO FALSE ;Not right entry
HRRZ X0,(X1)
CAMGE X0,LABB(YDST1)
GOTO FALSE ;Not right entry
THEN ;Entry valid
L XDBYTE,LABB(YDST1)
XCT ,1(X1) ;Convert to sixbit
AOS ,(XDSTK)
DRETUR ;Skip return, XDBYTE holds sixbit char.
FI
AS ;Try next entry
ADDI X1,2
CAIG X1,LAB(L2())
GOTO TRUE
SA
;No match
L XDBYTE,LABB(YDST1)
DRETUR ;Return, XDBYTE unchanged
;Conversion table
;Two words per group of ascii characters
;First halfword gives lower limit of ascii character
;Second halfword gives upper limit
;Second word gives conversion instruction
L3():! ;Relational characters
XWD 057,057
SUBI XDBYTE,040
XWD 074,076
SUBI XDBYTE,040 ;Convert to sixbit
XWD 134,134
SUBI XDBYTE,040
DSTC01: ; Used in DSGI
L1():! ;Symbol characters
XWD "0","9"
SUBI XDBYTE,040
L4():! XWD "@","Z" ;@,A TO Z ;[304] Reordered to exclude digits
SUBI XDBYTE,040
XWD 137,137 ;_
SUBI XDBYTE,040
XWD 043,044 ;# $
SUBI XDBYTE,040
XWD 140,172 ;Low @,a to z
SUBI XDBYTE,100
XWD 173,173 ;LOW #
LI XDBYTE,003
L2():! ;LAST TABLE ENTRY
XWD 175,175 ;LOW $
LI XDBYTE,004
EPROC
SUBTTL DSIT, SIMDDT Subroutine
Comment;
Purpose: Input text from TTY or file to input text variable
Entry: DSIT
Input arguments:none
Normal exit: DRETUR
Error exit: none
Errors generated:Input longer than 135 characters
CALL FORMAT: DEXEC DSIT
Used subroutines:DSOEM,DSINL,DSCLOS,DSOFTM,IOIG,DSCRTU
;
DSIT: PROC
MDSINL ;[41]
IFOFFA YDSITTY ;[41]
GOTO LAB(DSITFI) ;[41] Input from file
LOOP ;Input text from tty to input text variable
MOVNI X1,QDSION ;Max length
;Initialize input text variable
;Create byte pointer
MDSINL
LOOP
WHILE INCHWL XDBYTE ;Read from tty one
;character at a time but wait
;until line is complete
CAIGE XDBYTE," "
GOTO FALSE ;Test character
DO
L1():! ;Accept character
AOSG X1 ;[41] No store after overflow
IDPB XDBYTE,LABB(YDSIPO)
OD
AS
JUMPE XDBYTE,TRUE ;Null char. try next
CAIN XDBYTE,QCR
GOTO TRUE ;Skip carriage return
CAIN XDBYTE,33 ;[242] Replace altmode with LF
GOTO FALSE
CAIE XDBYTE,QVT
CAIN XDBYTE,QFF
GOTO FALSE ;Replace VT and FF with LF
CAIE XDBYTE,"G"-"A"+1
CAIN XDBYTE,"Z"-"A"+1
GOTO FALSE ;Replace BELL (^G) and EOF with LF
CAIE XDBYTE,QLF
GOTO LAB(L1()) ;Accept char.
SA
AS
;Break character found in input
LI XDBYTE,0
IDPB XDBYTE,LABB(YDSIPO) ;Store one null character at end of input
IDPB XDBYTE,LABB(YDSIPO) ;One extra null to enable DSSKBN
IF ;Not too many characters
JUMPG X1,FALSE
THEN ;Fix text length, byte pointer
ADDI X1,QDSION
SF X1,ZTVLNG(XDINT)
MDSINL
DRETUR ;Return
FI
MDSOEM QMITOW ;Overflow message
GOTO TRUE ;Try to read new line
SA
DSITFI: ;[41]
;Read input from file
SKIPE XWAC1,YDSIFO(XLOW) ;[242]
IFON ZIFEND(XWAC1)
GOTO LAB(L5()) ;End of file
SETZM YDSIGS(XLOW) ;Byte pointer reset
LI XDRTSR,IOIG
SETOFA YDSERE
DEXEC DSCRTU ;Inimage
DSIT02:;[304] To be checked on i/o error
IFONA YDSUFR
GOTO LAB(L5()) ;File error
IFON ZIFEND(XWAC1)
GOTO LAB(L5()) ;/* End of file
SETZM ,ZTE%S+QDSION/5+LABB(ZDSZTE)
;Zero to last word in buffer
IF ;Command output to TTY if necessary
SKIPN ,YDSIGS(XLOW)
GOTO FALSE
IFON ZFITTY(XWAC1) ;[302]
GOTO FALSE
THEN ;Put zero at end of ASCIZ string
LI X0,0
DPB X0,YDSIGS(XLOW)
OUTSTR ZTE%S+LABB(ZDSZTE)
OUTSTR LAB(DSOTCL) ;CRLF
LI X0," " ;Replace null with space
DPB X0,YDSIGS(XLOW)
FI
DRETUR
L5():! ;Error or end of file
SKIPE XWAC1,YDSIFO(XLOW) ;[242]
DEXEC DSCLOS
LI XDMN,QMITTI ;"USE INPUT FROM TTY"
DEXEC DSOFTM
SETONA YDSITTY ;[304]
GOTO LAB(DSIT)
EPROC
SUBTTL DSO, SIMDDT subroutines
Comment;
Purposes: To create a message in the output buffer and/or
to write the buffer on the user tty and/or the
output file (defined in USE command or SYSOUT)
ENTRIES: DSOFM Create message and output to current file
DSOF01
DSOF Output to current file
DSOBM
DSVOM
DSOFTM Create message and output both to current file
and to tty
DSVO
DSOFTA
DSOFT Output both to current file and to tty
DSOTM Create message and output to tty
DSOT Output to tty
DSOFCR Output blank line to file if present
DSOCR Reset ^O bit
DSOEM Output current input buffer and
output error to tty and file
Input argument: XDMN, message number if relevant
Normal exit: DRETUR
Error exit:
Error exit: none
Output argument: Output text pointer initialized
Call formats: DEXEC routine-name
Subroutines used:DSONL,DSPM,IOOG,DSSCI,DSCRTU
;
DSOTTC: edit(302) edit(304)
PROC
;[302] Non-skip return if USE file is a TTY (not controlling)
DSTACK X1
IFONA YDSTTY ;[304]
GOTO LAB(L2())
SKIPE X1,YDSUFO(XLOW)
SKIPL OFFSET(ZFIOPN)(X1)
GOTO LAB(L2()) ;No USE file or not open
WLF ,ZFIKAR(X1) ;DEVCHR bits
IFOFFA ZFITA ;Controlling TTY?
IFOFFA ZFITTY ;No, another TTY?
L2():! AOS -1(XDSTK) ;Controlling TTY or no usable TTY
DUNSTK X1
DRETUR
EPROC
PROC
DSOFM: ;Create message and output text to file
MDSPM ;Create message
DSOF: ;Output text to file
IFONA YDSTTY ;If current file is controlling tty
BRANCH LAB(DSOT) ;then continue at DSOT and return from there
DSOF01: ;Output to file
;Current file is not controlling tty
;Use RTS routine Outimage
DSTACK X1
DSTACK X2
DSTACK XDT3
DSTACK XDRTSR
;Make length of text variable equal to current pos
edit(242)
HRRZ XWAC1,YDSUFO(XLOW) ;[242]
LF X0,ZTVCP(XDINT,ZTV%S)
HRL X0,X0
ST X0,OFFSET(ZFIICP)(XWAC1)
edit(2) ;[2]
LI XDRTSR,IOOG
IFONA YDSBOI ;[2]
LI XDRTSR,IOBO ;[2] Call IOBO (Breakoutimage) instead
DEXEC DSCRTU ;Call IOOG or IOBO
DSOF02: ;Checked from DSINC2 to find output error on USE file
SETOFA YDSUFR
ST XDSWIT,YDSWIT(XLOW)
DUNSTK XDRTSR
DUNSTK XDT3
DUNSTK X2
DUNSTK X1
MDSONL
DRETUR
DSOFCR: ;Output blank line if file USEd (if not a TTY)
IFOFFA YDSTTY
DEXEC DSOTTC ;[302]
DRETUR
GOTO LAB(DSOF01)
DSOBM:
DSOFTM:
;Create message and output to file and tty
MDSPM
GOTO LAB(DSOFT)
DSVOM: ;
DEXEC DSOCR ;Inhibit ^O
MDSPM ;Create message
DSVO: ;Output text to file and tty
IFONA YDSOCOM
GOTO LAB(DSOFT) ;If output command
IFOFFA YDSDBG ;Only to file in debug mode
IFONA YDSALL
BRANCH LAB(DSOF) ;Output to file if command is ALL
DSOFT:
DSOFTA: ;Always to both tty and file even if ALL
DEXEC DSOTTC ;[302]
BRANCH LAB(DSOF) ;[302] Output only on another TTY
;Save position if both tty and file output
DSTACK ZTV%S+OFFSET(ZTVCP)(XDINT)
MDSOT ;Output to tty
DUNSTK
IFONA YDSTTY
DRETUR ;Already done
;Output to current file
ST X0,ZTV%S+OFFSET(ZTVCP)(XDINT)
BRANCH LAB(DSOF) ;Continue at DSOF and return there
EPROC
PROC
DSOTM: ;Create message and output text to tty
MDSPM ;Create message
DSOT: ;Output text to tty
DEXEC DSOTTC ;[302]
BRANCH LAB(DSOF01) ;[302]
;Place null char at end of text
;Position unchanged
SETZ X0,
IDPB X0,LABB(YDSOPO)
;Calculate text start address
OUTSTR ZTE%S+<QDSION+5>/5+LABB(ZDSZTE)
IFOFFA YDSBOI ;[2] Skip <CR><LF> if Breakoutimage
OUTSTR LAB(DSOTCL) ;Output <CR><LF>
MDSONL
DRETUR
DSOTCL: BYTE (7)QCR,QLF
EPROC
DSOEM: PROC
;Output error to tty and file
;Call DSOBM but output current input buffer
;upto last handled character on tty
IF ;Valid input buffer
IFONA YDSINO
GOTO FALSE
THEN
DEXEC DSSCI
SETZ X0, ;Place null at string end
DPB X0,LABB(YDSIPO)
IF ;[302] USE file is not another tty
DEXEC DSOTTC
GOTO FALSE
THEN ;Copy accepted part of command to tty
LI X0," "
OUTCHR X0
OUTSTR ZTE%S+LABB(ZDSZTE)
OUTSTR LAB(DSOTCL)
ELSE ;Copy the same info to the other tty
MDSINL ;Restore input byte pointer
LI X0," " ;Initial " "
LOOP
MDSOCH ;Copy one char to output
ILDB X0,LABB(YDSIPO) ;Next char
AS ;Long as null char not found
JUMPN X0,TRUE
SA
LI X0,QCR
MDSOCH
LI X0,QLF
MDSOCH
FI
FI
MDSPM ;Create message
BRANCH LAB(DSOFTA) ;Output to both tty and file
EPROC
DSOCR: PROC ;Reset ^O bit
IF ;[302] USE file is not another TTY
DEXEC DSOTTC
GOTO FALSE
THEN ;Use ordinary TTCALL
SKPINC
DRETUR
DRETUR
FI
DRETUR ;Dummy?
EPROC
SUBTTL DSSCI and DSSK, SIMDDT subroutines
Comment;
Purpose: To load next input character in XDBYTE
Entries: DSSCI load next input char in XDBYTE
DSSKB load next input char in XDBYTE which is not blank or tab
DSSKBN load next input char in XDBYTE which is not blank or
tab but start by testing current character
Normal exit: DRETUR
Error exit: none
Output argument:XDBYTE is zero if end of input
otherwise
XDBYTE is current input char.
Call format: DEXEC DSSCI
DEXEC DSSKB
DEXEC DSSKBN
Errors generated:none
Used subroutines:none
;
DSSCI: PROC
;Load next input byte in XDBYTE and update position field
;XDBYTE := 0 if no more input characters present
DSTACK ,LABB(YDSIPO)
ILDB XDBYTE,LABB(YDSIPO)
IF ;Not end of input
JUMPE XDBYTE,FALSE
THEN ;[41] Replace special characters with spaces
CAIE XDBYTE,QVT
CAIN XDBYTE,QFF
LI XDBYTE," " ;Replace with blank
CAIE XDBYTE,"G"-100
CAIN XDBYTE,"Z"-100
LI XDBYTE," "
AOS 1(XDINT) ;Update pos
DUNSTK LABB(YDSTIC) ;Previous pointer saved here
DRETUR
FI
DUNSTK ,LABB(YDSIPO) ;Restore
LDB XDBYTE,LABB(YDSIPO)
SKIPE ,XDBYTE ;Pointer to first null character
ILDB XDBYTE,LABB(YDSIPO)
DRETUR
EPROC
DSSCIR: ;Back up input pointer one character
IF ;Not at end of input string
LDB X0,LABB(YDSIPO)
JUMPE X0,FALSE
THEN ;Back up one step
L X0,LABB(YDSTIC)
ST X0,LABB(YDSIPO)
SOS 1(XDINT)
FI
DRETUR
DSSKB: PROC ;Skip blanks and tabs in input text
;XDBYTE contains first char which is not blank or tab
; or 0 on end of input
LOOP
MDSSCI ;Find next byte
AS
L1():! CAIE XDBYTE," " ;Skip spaces
CAIN XDBYTE,QHT
GOTO TRUE ;and tabs
SA
DRETUR
DSSKBN: ;Entry if last input character must be tested first
LDB XDBYTE,LABB(YDSIPO)
GOTO LAB(L1())
EPROC
SUBTTL DSGI, SIMDDT subroutine
Comment;
Purpose: Get identifier or relation operator from input
Entries: DSGIR Both identifier and relational operator accepted
DSGI Identifier accepted, advance input pointer before test
DSGIS Identifier accepted, but do not advance input pointer
[304] DSGIK As DSGI, but no digits in identifier (keyword)
Input argument: none
Normal exit: Skip DRETURN when identifier or operator found
Error exit: DRETUR when identifier or operator not found
Errors generated:none
Output arguments:XDSYM1 and XDSYM2 contain identifier in sixbit code
YDSSYM contains the same
Call format: normal
Used subroutines:DSTCR,DSTC,DSTCL,DSSCI,DSSKB,DSSKBN
;
PROC
DSGIR: ;Get identifier or relation operator from input
LI X1,LAB(DSTCSR) ;Define entry point for translation
GOTO LAB(DSGI.1) ;[242]
DSGIK: ;Get keyword (identif with no digit) from input
MDSSKB ;Advance input ptr
LI X1,LAB(DSTCL) ;[304] Entry point for char translation
GOTO LAB(DSGI.1)
DSGI: ;Get identifier from input
MDSSKB ;Advance input pointer
DSGIS: ;Get identifier from input but do not advance pointer
LI X1,LAB(DSTCS) ;Define entry point for translation
DSGI.1: DSTACK X1 ;Save entry point
n==1 ;Count saved words
DEXEC DSSKBN ;Skip blanks and tabs
IF
MDSSUB ;Translate character
GOTO FALSE ;No identifier found
CAIGE XDBYTE,'0' ;Identifier may not start with digit
GOTO TRUE
CAIG XDBYTE,'9'
GOTO FALSE
THEN
SETOFA YDSRLC
CAIGE X1,LAB(DSTC01)
SETONA YDSRLC ;If relational character found
;all following must also be relational
;First character valid start of identifier
SETZ XDSYM1, ;[242]
L XDSYM2,XDBYTE ;[242]
LOOP
MDSSCI ;Fetch next character
JUMPE XDBYTE,FALSE ;No more input char.
MDSSUB ;Translate char.
GOTO FALSE ;End of identifier
AS
IF ;[242] Not yet 12 characters
TLNE XDSYM1,(77B5) ;[242]
GOTO FALSE
THEN LSHC XDSYM1,6 ;Shift one sixbit char
IOR XDSYM2,XDBYTE
FI
IFONA YDSRLC
CAIGE X1,LAB(DSTC01)
GOTO TRUE ;Save character
SA
;Fill rest of XDSYM1 and XDSYM2 with blanks
SKIPN XDSYM1 ;[242]
EXCH XDSYM1,XDSYM2 ;[242]
WHILE
TLNE XDSYM1,(77B5) ;[242]
GOTO FALSE
DO
LSHC XDSYM1,6
OD
AOS -n(XDSTK) ;Skip return
STD XDSYM1,LABB(YDSSYM) ;Save symbol
FI
DUNSTK
n==0
DRETUR
EPROC
SUBTTL DSIFK, SIMDDT subroutine
PROC
Comment;
Purpose: Find if keyword identifier follows in input buffer
Entry: DSIFK
Input argument: input pointer (XDINT)
Normal exit: skip DRETURN if keyword found
Error exit: DRETURN if no keyword
Output arguments:
X1 address of ZKW entry if found
input pointer
Used subroutines: DSGI and DSFK
;
DSIFK: ;Find keyword in input
DSTACK XDZKW
IF ;Identifier
MDSGI
GOTO FALSE
THEN
MDSFK
L X1,XDZKW
AOS -1(XDSTK)
FI
DUNSTK XDZKW
DRETUR
EPROC
SUBTTL DSPM, SIMDDT subroutine
Comment;
Purpose: Put message in output text
Possible messages:
SIMDDT error message
SIMRTS error message
SIMDDT message with error number
prefix deleted
SIMRTS error message where ZYQ has
to be replaced by ZYD
Entry: DSPM
Input argument: XDMN message number
Normal exit: DRETURN
Error exit: none
Output argument:none
Call format: normal
Used subroutines:DSPOC
;
DSPM: PROC
;Put message in output text
;XDMN contains message number
;
DSTACK XDT3
DSTACK XDT2
DSTACK X1
DSTACK X0
DSTACK XDM1
DSTACK XDM2
DSTACK XDM3
DSTACK XDMN
DSPM02: ;Invalid error number
;Check message number
L X1,XDMN
LI XDM1,"Q" ;Assume ZYQ message
JUMPE XDMN,LAB(DSPM01)
IF ;Not a ZYQ message number
CAIG XDMN,QZYQLN
GOTO FALSE
THEN ;Check for ZYD range
CAIGE XDMN,QZYDFN
GOTO LAB(DSPM01) ;Wrong number
CAILE XDMN,QZYDLN
GOTO LAB(DSPM01)
;Valid ZYD number
SUBI XDMN,QZYDFN-QZYQLN-1 ;Skip entries in YEMI
LI XDM1,"D"
;Skip ZYDnnn if message is one of the first ZYD messages
CAIG XDMN,QMSUPN-QZYDFN+QZYQLN+1 ;Last message with
; suppressed number
GOTO LAB(DSPM03)
FI
IFONA YDSERE
LI XDM1,"D" ;Replace ZYQ with ZYD if error
SETOFA YDSERE ; occurred in SIMDDT
;Output ZYQnnn or ZYDnnn
LI X0,"Z"
OUTCHA
LI X0,"Y"
OUTCHA
LI XDCNT,4 ;Output Qnnn or Dnnn
LSH X1,^D27
L X0,XDM1
MDSPOC
OUTCHB
DSPM03:
;Find entry address to YEMI table
IDIVI XDMN,2
ADD XDMN,XDBAS
ADD XDMN,LAB(YDSDN)
ADD XDMN,LAB(YDSMN)
HRRZ X1,YDSED-1-DSSTAR(XDMN) ;Fetch YEMI entry for even messages
IF
JUMPE XDMN2,FALSE
THEN
HLRZ X1,YDSED-DSSTAR(XDMN) ;Fetch YEMI entry for odd messages
FI
LDB XDCNT,LAB(<[POINT 4,X1,23]>) ;Save number of words in message
JUMPE XDCNT,LAB(DSPM01) ;No words in message
;Handle type if relevant
;Find entry in YEM
LDB XDM1,LAB(<[POINT 12,X1,35]>) ;Fetch index
IDIVI XDM1,4
;Find byte pointer -1-XDM2
L XDM3,LAB(<[POINT 9,LAB(YDSED-1),26]>)
ADD XDM3,XDM1
ADD XDM3,LAB(YDSDN)
LOOP
ILDB X0,XDM3
AS
SOJGE XDM2,TRUE
SA
;Find word in dictionary
LOOP
ILDB XDMN,XDM3 ;Fetch word index
;Check that it is not a control word
;Scan through YEDL until word interval found
LI X1,LAB(YDSEDL-1)
LOOP
AOJ X1,
LF X0,YDSDLW(X1) ;Fetch word number
AS
CAMLE XDMN,X0
GOTO TRUE ;Interval not reached
SA
;Calculate number of characters preceding word in YED
LF XDM1,YDSDLC(X1) ;Character count
LF X0,YDSDLW(X1,-1)
SUBI X1,LAB(YDSEDL) ;Word length
IF
JUMPE X1,FALSE ;Word length is 1
THEN
SUB XDMN,X0
FI
LI X1,1(X1) ;Correct word length
SOJ XDMN,
IMUL XDMN,X1
ADD XDM1,XDMN
IDIVI XDM1,6
ADD XDM1,XDBAS
;Find byte pointer in dictionary
L XDM,LAB(<[POINT 6,YDSED-1-DSSTAR(XDM1),29]>) ;Char pointer
LOOP
ILDB X0,XDM
AS
SOJGE XDM2,TRUE
SA
;Transfer word from YED plus one blank
LOOP
ILDB X0,XDM
ADDI X0,40 ;Convert to ascii
OUTCHA
AS
DECR X1,TRUE ;X1 characters
LI X0," "-40 ;Fetch blank
JUMPE X1,1+TRUE
SA
AS
DECR XDCNT,TRUE ;More words in message
SA
;Exit
DUNSTK XDMN
DUNSTK XDM3
DUNSTK XDM2
DUNSTK XDM1
DUNSTK X0
DUNSTK X1
DUNSTK XDT2
DUNSTK XDT3
DRETUR
DSPM01: ;Invalid message number
LI XDMN,QMPMNI ;Invalid message number
GOTO LAB(DSPM02)
EPROC
SUBTTL DSIS, SIMDDT subroutine
Comment;
Purpose: To initialize SIMDDT
Entry: DSIS
Input argument: none
Normal exit: RETURN (POPJ XPDP,0)
Call format: EXEC DSIS, SIMDDT stack not yet created
Used subroutines:DSONL,CSNA,DSISRB and DSBUTX
;
DSIS: PROC
ST XDBAS,YDSBAS(XLOW) ;Save in case first call
SETON YDSACT(XLOW)
L XDSWIT,YDSWIT(XLOW)
IF ;Not initialized yet
IFONA YDSINI
GOTO FALSE
THEN ;Initialize
;Create text array ZDSTXT
MCSNA QTEXT,1,QDSTN
ST XWAC1,YDSTXT(XLOW) ;Save address
MCSNA QREF,1,QDSRN ;Create ref array
ST XWAC1,YDSREF(XLOW)
EXEC LAB(DSISRB) ;Set registers and
; remove any old breakpoints
LI X0,LABB(ZDSZTE) ;Save address of ZDSZTE
ST X0,YDSIOT(XLOW)
HRLI X1,LAB(DSIS01) ;Create YDSINC entry
HRRI X1,YDSINC(XLOW)
BLT X1,YDSINC+3(XLOW)
LI X0,YDSBSAV(XLOW) ;Relocate breakpoint return
HRRM X0,LABB(YDSBRETUR) ;instructions in ZBR
HRRM X0,2+LABB(YDSBRETUR)
LI X0,YDSBCOM(XLOW)
HRRM X0,1+LABB(YDSLEAVE)
HRRM X0,2+LABB(YDSLEAVE)
HRRM X0,3+LABB(YDSLEAVE)
SETZM ,LABB(YDSRRA) ;Initialize ZBR
HRLZI X0,700000
ST X0,LABB(YDSTRA) ;3 elements used
;Initialize ZBE links
LI X0,QBRN*2+3 ;First unused ZBE
HRLZM X0,LABB(DSZBRU)
LI X1,QBRN*2+LABB(DSZBRF)
LOOP
ADDI X0,QZBEL
HRLZM X0,(X1)
AS
ADDI X1,QZBEL
CAIGE X1,LABB(DSZBRK)
GOTO TRUE
SA
SETZM ,-QZBEL+LABB(DSZBRK)
;Find ZLN address for main program
IF
L X1,YDSZLA(XLOW)
JUMPE X1,FALSE ;No ZLN table present
THEN
LF X0,ZLNADF(X1)
ST X0,LABB(YDSCZS) ;Save start address
;of current line
;number table
FI ST X1,YDSZLN(XLOW) ;Save main line number
; table
SETONA YDSINI ;SIMDDT initialized
SETONA YDSTTY ;Output via tty
SETONA YDSITTY ;Input via tty [41]
FI
;Initialize accumulators
LI XDZBR,LAB(DSZBRS)
LI XDSTK,LABB(DSZBRK)
HRLI XDSTK,-QSTAKL+1
SETZ X1, ;[242]
IF ;[242] Channel zero is active
DEVCHR X1,
JUMPE X1,FALSE
THEN ;[242] Force out any buffer, save non-standard chnl sts
HLRZ X1,YIOCHT(XLOW)
IF ;Buffers exist
JUMPE X1,FALSE
LF XBH,ZFIOBH(X1)
SOJL XBH,FALSE
THEN
L XWAC1,X1
LF X1,ZBHZBU(XBH)
HRRZ OFFSET(ZBHBUP)(XBH)
IF ;Something not yet output
CAIG 2(X1)
SKIPE 2(X1)
GOTO TRUE
GOTO FALSE
THEN ;Force out the buffer
SKIPA
SKIPA ;IONB returns here!!
XEC IONB
;[302] OUTSTR LAB(DSOTCL)
FI
FI
GETSTS X1
ST X1,LABB(YDSST0)
TRZE X1,IO.TEC+IO.SUP+IO.LEM+16
SETSTS (X1)
CAMN X1,LABB(YDSST0)
SETZM LABB(YDSST0) ;Save only non-standard status
FI ;[242]
DEXEC DSBUTX ;Initiate text pointers and stack
DEXEC DSPLEE
;Assume normal switches
SETONA YDSDBG
SETOFA YDSSTA
SETOFA YDSREE
SETOFF YDSSUP(XLOW) ;[41]
ST XDSWIT,YDSWIT(XLOW)
RETURN ;Exit DSIS
DSIS01: ;YDSINC entry
; moved to YDSINC(XLOW) area
;Call RTS routine from SIMDDT when garbage collection may occur
;Return address must be valid even if SIMDDT moved by g.c.
PUSHJ XPDP,(XDRTSR)
DSIS02: LOWADR
L XDBAS,YDSBAS(XLOW)
BRANCH LAB(DSINC)
EPROC
SUBTTL DSISRB, SIMDDT subroutine
Comment;
Purpose: Remove all breakpoints
Entry: DSISRB
Input argument:none
Normal exit: Return
Error exit: none
Output arguments:None
Call format: EXEC DSISRB
Used subroutines:DSRLBI
;
DSISRB: ;Remove any breakpoints from program
LI XDZBR,LAB(DSZBRS) ;Not ok if SIMDDT
; in high segment
LI X1,LABB(DSZBRF)
LOOP
LI XDSTK,LABB(DSZBRK)
HRLI XDSTK,-QSTAKL+1
DEXEC DSRLBI ;Remove breakpoint instructions
;if any exist
AS
ADDI X1,2
CAIGE X1,2*QBRN+LABB(DSZBRF)
GOTO TRUE
SA
RETURN
SUBTTL DSOC, SIMDDT subroutine
Comment;
Purpose: Put character in output text
Entries: DSOCH put character in output text
DSOCO output if overflow
DSOCB put blank in output text
DSOCT put tab in output text
Input argument: X0 contains character to be stored in outtext
Normal exit: DRETUR
Error exit: None
Output argument:None
Call format: Normal
Used subroutine:DSOFT and DSOF
;
PROC
DSOCT: LI X0," " ;Output tab
GOTO LAB(DSOCH)
DSOCB: LI X0," " ;Output blank
DSOCH:
IDPB X0,LABB(YDSOPO)
LF X0,ZTVCP(XDINT,ZTV%S)
AOJ X0,
SF X0,ZTVCP(XDINT,ZTV%S)
CAIG X0,QDSION
DRETUR ;No overflow
DSOCO: ;Entry from DSTXO if line overflow
;error
IF
IFOFFA YDSALL
IFOFFA YDSOBOTH
GOTO FALSE
THEN
MDSOFT ;Output to both files if overflow
DRETUR
FI
MDSOF ;In debug mode overflow only
;to output file
DRETUR
SUBTTL DSOSWS, SIMDDT subroutine
DSOSWS: ;Set switch YDSOBOTH to control output in case of
;line overflow
;Called from DSSC,DSCH and DSVA routines
SETONA YDSINO
;[41]
IFOFFA YDSDBG
SETONA YDSOBOTH
DRETUR
EPROC
SUBTTL DSONL AND DSINL, SIMDDT subroutines
Comment;
Purpose: Initialize input and output text pointers
Entries: DSONL initialize output text
DSINL initialize input text
Input argument: None
Normal exit: DRETUR
Error exit: None
Output argument:None
Call format: DEXEC DSONL or DEXEC DSINL
Used subroutines:None
;
DSONL: PROC
ZF ZTVCP(XDINT,ZTV%S)
L X0,LAB(<[POINT 7,ZTE%S-1+<QDSION+5>/5+LABB(ZDSZTE),34]>)
ST X0,LABB(YDSOPO)
DRETUR
EPROC
DSICH=DSSCI
DSINL: PROC
ZF ZTVCP(XDINT)
L X0,LAB(<[POINT 7,ZTE%S-1+LABB(ZDSZTE),34]>)
ST X0,LABB(YDSIPO)
DRETUR
EPROC
SUBTTL DSPL, SIMDDT subroutine
Comment;
Purpose: Locate address in line number table and
Put module:nnnnn line number in output text
or
put Onnnnnn (octal address) in output text if
no table entry exists
or
put module:Onnnnnn in output text
if module but not linenumber entry known
Entries: DSPL
DSPLL
DSPLO
DSPLE
DSPLEE [2]
Input arguments:XDSTA address
Normal exit: DRETUR
Error exit: none
Output argument:XDZLN points at line number table entry if valid entry found
YDSCZL,YDSZLN and YDSCZS updated if DSPLE entry
Call format: Normal
Used subroutines:DSLO,DSTXPI,DSPOC and DSPSP
;
DSPL: PROC
SETOM ,LABB(YDSSLN)
IF
MDSLO ;Locate instruction
GOTO FALSE ;Address not in ZLN table
DSPLL: ;Entry if line number entry already known
ST X0,LABB(YDSSZN) ; [2] Save ZLN table pointer
ST XDT2,LABB(YDSSLN) ;Save block structure entry
ST X1,LABB(YDSSLS) ;Save start of ZLN table
LF XDZPR,ZLNADF(X1)
MDSPSP ;Create module name
LI X0,":"
OUTCHA
THEN ;Create line number nnnnn
LF XWAC3,ZLNLIN(XDZLN) ;Fetch line number
;Remove bit for declaration
TRZ XWAC3,200000
CAIN XWAC3,QLINEM
GOTO LAB(DSPLO) ;Output octal address if linenumber is
;Max used to signal that program is
;compiled with -I switch
MTXPI ;Output digits
ELSE
DSPLO: ;Entry if octal number to be put in outtext
;Create Onnnnnn octal address
LI XDCNT,7
LI X0,"O"
OUTCHA
LI X0," "
HRLZ X1,XDSTA
MDSPOC
FI
DRETUR
EPROC
PROC
DSPLE: ;Call DSPL and change environment variables
IF ;Valid line no table entry
MDSLO
GOTO FALSE
THEN
ST XDT2,LABB(YDSCZL)
ST X0,YDSZLN(XLOW)
ST X1,LABB(YDSCZS)
DEXEC DSPLL
IF ;Error mode or breakpoint ;[163] Start of change
IFOFFA YDSDBG
GOTO TRUE
IFOFFA YDSREE
GOTO FALSE
THEN ;Check if XCB and interrupt address are compatible
L XDZLN,LABB(YDSCZL)
LI X0,LAB(L1())
DEXEC DSSS ;Search line number table for blocks
BRANCH LAB(DSTERM) ;Terminating error if block not found
L1():!
LF X0,ZBIZPR(XCB) ;Fetch current prototype
IF ;Not same as stacked
CAMN X0,-1(XDSTK)
GOTO FALSE
THEN
LF X1,ZDRZBI(XCB) ;Try calling block
JUMPLE X1,FALSE ;None exists
LF X0,ZBIZPR(X1) ;New prototype
CAME X0,-1(XDSTK)
GOTO FALSE ;Calling block not ok
L XCB,X1 ;Change environment
LI X0,0
HRLM X0,YDSENR(XLOW) ;Forbid continuation
FI
DEXEC DSSSR ;Exit DSSS
FI ;[163] End of change
ELSE ;No valid line found
;Output block identification
LF XDZPR,ZBIZPR(XCB)
MDSPSP
OUTCHB
DEXEC DSPLO
;[2] Try to find prototype in ZLN table
LF XDT4,ZBIZPR(XCB)
DEXEC DSLPR
;***AUBEG
;Avoid skipping over the STD macro.
;This can happen here because DSLPR
;may have a SKIP return.
SKIPA
GOTO LAB(.+3) ;Skip over the STD
;***AUEND
STD XDT2,LABB(YDSCZL)
ST X1,YDSZLN(XLOW)
FI
DSPLEE: ; [2]
;Initiate reset and start variables for INSPECT command
ST XCB,YDSSXCB(XLOW)
ST XCB,YDSRXCB(XLOW)
LD XDT2,LABB(YDSCZL)
STD XDT2,LABB(YDSSZL)
STD XDT2,LABB(YDSRZL)
L X1,YDSZLN(XLOW)
ST X1,LABB(YDSSZE)
ST X1,LABB(YDSRZE)
DRETUR
EPROC
SUBTTL DSLL and DSLO subroutines
Comment;
Purpose: Locate line number in line number table or
locate octal address in line number table
Entries: DSLL locate line number
DSLO locate octal address
Input arguments:
XDLIN line number and XDT2 address of ZLN table if DSLL call or
XDSTA octal address if DSLO call
Normal exit: Skip DRETUR if valid ZLN entry found
Error exit: DRETUR if no valid entry found
Output argument:XDZLN, pointer to ZLN entry if valid
XDT2, pointer to first block structure entry
X1, pointer to start of relevant ZLN TABLE
X0, pointer to main ZLN table entry
Value of YDSZLN(XLOW) if DSLO call
Errors generated:None
Call format: Normal
Used subroutines:DSEZLN
;
PROC
IF
;Two different entry points
THEN
DSLL: ;Locate line number in a ZLN table
SETOM ,LABB(YDSFLG) ;Indicate DSLL entry
ELSE
DSLO: ;Locate octal address in ZLN table
;Try main ZLN table first
L XDT2,YDSZLA(XLOW)
L X1,XDT2
DSLO02:
DSTACK X1
IF ;Valid ZLN entry found
DEXEC DSLO01
GOTO FALSE
THEN
DUNSTK
AOS (XDSTK)
DRETURN ;Return from DSLO
FI
;Try any external tables
DUNSTK X1
DEXEC DSEZLN ;Find next external ZLN table
IF ;No luck
JUMPN X1,FALSE
THEN ;Return from DSLO, no valid ZLN entry found
DRETUR
FI
LF XDT2,ZSMZLN(XDT2)
GOTO LAB(DSLO02)
DSLO01: ;Search one ZLN table
SETZM ,LABB(YDSFLG) ;Indicate DSLO entry
FI
IF ;There is a ZLN table
JUMPE XDT2,FALSE
THEN
LF X1,ZLNADF(XDT2) ;First table entry
LI XDZLN,1(XDT2)
;X1 points at first entry
;XDZLN at last entry +1
;XDT2 at last entry
DSLC: ;Common part
WHILE
SOJ XDZLN,
CAME XDT2,XDZLN
GOTO FALSE ;Valid line number entry
CAMN XDZLN,X1
DRETUR ;First entry in ZLN reached, no match
DO
;Block structure entry
LF XDT2,ZLNBLK(XDZLN)
ADD XDT2,X1 ;Find previous block structure entry
OD
IF ;DSLL entry
SKIPL ,LABB(YDSFLG)
GOTO FALSE
THEN
LF X0,ZLNLIN(XDZLN)
IF ;Declaration entry
CAIGE X0,QLINEM
GOTO FALSE
THEN
TRZ X0,200000 ;Delete declaration flag
CAMLE X0,XDLIN
GOTO LAB(DSLC) ;Skip entry if table value>XDLIN
GOTO LAB(L2()) ;Accept last line entry
FI
SOS ,LABB(YDSFLG)
IF
CAMGE X0,XDLIN
GOTO FALSE
THEN
IF ;Matching line no
CAME X0,XDLIN
GOTO FALSE
THEN ;Check if first line entry in table
DSTACK XDZLN
LOOP
SOJ XDZLN,
AS
CAMN XDZLN,X1
GOTO FALSE ;No line entry found
LF X0,ZLNLIN(XDZLN)
CAILE X0,QLINEM
GOTO TRUE ;Declaration entry
;or block entry
DUNSTK XDZLN
GOTO LAB(DSLC) ;Try previous line
SA
DUNSTK XDZLN
GOTO LAB(L1())
;Use first entry
FI
;Table value > XDLIN
LF X0,ZLNLIN(XDT2,1)
TRZ X0,200000 ;Remove declaration flag
CAMLE X0,XDLIN
LI XDZLN,1(XDT2) ;Skip to next block entry
GOTO LAB(DSLC)
FI
;Table value < XDLIN
;Seek first entry where XDLIN <= table entry
AOS ,LABB(YDSFLG)
L2():!
AOSN ,LABB(YDSFLG)
DRETUR ;Last line number entry
LOOP
AOJ XDZLN,
AS
LF X0,ZLNLIN(XDZLN)
CAIG X0,QLINEM
GOTO FALSE ;Valid number
CAIL X0,1B18 ;Skip if declaration entry
L XDT2,XDZLN ;Update block entry pointer
GOTO TRUE
SA
ELSE
;DSLO entry
AOS ,LABB(YDSFLG)
LF X0,ZLNADR(XDZLN)
IF
CAMG X0,XDSTA
GOTO FALSE
THEN
LF X0,ZLNADR(XDT2,1)
CAMLE X0,XDSTA
LI XDZLN,1(XDT2)
GOTO LAB(DSLC)
FI
CAME X0,XDSTA ;Exact match
SOSE ,LABB(YDSFLG) ;Last entry not valid
FI
L1():! ;Return valid entry
AOS ,(XDSTK) ;Skip return
FI DRETUR
EPROC
SUBTTL DSEZLN, SIMDDT subroutine
Comment;
Purpose: Find next external block entry in main ZLN table
Entry: DSEZLN
Input arguments:X1 previous external block entry in main ZLN table
or address of main ZLN table(first call)
Normal exit: DRETUR
Error exit: none
Output arguments:X1 is 0 if no external entries exist or
address of external block entry
XDT2 is address of external symbol table if X1 valid
Used subroutines:none
;
PROC
DSEZLN: ;Find next external symbol table
L XDT2,YDSZLA(XLOW)
LF XDT2,ZLNADR(XDT2)
LOOP
IF
LF X1,ZLNBLK(X1)
JUMPN X1,FALSE
THEN
DRETUR ;X1 is 0
FI
ADD X1,XDT2
LF X0,ZLNTYP(X1)
AS
CAIL X0,QCEXT
CAILE X0,QFEXT
GOTO TRUE ;Try previous ZLN entry
SA
;External block found
LF XDT2,ZLNADF(X1) ;Fetch prototype
LF XDT2,ZPRSYM(XDT2)
DRETUR
EPROC
SUBTTL DSPO, SIMDDT subroutines
Comment;
Purpose: Put octal digits in text
Entries: DSPO put octal digits in text
DSPOC put octal digits in text, X0 contains first
char to be put in outtext
Input argument(s): X1 octal number left adjusted
XDCNT number of characters to be put in text
X0 first output char. if DSPOC call
Normal exit: DRETUR
Error exit: none
Output argument(s): none
Call format: normal
Used subroutines:DSOCH and DSOCO
;
DSPO: PROC
;Put octal digits in text
;Input XDCNT number of octal digits in text
;Input X1, octal number left adjusted
LOOP
LI X0,6
LSHC X0,3
DSPOC: ;Entry if X0 already contains first output char.
OUTCHA
AS
DECR XDCNT,TRUE
SA
DRETUR
EPROC
SUBTTL DSTX, SIMDDT subroutines
Comment;
Purpose: Subroutines to handle the communication
with RTS text routines:
TXPI, TXPR, TXGI and TXGR
Entries: DSTXO initialize output via RTS
DSTXI initialize input via RTS
DSTXPC output integer and calculate number of digits in text
DSTXPI output integer, number of digits in XDCNT
DSTXGI input integer
DSTXPR output real
DSTXGI input real
Input argument(s): XDCNT number of output digits (characters)
if DSTXPI call
XWAC3 integer to be output
XWAC3,XWAC4 real number to be output
XWAC5 number of significant digits
if real output
Normal exit: DRETUR if real output or integer output
Skip DRETUR if input real or integer ok
Error exit: DRETUR if input real or integer not ok
Output arguments:Text buffer pointers updated
Call format: Normal
Used subroutines: DSTXB internal routine
DSCTX called to input real or integer
DSOF,DSPOC,DSOCH,DSSCI,DSOEM,
RTS routines TXPI and TXPR
;
DSTXO: PROC
;Initialize output via RTS
LI X1,ZTV%S(XDINT)
;XDCNT contains number of output characters
LF X0,ZTVCP(X1)
ADD X0,XDCNT
IF
CAIG X0,QDSION
GOTO FALSE
THEN
;Overflow in buffer
DEXEC DSOCO ;Output current buffer
FI
DSTACK XDCNT
MDSTXB
DUNSTK X1
LOOP
OUTCHA
AS
DECR X1,TRUE
SA
DRETUR
EPROC
PROC
DSTXI: ;Initialize for input
L X1,XDINT
DSTXB: ;
;Build temporary text variable
;Input XDCNT number of characters
;Input X1 text variable
;Note code not field independent
HRLZ X0,1(X1) ;Fetch ZTVCP
ADD X0,(X1) ;ZTVSP, ZTVZTE
ST X0,LABB(YDSTTX)
HRLZM XDCNT,1+LABB(YDSTTX) ;ZTVLNG, ZTTVSP
LI XWAC1,LABB(YDSTTX) ;Address of temporary TEXT variable
DRETUR
EPROC
PROC
DSTXPC: ;Entry when number of output characters to be calculated
DSTACK XDCNT
LI XDCNT,0
L X0,XWAC3
CAIGE XWAC3,0
AOJ XDCNT,
LOOP
AOJ XDCNT,
IDIVI X0,^D10
AS
JUMPN X0,TRUE
SA
SKIPA
DSTXPI: ;Entry when number of output characters in XDCNT
DSTACK XDCNT
;Call TXPI
MDSTXO ;Initiate for RTS text routine
EXEC TXPI ;Call RTS routine
DUNSTK XDCNT
DRETUR
EPROC
PROC
;Not used
;DSTXGR: ;Call TXGR
; SETONA YDSTXR
; SKIPA
DSTXGI: ;Call TXGI
SETOFA YDSTXR
DSTXG: ;Common entry point when switch YDSTXR ALREADY SET
LI XTAC,XWAC1 ;[242]
DSTXG1: ;[242] Entry when XTAC is already set
HLRZ XDCNT,1(XDINT)
HRRZ X0,1(XDINT)
SUB XDCNT,X0 ;Calculate length of remaining input
MDSTXI ;Initiate temporary TEXT variable
LI X1,TXGI
IFONA YDSTXR
LI X1,TXGR
DEXEC DSCTX
SOS ,(XDSTK) ;Dretur if error found in TX routine
;Update YDSIPO
HRRZ XDT2,1+LABB(YDSTTX) ;Number of scanned positions
LOOP
MDSSCI ;Dummy read
AS
DECR XDT2,TRUE
SA
AOS ,(XDSTK)
DRETUR ;Skip return when valid integer or real found
EPROC
DSTXPR: PROC
;Call TXPR
;XWAC3,XWAC4 loaded
;XWAC5 number of significant digits
IF ;True zero
JUMPN XWAC3,FALSE
THEN ;Output 0
LI X0,"0"
OUTCHA
DRETUR
FI
L1():! ;Real number not 0
LI XDCNT,6(XWAC5) ;Plus blank . E + 00
MDSTXO ;Prepare for text output via RTS
EXEC TXPR
DRETUR
EPROC
SUBTTL DSCTX and DSCRTS (call RTS routines), SIMDDT subroutines
Comment;
Purpose: Call special RTS routines
IOLN,IOOP,IOOG,IOCL,CPNE,CSEN,
SAGC,TXBL,TXCY,TXGI and TXGR
These routines are treated specially to be able
to allow garbage collection during the call or
to be able to handle errors that may be detected
by the calling routine.
Entries: DSCRTU i/o routines
DSCRTS normal routines
DSCRTP routines with parameters
placed in 1+YDSINC(XLOW)
DSCTX TXGI and TXGR
Input arguments:XDRTSR address of RTS routine
X1 address of TXGR or TXGI routine (if DSCTX entry)
Parameter in 1+YDSINC(XLOW) if DSCRTP entry
Normal exit: BRANCH YDSINC(XLOW) return to SIMDDT
from YDSINC(XLOW)+3
Skip DRETUR if DSCTX entry
Error exit: DRETUR if DSCTX entry
Output argument:Integer or real in XWAC1,XWAC2 if DSCTX normal exit
otherwise none
Call format: Normal
Used subroutines:TXGI and TXGR
The other RTS routines are not used as subroutines to
DSCR rather as subroutines to SIMDDT.
;
;
PROC
DSCRTU: ;Call i/o routines
SETONA YDSUFR ;USE or DISPLAY file invoked via RTS
DSCRTS:
;Restore LOWADR instruction, may have been destroyed
DSTACK LAB(DSIS02)
DUNSTK 1+YDSINC(XLOW)
DSCRTP: ;Parameters placed in YDSINC+1(XLOW)
SETONA YDSGCO
DSCTX2: ;Call text input routines
ST XDSWIT,YDSWIT(XLOW)
ST XDZBR,LABB(YDSOBR)
ST XDSTK,LABB(YDSOST)
ST XPDP,LABB(YDSOXPDP)
DSTACK YSAGCN(XLOW)
DUNSTK LABB(YDSOSAGCN) ;Save number of garbage collections
IFONA YDSGCO
BRANCH YDSINC(XLOW) ;Call from static low area
;if garbage collection may occur
;Call TXGI or TXGR routine
EXEC 0(X1)
AOS ,(XDSTK)
DSCTX1: SETOFA YDSTXC
ST XDSWIT,YDSWIT(XLOW)
DRETUR
DSCTX: ;Call TXGI or TXGR routines
SETONA YDSTXC
GOTO LAB(DSCTX2)
EPROC
SUBTTL DSCLOS, SIMDDT subroutine
Comment; [2]
[242] Reworked to take care of "transient files"
(Opened without garbage collection, special buffers)
Purpose: Call IOCL to close any opened file
used by the SIMDDT system
Entries: DSCLOS close file, file object is given in XWAC1
DSCLOU close any use file and reset switch
DSCLOD close display file if it exists
DSCLOI close indirect command file if it exists [242]
DSCLOF [242] close any file, X1 points to word with file
pointer. DSCLOF clears this word if negative.
DSCL. File ref in XWAC1, XDSWIT new value of YDSWIT.
Close file [242].
Input argument: See above - X1, XWAC1, XDSWIT.
Output argument:None
Used routine: IOCL
;
PROC
DSCLOD: ;Close any open DISPLAY file
LI X1,YDSDFO(XLOW) ;[242]
BRANCH LAB(DSCLOF) ;[242]
DSCLOU: ;Close USE file
IFONA YDSTTY
DRETURN ;[242] Do not close TTY
SETONA YDSTTY
LI X1,YDSUFO(XLOW)
BRANCH LAB(DSCLOF)
DSCLOI: ;Close indirect command file
IFONA YDSITTY
DRETURN ;[242] Do not close TTY
SETONA YDSITTY
LI X1,YDSIFO(XLOW)
; BRANCH LAB(DSCLOF)
DSCLOF: ;[242] Close file whose address is at (X1)
;[242] Delete reference if temporarily allocated
SKIPL XWAC1,(X1)
BRANCH LAB(DSCL.)
DSTACK X1
DEXEC DSCL.
DUNSTK X1
;Deallocate if possible **** later***
SETZM (X1)
DRETURN
;[41]
DSCLOS: ;Close any opened file
;[41]
CAMN XWAC1,YDSUFO(XLOW)
BRANCH LAB(DSCLOU)
CAMN XWAC1,YDSIFO(XLOW)
BRANCH LAB(DSCLOI) ;[242]
CAMN XWAC1,YDSDFO(XLOW)
BRANCH LAB(DSCLOD)
BRANCH LAB(DSCL.1)
DSCL.: ST XDSWIT,YDSWIT(XLOW)
DSCL.1: IF ;File exists and is open
JUMPE XWAC1,FALSE
IFOFF ZFIOPN(XWAC1)
GOTO FALSE
THEN ;Call RTS Close procedure
LI XDRTSR,IOCL
DEXEC DSCRTS
FI
DRETUR
EPROC
SUBTTL DSBUTX, SIMDDT subroutine
Comment;
Purpose: To initialize text variables and SIMDDT stack
Entry: DSBUTX
Output arguments:XDINT and text pointers initialized
Used subroutines:DSINL and DSONL
;
PROC
DSBUTX:
;Fill in underflow stack address
LI X0,LAB(DSTERM)
ST X0,LABB(DSZBRK)
DSTACK XDT2
;Build text variables
;Elements 0,1,2 in text array
L XDINT,YDSTXT(XLOW)
LF XDINT,ZARBAD(XDINT) ;Calculate XDINT
LI XDT2,2
LI X1,LABB(ZDSZTE) ;Text record address
LOOP
WSF X1,ZTVZTE(XDINT)
HRLZI X0,QDSION ;Length of text variable
WSF X0,ZTVLNG(XDINT)
AS
ADDI XDINT,ZTV%S
HRLI X1,QDSION+5 ;Next ZTVSP
DECR XDT2,TRUE
HRLI X1,2*<QDSION+5> ;Last input text variable
JUMPE XDT2,TRUE
SA
SUBI XDINT,3*ZTV%S ;Restore XDINT
MDSONL
MDSINL
DUNSTK XDT2
DRETUR
EPROC
SUBTTL DSEXPR, SIMDDT subroutine
Comment; [2]
Purpose: To close any open display file and update variables
Entry: DSEXPR
Used subroutine: DSCLOD
;
PROC
DSEXPR:
DEXEC DSCLOD
;No display file exists
SETZM YDSDFO(XLOW)
SETZM LABB(YDSDZLN)
SETZM LABB(YDSNDL) ;[242]
DRETUR
EPROC
SUBTTL DSFSP, SIMDDT subroutine
Comment; [2]
Purpose: Create file specification to be used by RTS i/o routines
Entry: DSFSP
Input arguments:X1,X2,X3 name to convert to ascii and place in input buffer
XDT4 number of characters to convert
Null character in input buffer marks end of input
Output arguments: Input buffer filled and cr placed at end of input
Input text variable initialized
Normal exit: DRETUR
;
PROC
DSFSP:
MDSINL ;Initialize input buffer
HRLZI XDSTA,600 ;[41] Build byte pointer to X1,X2,X3
LOOP
ILDB X0,XDSTA ;[41]
ADDI X0,040
IDPB X0,LABB(YDSIPO)
AS
DECR XDT4,TRUE ;[41]
SA
;Find end of input
;If call from DSUS file specification still exists
LOOP
MDSSCI
AS
JUMPN XDBYTE,TRUE
SA
LI X0,15
DPB X0,LABB(YDSIPO)
HRLZI X0,QDSION
WSF X0,ZTVLNG(XDINT) ;Create text variable for input
DRETUR
EPROC
SUBTTL DSCF, SIMDDT subroutine
Comment; [2]
Purpose: Create file object and open file
Entries: DSCF create file object and open file
DFCFO open a file for which file object already exists
Input arguments: X0 parameters to CPNE RTS routine
File specification in input buffer area
Output arguments: XWAC1 new file object if ok
0 if file not ok
Normal exit: DRETUR
Used subroutines:IOOP,CPNE,CSEN,DSCFAB,DSCFLB,DSCRTU and DSCRTP
;
PROC
DSCF: IF ;[242] GC is ok
DEXEC DSCHGC
DSCF02: GOTO FALSE ;[242] Address checked in DCCHGC, no message on failure
THEN ;Ok, use ordinary allocation of buffers etc
ELSE ;Make sure there will be no GC, or give up
LF X1,ZDNTYP(XCB)
IF ;Class body
CAIE X1,QZCL
GOTO FALSE
THEN ;Check for file subclass
LF X1,ZBIZPR(XCB) ;Prototype of current block
LF X1,ZCPGCI(X1)
IF ;File subclass
CAIE X1,QIOFI
GOTO FALSE
THEN ;Reissue check for GC to get message, then abort
DEXEC DSCHGC
BRANCH LAB(L1())
FI
FI
SETON SWNOGC(XLOW)
ZBU%S==203 ;Buffer size
ZBH%S==4 ;Buffer header size
q==QPFLNG+10+2*ZBU%S+10 ;Adequate space for file obj and 2 bufs
LI X1,q
ADD X1,YSATOP(XLOW)
SUB X1,YSALIM(XLOW) ;Neg diff if space remains
IF ;Not enough
JUMPLE X1,FALSE
THEN ;Try one buffer only
SUBI X1,ZBU%S
IF ;Not even space for one buffer
JUMPLE X1,FALSE
THEN ;Try more core
EXTERN .JBREL
L X1,.JBREL
ADDI X1,1000 ;One page suffices
CORE X1,
GOTO LAB(L1()) ;Failed
;Ok, adjust limits
L X1,.JBREL
HRRM X1,.JBFF
SUBI X1,QSALIM
ST X1,YSALIM(XLOW)
FI FI FI
ST XCB,YDSXCB(XLOW) ;Save XCB in dynamic part of static
;area. XCB will be changed on error
;during file creation and opening
LD XWAC2,(XDINT)
ST X0,1+YDSINC(XLOW) ;Place parameter in low segment area
SETONA YDSUFR ;Indicate i/o call to RTS
LI XDRTSR,CPNE
DEXEC DSCRTP ;Call CPNE RTS routine
IFONA YDSUFR
GOTO LAB(L1()) ;File error
LD XWAC2,(XDINT) ;File spec. in input buffer
STD XWAC2,OFFSET(ZFISPC)(XWAC1)
ST XWAC1,YDSCFO(XLOW) ;Save file object
IF ;[242] No GC allowed
IFOFF SWNOGC(XLOW)
GOTO FALSE
THEN ;Allocate buffers in a special way
DEXEC DSCFAB
SETON ZFIBNW(XWAC1) ;Tell .IOCF not to allocate any buffer
HRROS XWAC1,YDSCFO(XLOW) ;Mark file obj addr not to be saved
; over return to code
FI
LI XDRTSR,CSEN
DEXEC DSCRTU ;Call CSEN i/o routine
ZF ZFISPC(XWAC1) ;NOTEXT to file name
ZF ZFISPC(XWAC1,1)
IFONA YDSUFR
GOTO LAB(L1()) ;File error
SKIPGE XWAC1,YDSCFO(XLOW) ;[242] Link buffers if specially
DEXEC DSCFLB ;[242] allocated
SKIPA
DSCFO:
ST XCB,YDSXCB(XLOW)
ST XWAC1,YDSCFO(XLOW)
LD XWAC2,ZTV%S(XDINT)
HRRZ X0,(XDSTK) ;[41]
;***AUBEG
;Correct error in DISPLAY command of SIMDDT. It
;was caused by trying to skip over an LD instruction
;which really is two words. This corrects the
;"ERROR FOR INFILE" error which occurred
;when trying to go backwards through the display
;file. i.e. A "DIS 10" followed by a "DIS 5".
CAIE X0,LAB(DSGET1) ;[41] From DSGET routine
GOTO LAB(.+3) ; SKIP over LD
;***AUEND
LD XWAC2,(XDINT) ;[41] Read to input area
LI XDRTSR,IOOP
DEXEC DSCRTU ;Call i/o open routine
IFONA YDSUFR
L1():! SETZM ,YDSCFO(XLOW) ;Output argument is 0
;File ok
SETOFA YDSUFR
ST XDSWIT,YDSWIT(XLOW)
SETZB XCB,XWAC1 ;[242]
EXCH XCB,YDSXCB(XLOW) ;[242]
EXCH XWAC1,YDSCFO(XLOW) ;[242]
DRETUR
EPROC
SUBTTL DSCFAB, special buffer allocation [242]
Comment;
Purpose: Allocate one or two buffers at the top of the pool.
To be used when normal GC was not allowed when allocating
a file from SIMDDT. The buffers will not stay in core
over any GC. Open the channel before linking buffers.
Input: XWAC1 = File pointer.
Output: ZFIIBH or ZFIOBH points to the buffer header of a buffer ring
allocated in a ZYS record.
Uses registers: X0, X1 without restoring.
;
DSCFAB: PROC ;[242]
DSTACK X2
LF X1,ZFIBFS(XWAC1) ;Buffer size
IF ;Size not determined or too big
CAIG X1,ZBU%S
JUMPG X1,FALSE
THEN ;Make it standard
LI X1,ZBU%S
SF X1,ZFIBFS(XWAC1)
FI
ADDI X1,ZBH%S+2(X1) ;Overhead, ZBH and 2 buffers
LI X2,(X1)
L X2
ADD YSATOP(XLOW) ;New tentative top address
IF ;There was enough space for two buffers
CAMLE YSALIM(XLOW)
GOTO FALSE
THEN ;Ok, 2 buffers it is
LI X1,2
ELSE ;Only one buffer will have to do
SUB X2,OFFSET(ZFIBFS)(XWAC1) ;Adjust size
SUB OFFSET(ZFIBFS)(XWAC1)
LI X1,1
FI
SF X1,ZFIBUF(XWAC1)
L X1,YSATOP(XLOW)
SF X2,ZYSLG(X1) ;Record length
HRRZM YSATOP(XLOW) ;New top
LI QZYS ;Record type
SF ,ZDNTYP(X1)
;Determine buffer header address
LI X1,3(X1)
LF ,ZBIZPR(XWAC1) ;Prototype
CAIN IOIN ;Infile?
SF X1,ZFIIBH(XWAC1)
CAIE IOIN ;Not Infile?
SF X1,ZFIOBH(XWAC1)
DUNSTK X2
DRETURN
EPROC
SUBTTL DSCFLB, link special buffers [242]
Comment;
Purpose: Sets up the buffer pool defined by XWAC1.
Input: XWAC1 is file object address.
;
DSCFLB: PROC
WLF X1,ZFIIBH(XWAC1) ;Buffer header address in one halfword
TRNN X1,-1 ;If rhs=0,
MOVSS X1 ; swap halves
LI 4(X1) ;First buffer address
SETONA ZBHUSE
WSF ,ZBHZBU(X1,-1)
MOVSI (POINT 7,0)
HRRI 5(X1)
SF ,ZBHBUP(X1,-1)
LF ,ZFIBFS(XWAC1)
SUBI 2
SF ,ZBUSIZ(X1,-1)
IF ;More than one buffer
LF ,ZFIBUF(XWAC1)
CAIG 1
GOTO FALSE
THEN ;Chain to next
LI 4(X1)
SF ,ZBUZBU(X1,ZBU%S-1)
LF ,ZFIBFS(XWAC1)
SUBI 2
SF ,ZBUSIZ(X1,ZBU%S-1)
LI 4+ZBU%S(X1)
ELSE
LI 4(X1)
FI
SF ,ZBUZBU(X1,-1) ;Close the ring
DRETURN
EPROC
SUBTTL DSRUC, SIMDDT subroutine
Comment;
[2]
Purpose: Find static or dynamic link
Entries: DSRUC
Input arguments:Switches YDSCH if operating chain requested
YDSUP if static block
YDSRE if dynamic block
XDZLN line number entry
YDSSBA current block address
Output arguments:YDSSBA new block address
If 0 no valid environment found
Normal exit: DRETUR
Used subroutines: DSSS,DSSSR,DSRUCS,DSFA,DSVO,DSVOM and DSONL
;
PROC
DSRUC: ;Find static or dynamic link
SETOM ,LABB(YDSTIC) ;Counter used if call from DSPC
WHILE
LI X0,LAB(L3())
MDSSS
DRETUR
DO
L3():! ;Subroutine called from DSSS
L XDZPR,-1(XDSTK)
;Fetch prototype address
HLRZ X0,-2(XDSTK)
JUMPN X0,LAB(L6()) ;Subblock
ST XDZLN,LABB(YDSSLN) ;Save pointer if not subblock
IF
IFOFFA YDSCH ;[41]
GOTO TRUE
IFON YDSSUP(XLOW)
DRETUR ;Command suppressed
GOTO FALSE
;[41] END
THEN
L X1,@YDSZLA(XLOW)
LF X1,ZLNADF(X1) ;Fetch prototype for outermost block
CAMN XDZPR,X1
GOTO LAB(L7()) ;Outermost block reached, exit DSRUC
IF ;Outermost external block and /UP
SKIPE ,LABB(YDSTIC) ;Ok if second time
IFONA YDSRE
GOTO FALSE
THEN
CAMN XDZLN,LABB(YDSCZS)
GOTO LAB(L7())
FI
FI
LF X1,ZPRSYM(XDZPR)
IF
LF X0,ZSMTYP(X1)
CAIN X0,QPROCB
GOTO TRUE ;Dynamic link
CAIGE X0,QPEXT
GOTO LAB(L4())
CAIG X0,QFEXT
GOTO TRUE
L4():! CAIE X0,QCEXT
CAIN X0,QCLASB
GOTO LAB(L2())
CAIE X0,QPBLOCK
CAIN X0,QSYSCL
GOTO LAB(L2())
L6():! IFONA YDSCH
GOTO LAB(L1())
L X0,LABB(YDSNLN) ;Find line number entry for subblock
SKIPE ,LABB(YDSSLN)
L X0,LABB(YDSSLN) ;Valid pointer
ST X0,LABB(YDSCZL) ;Update current pointer
SETZM ,LABB(YDSSLN) ;Make sure that YDSNLN is used next
GOTO LAB(L5())
L2():! ;Remove prefix classes
WHILE
LF XDZPR,ZCPZCP(XDZPR)
JUMPE XDZPR,FALSE
DO
ST XDZPR,-1(XDSTK)
OD
THEN ;Part of operating chain
L5():!
DSTACK XDZLN
DEXEC DSOCT
L XDSTA,LABB(YDSSBA)
IF ;Operating
IFON ZDNTERM(XDSTA)
GOTO FALSE
THEN ;Find block instance address
ADD XDSTA,LABB(YDSEBL)
L XDSTA,(XDSTA)
FI
MDSFA
DUNSTK XDZLN
IF ;INSPECT block
LF X0,ZLNTYP(XDZLN)
CAIE X0,QINSPEC
GOTO FALSE
THEN ;no change in dynamic link
DEXEC DSOCB
MDSPM QMCHIN ;INSPECT block
IF
IFONA YDSCH
GOTO FALSE
THEN
ST XDZLN,LABB(YDSCZL)
AOS ,LABB(YDSCZL) ;Indicate second of two
;Inspect entries in ZLN
SETZM ,LABB(YDSSLN) ;Indicate update already done
ELSE
MDSVO ;Output text
FI
GOTO LAB(L1())
FI
IF ;[55] Update XCB pointer
IFOFFA YDSCH
GOTO TRUE
IFON ZDNTERM(XDSTA)
GOTO FALSE
THEN
LF X0,ZDNTYP(XDSTA)
CAIE X0,QZBI ;Unreduced block without display
ST XDSTA,LABB(YDSSBA)
FI ;[55] End
;Check for error
IF
IFOFFA YDSCH ;[55] ok if chain
SKIPL LABB(YDSTIC)
GOTO FALSE ;Ok
IFON ZDNTERM(XDSTA)
GOTO TRUE ;Error if terminated block
IFOFFA YDSRE
GOTO FALSE
IFOFF ZDNDET(XDSTA)
GOTO FALSE
LF X0,ZDNTYP(XDSTA)
CAIN X0,QPBLOCK
GOTO FALSE
THEN
;Error found
MDSONL
MDSVOM QMRUCE
;[55]
GOTO LAB(L7()) ;Exit DSRUC
FI
IFONA YDSCH
MDSVO
FI
IFONA YDSUP
GOTO LAB(L1())
IFONA YDSACB
SKIPG ,LABB(YDSSLN) ;No valid line number found
GOTO LAB(L1())
;Change environment, return to calling point
LF XDSTA,ZDRZBI(XDSTA) ;New block instance
ST XDSTA,LABB(YDSSBA)
DEXEC DSSSR ;Exit DSSS
L XDZLN,LABB(YDSSLN)
L X0,LABB(YDSSLS)
ST X0,LABB(YDSCZS)
L X0,LABB(YDSSZN)
IFOFFA YDSCH
ST X0,YDSZLN(XLOW) ;Update external table pointer
;set in DSPL
DEXEC DSRUCS
OD
L1():! ;Static link
DEXEC DSRUCS
IFONA YDSCH
DRETUR ;Return to DSSS
SKIPE ,LABB(YDSSLN)
ST XDZLN,LABB(YDSCZL);Save current pointer if valid
SKIPLE ,LABB(YDSTIC)
L7():! ;
DEXEC DSSSR ;Exit DSSS
DRETUR ;Exit DSRUC the second time
;Return to DSSS the first time
DSRUCS:
IFONA YDSCH
DRETUR
SETOFA YDSRE
SETONA YDSUP
AOSG ,LABB(YDSTIC) ;Increment counter
MDSONL ;Remove block id
DRETUR
EPROC
SUBTTL DSRU, SIMDDT subroutine
Comment;
[2]
Purpose: To call DSRUC for INSPECT /UP or /RETURN to
change current block pointer
Entry: DSRU
Input arguments: See DSRUC
Output arguments: YDSSXCB
Used routines: DSRUC
;
DSRU: ;Call DSRUC
SETOFA YDSACB
L X0,YDSSXCB(XLOW)
ST X0,LABB(YDSSBA)
L XDZLN,LABB(YDSCZL)
DEXEC DSRUC
L XDSTA,LABB(YDSSBA)
ST XDSTA,YDSSXCB(XLOW)
DRETUR
SUBTTL DSLPR, SIMDDT subroutine
Comment;
[2]
Purpose: Search all ZLN tables for prototype
or class identifier [41]
Entry: DSLPR
Input arguments: XDT4 contains prototype
Output arguments: XDT2 is 0 if no entry found
XDT2 points at ZLN entry with prototype in ZLNADF
XDT3 points at start of ZLN table
X1 points at ZLN table
Normal exit: DRETUR
Error exit: DRETUR
Used routines:DSEZLN
;
PROC
;[151] Proc added
DSLPR: ;Find prototype class in ZLN table
L XDT2,YDSZLA(XLOW)
L X1,XDT2 ;Begin with main ZLN table
LOOP
IF
JUMPE XDT2,FALSE
LF XDT3,ZLNADF(XDT2)
THEN
LOOP
IF
JUMPE XDT4,FALSE
THEN ;Find prototype in ZLN table
IF ;Same prototype, right type of block
LF X0,ZLNADF(XDT2)
CAME X0,XDT4
GOTO FALSE ;Not same prototype
LF X0,ZLNTYP(XDT2)
CAIE X0,QPROCB
CAIN X0,QUBLOCK
GOTO TRUE
CAIE X0,QPBLOCK
CAIN X0,QCLASB
THEN
DRETUR ;Right entry in ZLN table found
FI
ELSE ;Find class in ZLN table
IF
LF XDT4,ZLNADF(XDT2) ;[151]
LF X0,ZLNTYP(XDT2)
CAIE X0,QCLASB
GOTO FALSE
;[151]
THEN ;[151]
DEXEC DSLPRR ;[151]
DRETUR ;[151] Entry found
LF XDT4,ZLNADF(XDT2) ;[151]
GOTO LAB(L1()) ;[151]
DSLPRR: ;[151]
;[151] Help procedure
LF XDT4,ZPRSYM(XDT4) ;Fetch name
IF ;[151] The right name is found
CAMN XDSYM1,-2(XDT4)
CAME XDSYM2,-1(XDT4)
GOTO FALSE
THEN ;Find prefix with correct qualif
LF XDT4,ZLNADF(XDT2)
WHILE ;Prefixes exist
JUMPE XDT4,FALSE ;Not found
DO
LF XDT4,ZCPZCP(XDT4)
CAMN XDT4,LABB(YDSSQU)
DRETUR ;Exit ZLN table found
OD
FI ;Not found
AOS ,(XDSTK) ;[151] Skip return
DRETUR ;[151]
ELSE ;[151]Start of change
IF ;Prefixed block
CAIE X0,QPBLOCK
GOTO FALSE
THEN
L1():! ;Check if class has Simulation or Simset as prefix
WHILE
LF XDT4,ZCPZCP(XDT4)
JUMPE XDT4,FALSE
DO
DSTACK XDT2
DSTACK X1
DSTACK XDT4
IF
LF XDT4,ZPRSYM(XDT4)
LD X0,-2(XDT4)
JUMPE X1,LAB(L2())
CAMN X0,LAB([SIXBIT "SIMULA" ])
CAME X1,LAB([SIXBIT "TION" ])
GOTO FALSE
LI X1,-5(XDT4)
GOTO TRUE
L2():!
LI X1,-4(XDT4)
CAME X0,LAB([SIXBIT "SIMSET" ])
GOTO FALSE
THEN
LI X0,-3(XDT4) ;Last prototype
LOOP
L XDT4,(X1)
LI XDT2,LABB(YDSDUZLN)
ST XDT4,LABB(YDSDUZLN)
DEXEC DSLPRR
GOTO LAB(L3())
AS
CAME X0,X1
AOJA X1,TRUE
SA
FI
DUNSTK XDT4
DUNSTK X1
DUNSTK XDT2
OD
FI FI ;[151] End of change
SETZ XDT4,
FI
AS
CAMN XDT2,XDT3
GOTO FALSE ;Not in this ZLN table
LF XDT2,ZLNBLK(XDT2)
ADD XDT2,XDT3
GOTO TRUE
SA
FI
AS
DEXEC DSEZLN ;Find next ZLN table
JUMPE X1,FALSE ;No valid entry
LF XDT2,ZSMZLN(XDT2)
GOTO TRUE
SA
SETZ XDT2,
DRETUR
L3():! ;[151]
DUNSTK ;[151]
DUNSTK ;[151]
DUNSTK ;[151]
L XDT4,(X1) ;[141]
DRETUR ;[151]
EPROC ;[151]
SUBTTL DSCHGC, SIMDDT subroutine
Comment;
[41]
Purpose: Check if call allowed if REENTER or error mode
Entry: DSCHGC
Input argument: SIMDDT status
Output argument: None, message is created if command not valid
Normal return: Skip DRETUR
Error return: DRETUR if command not possible
;
DSCHGC:
DSTACK X0 ;[242]
n==1
IF
IFOFFA YDSREE
IFOFFA YDSDBG
SKIPA
GOTO FALSE
HLLZ X0,LABB(YDSSENR)
JUMPE X0,FALSE ;No problem
THEN
HRRZ X0,-n(XDSTK)
IF ;Not special return address
CAIE X0,LAB(DSCF02) ;[242]
CAIN X0,LAB(DSVA02)
GOTO FALSE
THEN ;Command not allowed
MDSOTM QMGVNS
MDSOTM QMCHQS ;Give NOPROCEED command and reenter
;current command
FI
ELSE
AOS -n(XDSTK)
FI
DUNSTK X0 ;[242]
n==0
DRETUR
SUBTTL DSVAK, SIMDDT subroutine
Comment;
Purpose: [41]
Find /-ARRAY,/-TEXT and/or /-GC in command
and set switches
[242] /START:oooooo specifies first address to output
(in octal)
Entry: DSVAK
Ijput arguealt: Input text pointer
Output arguments: Switches YDSSGC, YDSSNA and/or YDSSKTX
Normal return: Skip DRETUR if ok
Error return: DRETUR if invalid key after /
Used subroutines: DSGI,DSSKB
;
PROC
DSVAK:
DSTACK XDZBE
DSTACK XDTYP
DSTACK XDT5
n==3
WHILE
DEXEC DSSKBN
CAIE XDBYTE,"/"
GOTO FALSE ;No keyword found
DO
LI XDMN,QMVAKE ;Invalid key
DEXEC DSSKB
IF ;[242] - sign
CAIE XDBYTE,"-"
GOTO FALSE
THEN ;Check for valid keywords
DEXEC DSGI
GOTO LAB(L1())
MDSFK
GOTOE XDZKW,LAB(L1())
IF ;/-ARRAY
CAIE XDZKW,LAB(ZKWSKA)
GOTO FALSE
THEN
SETONA YDSSNA
ELSE
IF ;/-TEXT
CAIE XDZKW,LAB(ZKWSKT)
GOTO FALSE
THEN
SETONA YDSSKT
ELSE ;Should be /-GC
CAIE XDZKW,LAB(ZKWSKG)
GOTO LAB(L1())
SETONA YDSSGC
FI FI
ELSE ;[242] May be /START:oooooo
DEXEC DSGIS
GOTO LAB(L1())
MDSFK
JUMPE XDZKW,LAB(L1())
CAIE XDZKW,LAB(ZKWSTA)
GOTO LAB(L1())
DEXEC DSSKBN
CAIE XDBYTE,":"
GOTO LAB(L1())
DEXEC DSIOCT ;Get value
IF ;Neg value
JUMPGE X1,FALSE
THEN ;Add YSATOP
ADD X1,YSATOP(XLOW)
FI
ST X1,LABB(YDSVFA)
FI
OD
AOS -n(XDSTK)
L2():!
DUNSTK XDT5
DUNSTK XDTYP
DUNSTK XDZBE
n==0
DRETUR
L1():! MDSOEM
GOTO LAB(L2())
DRETUR
EPROC
SUBTTL DSIOCT, input of octal value
Comment;
Purpose: Compute binary value from [-]oooooooooooo (octal digits).
Input: Next character is non-blank.
Output: Value in X1.
Exit: DRETURN
Calls: DSSKB,DSSKBN,DSSCI
;
DSIOCT: PROC
DEXEC DSSKB
SETZ X1,
DSTACK X1 ;Positive flag
IF ;Minus sign
CAIE XDBYTE,"-"
GOTO FALSE
THEN ;Flag with -1 in stack
SETOM (XDSTK)
DEXEC DSSKB
FI
WHILE ;[242] Digit(Inchar)
JUMPE XDBYTE,FALSE
SUBI XDBYTE,"0"
JUMPL XDBYTE,FALSE
CAILE XDBYTE,7
GOTO FALSE
DO ;Accumulate value from octal digits
LSH X1,3
ADD X1,XDBYTE
MDSSCI
OD
SKIPE (XDSTK)
MOVNS X1 ;Neg value
DUNSTK (XDSTK)
DRETURN
EPROC