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+/5+LABB(ZDSZTE) IFOFFA YDSBOI ;[2] Skip if Breakoutimage OUTSTR LAB(DSOTCL) ;Output 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+/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* ;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