Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00035 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002
C00005 00003 HISTORY
C00010 00004 Discussion
C00013 00005 COMPIL(CAT,<CAT,CATCHR,CHRCAT,CHRCHR,CAT.RV>
C00021 00006 COMPIL(PTC,<PUTCH>,<GOGTAB,STRNGC,INSET>,<PUTCH -- PUT 1 CHARACTER ROUT>)
C00023 00007 COMPIL(PNT,<POINT,BBPP.>,<GOGTAB,X22,X44>,<POINT, BBPP.>)
C00024 00008 COMPIL(CVF,<CVF,CVG,CVE>
C00028 00009 CVF,CVE,CVG CONTD.
C00031 00010 CVF,CVG,CVE CONTD.
C00033 00011 CVF,CVG,CVE CONTD.
C00035 00012 CVF,CVG,CVE CONTD.
C00037 00013 COMPIL(SUB,<SUBST,SUBSR>,<SAVE,RESTR,X22,.SKIP.,GOGTAB>,<SUBSTRING ROUTINES>)
C00042 00014 COMPIL(EQU,<EQU>,<X44>,<EQU>)
C00044 00015 COMPIL(CVD,<CVD,CVO>,<SAVE,RESTR,X11,X22>,<CVD AND CVO ROUTINES>)
C00046 00016 COMPIL(CVS,<GETFORMAT,SETFORMAT,CVS,CVOS>
C00051 00017 COMPIL(SCC,<SCANC>,<GETBREAK,SETBREAK,RELBREAK,SCAN>,<SCANC ROUTINE>)
C00062 00018 COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR,CV6STR,CVASTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
C00068 00019 COMPIL(CVL,<CVFIL>,<SAVE,RESTR,X22,X33,FILNAM,.SKIP.>,<CVFIL>)
C00070 00020 COMPIL(BRK,<BREAKSET,SETBREAK>
C00075 00021 Setbreak
C00077 00022 COMPIL(SBK,<STDBRK>,<.SKIP.,OPEN,LOOKUP,GOGTAB,BKTCHK,ARRYIN,RELEASE,X22>,<STDBRK>)
C00084 00023 $print
C00091 00024 DSCR PRINT routines
C00098 00025 DSCR $PRSTR -- final string printer
C00100 00026 DSCR
C00103 00027 DSCR Utility routines for PRINT statement.
C00110 00028 ENDCOM(PRN)
C00111 00029 COMPIL(DVF,<CVEL>,<GOGTAB,STRNGC,SAVE,RESTR>,<LONG REAL TO STRING CONVERSION>)
C00113 00030
C00117 00031
C00120 00032
C00123 00033
C00125 00034
C00127 00035
C00130 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021 102100000060 ;
COMMENT
VERSION 17-1(48) 11-13-74 BY JFR GETBREAK BUG P.21
VERSION 17-1(47) 11-7-74 BY RHT FEAT %BW% CV6STR
VERSION 17-1(46) 11-2-74 BY JFR MODS TO HANDLE BREAKTABLE 0(P.16)
VERSION 17-1(45) 10-26-74 BY JFR GETBREAK
VERSION 17-1(44) 10-26-74 BY JFR BUG #TP GETBREAK FIXES
VERSION 17-1(43) 10-14-74 BY JFR CHECK FOR HACK'S--NONE FOUND
VERSION 17-1(42) 10-13-74 BY JFR FIX MINOR LOSSAGE IN SCAN
VERSION 17-1(41) 10-13-74 BY
VERSION 17-1(40) 10-11-74 BY JFR CORRECT TYPOS %BS%
VERSION 17-1(39) 10-11-74 BY JFR INSTALL GETBREAK, RELBREAK
VERSION 17-1(38) 10-11-74
VERSION 17-1(37) 10-11-74 BY JFR BETTER ERROR TRACING FOR %BS% BKTCHK
VERSION 17-1(36) 10-11-74 BY JFR FEAT %BS% (SECOND HALF) NEW WAY TO DO BREAK TABLES
VERSION 17-1(35) 10-10-74 BY JFR FEAT %BS% (FIRST HALF) NEW WAY TO DO BREAK TABLES
VERSION 17-1(34) 10-10-74
VERSION 17-1(33) 10-10-74
VERSION 17-1(32) 10-10-74
VERSION 17-1(31) 10-10-74
VERSION 17-1(30) 10-10-74
VERSION 17-1(29) 9-16-74 BY RHT BUG #TH# OVERFLOW IN SCAN
VERSION 17-1(28) 9-8-74 BY RHT BUG #TF# NEW SCAN LOSING WHEN NO BRK CHR
VERSION 17-1(27) 7-29-74 BY RHT BUG #SW# NEW SCAN PROBLEM
VERSION 17-1(26) 7-19-74 BY RHT FEAT %BK% MAKE SCAN BETTER FOR NON-OMIT CASE
VERSION 17-1(25) 5-30-74 BY RHT FIX UP SOME COMPILS
VERSION 17-1(24) 5-29-74 BY RHT FIX STDBRK
VERSION 17-1(23) 5-25-74 BY RLS EDIT
VERSION 17-1(22) 5-25-74 BY rls edit
VERSION 17-1(21) 5-25-74 BY rls edit
VERSION 17-1(20) 5-25-74
VERSION 17-1(19) 5-25-74 BY RLS EDIT
VERSION 17-1(18) 5-24-74 BY RLS EDIT
VERSION 17-1(17) 5-24-74 BY RLS MAKE STDBRK SYSTEM INDEPENDENT
VERSION 17-1(16) 5-24-74
VERSION 17-1(15) 5-24-74 BY rht move some routines over from ioser
VERSION 17-1(14) 5-24-74
VERSION 17-1(13) 5-24-74
VERSION 17-1(12) 5-24-74
VERSION 17-1(11) 5-24-74
VERSION 17-1(10) 5-24-74
VERSION 17-1(9) 5-24-74
VERSION 17-1(8) 5-24-74
VERSION 17-1(7) 1-13-74 BY JRL BUG QI CVO DIDN'T WORK WITH INTERRUPTS ENABLED
VERSION 17-1(6) 1-13-74
VERSION 17-1(5) 12-14-73 BY RFS BUG #QB# MAKE CVG DO LARGEST NEG RIGHT
VERSION 17-1(4) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(3) 11-28-73 BY RLS BUG #PG# CVS OF '400000000000
VERSION 17-1(2) 11-28-73
VERSION 17-1(1) 11-25-73 BY RHT BUG #LA# MAKE CVSIX HONEST
VERSION 17-1(14) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(13) 3-18-73 BY RHT PROTECT RPH FROM USERERR
VERSION 16-2(12) 5-11-72 BY DCS BUG #GY# BE SURE ALIGNED IF SGLIGN & ALREDY CATED
VERSION 15-2(6-11) 5-11-72
VERSION 15-2(5) 2-8-72 BY DCS BUG #GL# -- CANCEL SAME -- COULDN'T GET RIGHT
VERSION 15-2(4) 2-6-72 BY DCS BUG #GL# CVF, CVG, CVE DON'T PUT OUT EXTRA SPACE WHEN NON-NEGATIVE
VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# OPTIMIZE CAT, REMOVE TOPSTR
VERSION 15-2(2) 12-21-71 BY DCS BUG #FS# REMOVE SAILRUN CONDITIONAL
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
SUBTTL Discussion
LSTON (STRSER)
DSCR BEGIN STRSER
IFN ALWAYS,<BEGIN STRSER>
DSCR STRSER DISCUSSION
Comment These routines manipulate entities known to
SAIL/GOGOL users as STRINGS. A string is described by
a two-word string descriptor with the following format:
WD1: string no,,# of characters
WD2: byte pointer to string
String no. is incremented whenever a new string is created at
the top of string space. (SUBSTR does not increment it). An
ILDB on WD2 gets the first character of the string.
All parameters necessary for string operations are in the user's
parameter table (GOGTAB pnts at it):
TOPBYTE: byte pointer to next available character
REMCHR: negative count of free characters remaining
ST: addr of first string space word
STTOP: addr of last word.
STRNGC is the compacting string garbage collector, called when not
enough space remains. The number of characters desired by the
operation detecting the lack is in register A on entry.
Strings are concatenated by copying both operands to the top
of string space (or only the 2nd if the first is already
on top), and creating a descriptor for the new string.
SUBSTR operations simply create new descriptors.
GETCH and PUTCH handle numeric to string conversions (vice-versa)
COMPIL(CAT,<CAT,CATCHR,CHRCAT,CHRCHR,CAT.RV>
,<SAVE,RESTR,X22,X33,STRNGC,INSET,GOGTAB,CONFIG,PUTCH>
,<CAT -- CONCATENATION ROUTINE>)
;;#GI# DCS 2-5-72 OPTIMIZE CAT SOME MORE, REMOVE TOPSTR
DSCR "STRING"_CAT("STR1","STR2");
CAL SAIL
DES CALL GENERATED BY COMPILER FOR & OPERATOR
DEFINE CANON (ADR,AC)<
LDB TEMP,[POINT 3,ADR,5] ;4,5,6,7,0,1 FROM POSITION
IMULI AC,5 ;ADDR IN CHARS
ADD AC,BPTBL(TEMP) ;0,1,2,3,4,5 EXTRA CHARS
>
;CAT'S MAP TABLE
BPTBL: 4
5
0
0
0
1
2
3 ;MAP
HERE (CAT.RV)
POP SP,TEMP ;ARGUMENTS ARE IN REVERSE ORDER,
POP SP,LPSA ; PUT THEM RIGHT
PUSH SP,-1(SP)
PUSH SP,-1(SP)
MOVEM LPSA,-3(SP)
MOVEM TEMP,-2(SP)
HERE (CAT)
MOVE USER,GOGTAB
POP P,UUO1(USER) ;SAVE FOR STRNGC ERR MESSAGE
MOVEI TEMP,-1 ;FOR TESTING LENGTHS
TDNN TEMP,-3(SP) ;FIRST STRING NULL?
JRST RETSEC ;YES, RETURN SECOND STRING
TDNN TEMP,-1(SP) ;SECOND STRING NULL?
JRST RETFRS ;YES, RETURN FIRST STRING
CATGO: MOVEI TEMP,RACS(USER)
BLT TEMP,RACS+3(USER)
MOVEM RF,RACS+RF(USER) ;SAVE F-REGISTER
CATGO1: HRRZ B,-2(SP) ;ADDR WORD OF FIRST STRING
MOVE LPSA,B
CANON (<-2(SP)>,LPSA) ;COMPUTE CANONICAL FORM
HRRZ A,-3(SP) ;#CHARS IN FIRST
ADD LPSA,A ;+#CHARS IN FIRST
HRRZ C,(SP) ;2D ADDRESS
CAMGE C,B ;IS IT POSSIBLE THEY ARE ALREADY CAT?
JRST CAT3 ;NO
CANON (<(SP)>,C) ;GET CANONICAL FORM OF 2D
CAMN C,LPSA ;SAME?
JRST ADJRET ;YES, RETURN ADJUSTED POINTER
CAT3: HRRZ C,TOPBYTE(USER) ;TRY SAME TRICK WITH THIS GUY
CANON (<TOPBYTE(USER)>,C)
CAMN C,LPSA ;FIRST AT THE TOP?
JRST ONLY1 ;YES
; TWO STRINGS TO MOVE
MOVTWO: ADD A,-1(SP) ;#CHARS(2)
HRRZ A,A ;ALLOW ROOM FOR POSSIBLE INSET
ADDM A,REMCHR(USER) ;#CHARS(NEW) - REMAINING #CHARS
SKIPLE REMCHR(USER) ;ENOUGH ROOM?
PUSHJ P,STRNGC ;NO, GO MAKE SOME
SKIPE SGLIGN(USER) ;IF ALIGNING,
PUSHJ P,INSET ; ALIGN
HRRZ B,-3(SP) ;GET 1ST # CHARS
HRROM A,-3(SP) ;COUNT RESULT
MOVE LPSA,TOPBYTE(USER);WILL BE NEW BYTE POINTER
MOVE A,LPSA ;WILL BE RESULT
EXCH A,-2(SP) ;TRADE WITH FIRST BYTE POINTER
ILDB C,A ;KNOWN NOT TO BE NULL STRING
IDPB C,LPSA ;MOVE THE STRING
SOJG B,.-2 ;RAPIDLY
HRRZ A,-1(SP) ;#CHARS(2)
JRST CATB
; ONLY ONE STRING TO MOVE
ONLY1: SKIPE SGLIGN(USER) ;CHECK ALIGNMENT?
;;#GY# SEE JUST BELOW
JSP C,CHKLGN ;YES, DON'T RETURN IF MISALIGNED
;;#GY#
;;#QE# DCS 12-30-73 Avoid problems when STRNGC expands
HRRZ A,-1(SP) ;#CHARS(2)
ADDM A,REMCHR(USER) ; - REMAINING CHARS
SKIPLE REMCHR(USER) ;ROOM?
; PUSHJ P,STRNGC ;NO
JRST [PUSHJ P,STRNGC ;no, collect, then start from scratch
MOVNS A ;since new string space may void
ADDM A,REMCHR(USER) ;the ONLY1 condition.
JRST CATGO1] ;CATGO1 is new for this fix.
;;#QE#
ADDM A,-3(SP) ;NEW #CHARS
MOVE LPSA,TOPBYTE(USER);EXTEND FROM HERE
; MOVE 2D
CATB: MOVE B,(SP) ;2D BYTE POINTER
ILDB C,B ;MOVE THIS STRING
IDPB C,LPSA ;AND MOVE IT
SOJG A,.-2 ; FAST
MOVEM LPSA,TOPBYTE(USER);PUT THIS AWAY, BY ALL MEANS
REST.4: MOVSI TEMP,RACS(USER)
BLT TEMP,C
RETFRS: SUB SP,X22 ;REMOVE NON-RESULT
JRST @UUO1(USER) ;RETURN
RETSEC: POP SP,-2(SP)
POP SP,-2(SP)
JRST @UUO1(USER) ;DIDN'T SAVE THEM
;;#GY# DCS 5-11-72 ASSURE FULL-WORD ALIGN IF SGLIGN AND ALREADY CATTED
ADJRET: SKIPE SGLIGN(USER) ;IF NEED ALIGNMENT, MUST CHECK IT
JSP C,CHKLGN ;DON'T RETURN IF NOT ALIGNED
OKLG: HRRZ TEMP,-1(SP) ;COUNT OF 2D
ADDM TEMP,-3(SP) ;INCREASE COUNT OF FIRST
JRST REST.4
CHKLGN: MOVE TEMP,-2(SP) ;Check the position field of first arg --
TLNN TEMP,300000 ;44, 01 are aligned, 35,27,17,10 not. Bits
JRST (C) ; 1 and 2 are both off only for 44 and 01.
JRST MOVTWO ;Not aligned, move both
;;#GY#
DSCR "STRING"_CHRCAT(CHAR,"STR")
HERE (CHRCAT)
HRRZ TEMP,-1(SP) ;CHECK OTHER STRING NULL
JUMPE TEMP,ITSNUL
PUSH SP,-1(SP) ;MAKE ROOM FOR ONE UNDERNEATH
PUSH SP,-1(SP)
MOVEI TEMP,-4(SP) ;NOW PUT SINGLE-CHAR STRING
PUSH TEMP,[ONECH: 1
POINT 7,RACS+5(USER),27] ;CONSTANT IN
PUSH TEMP,ONECH+1
JRST CATCGO ;GO DO SPECIAL CAT
DSCR "STRING"_CATCHR("STR",CHAR)
HERE (CATCHR)
HRRZ TEMP,-1(SP)
JUMPE TEMP,ITSNUL
PUSH SP,ONECH ;PUT ONE-CHAR DESCRIPTOR ON
PUSH SP,ONECH+1 ;TOP
CATCGO: MOVE USER,GOGTAB
POP P,UUO1(USER) ;RETURN ADDRESS
POP P,TEMP ;PUT IT SOMEWHERE SAFE
ADD TEMP,TEMP
MOVEM TEMP,RACS+5(USER)
JRST CATGO ;EVERYBODY'S NON-NULL
ITSNUL: SUB SP,X22
JRST PUTCH ;ZAP
DSCR "STRING"_CHRCHR(CHAR,CHAR)
HERE (CHRCHR)
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER)
PUSH P,A
MOVEI A,2 ;NEED 2 CHARS
ADDM A,REMCHR(USER)
SKIPLE A,REMCHR(USER)
PUSHJ P,STRNGC ;THE USUAL
MOVE A,-3(P) ;CHAR 1
EXCH A,(P) ;GET BACK SAVED
PUSHJ P,PUTCH ;A STRING
AOS -1(SP) ;2 CHARACTER STRING
MOVE TEMP,-1(P) ;CHAR 2
IDPB TEMP,TOPBYTE(USER);A 2-CHAR STRING
SUB P,X33
JRST @3(P) ;QUICK AS A BUNNY
;;#GI#
ENDCOM (CAT)
COMPIL(PTC,<PUTCH>,<GOGTAB,STRNGC,INSET>,<PUTCH -- PUT 1 CHARACTER ROUT>)
DSCR "1-CHR STRING"_PUTCH(INTEGER);
CAL SAIL
DES CALL GENERATED BY SAIL TO MAKE A 1 CHAR STRING FROM AN INTEGER
HERE(PUTCH)
MOVE USER,GOGTAB
MOVEM RF,RACS+RF(USER)
SKIPE SGLIGN(USER)
PUSHJ P,INSET ;START ON FW BDRY
POP P,UUO1(USER)
PUSH P,A ;SAVE A
MOVEI A,1 ;COUNT FOR STRNGC
AOSLE REMCHR(USER) ;DECREASE FREE CHARS
PUSHJ P,STRNGC ; NO
POP P,A ;RESTORE A
POP P,TEMP ;GET CHARACTER
PUSH SP,[XWD 40,1] ;#CHARS
PUSH SP,TOPBYTE(USER);HERE'S WHERE IT GOES
IDPB TEMP,TOPBYTE(USER) ;STORE CHAR, UPDATE TOPBYTE(USER)
JRST @UUO1(USER) ;RETURN
ENDCOM (PTC)
COMPIL(PNT,<POINT,BBPP.>,<GOGTAB,X22,X44>,<POINT, BBPP.>)
; GETCH AND LOP NOW DONE IN LINE, NO LONGER NEEDED
HERE (BBPP.)
HERE (POINT) MOVEI A,43 ;GET LOW BIT
SUB A,-1(P)
ROT A,-6 ;NOW IN HIGH BITS
MOVE TEMP,-3(P) ;BYTE SIZE
DPB TEMP,[POINT 6,A,11]
HRR A,-2(P) ;EFFECTIVE ADDRESS.
SUB P,X44
JRST @4(P)
ENDCOM(PNT)
COMPIL(CVF,<CVF,CVG,CVE>
,<SAVE,STRNGC,RESTR,X22,X11,X33,.MT.,.CH.,.TEN.>
,<CVF, CVG, CVE>)
DSCR "STRING"_CVF(REAL);
CAL SAIL
HERE (CVF) PUSHJ P,SAVE
PUSH P,[-1]
JRST SSCONV
DSCR "STRING"_CVG(REAL);
CAL SAIL
HERE (CVG) PUSHJ P,SAVE
PUSH P,[1]
JRST SSCONV
DSCR "STRING"_CVE(REAL);
CAL SAIL
HERE (CVE) PUSHJ P,SAVE
PUSH P,[0]
JRST SSCONV
BEGIN NUMOUT
^SSCONV:MOVE LPSA,X33
PUSHJ P,BOUND
;BOUND RETURNS AN INTEGER IN B WHICH WILL CONVERT
;TO 8 DECIMAL DIGITS.
;AN EXPONENT OF TEN IN D AND THE SIGN OF THE NUMBER IN FF
MOVM X,DIGS(USER) ;NUMBER OF DECIMALS
SKIPGE (P) ;IF F FORMAT
ADD X,D ;ADD THE TEN EXPONENT
JUMPN B,E0
JUMPN X,E0
MOVEI A,2
SKIPL (P)
MOVEM A,(P)
E0: JUMPGE X,E1
MOVEI B,0 ;THIS FIXES A BUG
JRST E2
E1: CAIL X,10
JRST E2
MOVEI Y,10 ; 0 LEQ X LESS THAN 8
SUB Y,X ;Y IS THE EXPONENT OF DIVISOR
MOVE Z,.TEN.(Y) ;Z IS THE DIVISOR
IDIV B,Z
ASH Z,-1
CAML C,Z
AOJ B, ;ROUND
CAMGE B,.TEN.(X) ;CHECK IF ROUND CAUSED ANOTHER DIGIT
JRST E2
SKIPGE (P) ;IF F FORMAT
AOJA X,E2 ;INCREASE DIGIT COUNT
IDIVI B,=10 ;OTHERWISE REMOVE IT
AOJ D, ;AND INCREASE EXPONENT
E2: MOVM A,DIGS(USER)
CAMGE A,X
MOVE A,X ;A CONTAINS NUMBER OF DIGITS
ADDI A,2 ;SIGN AND DECIMAL POINT
SKIPL (P)
ADDI A,4 ;IF NOT F FORMAT @-DD
MOVE Z,A ;SAVE CHARACTER COUNT
MOVM Y,WDTH(USER) ;MINIMUN STRING LENGTH
CAMG A,Y
MOVE A,Y
; THE STRING GARBAGE COLLECTOR GOODIES
ADDM A,REMCHR(USER) ;CHECK THERE IS ROOM
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC ;NO ROOM
HRRO C,A ;NON-ZERO, WITH COUNT
PUSH SP,C
PUSH SP,TOPBYTE(USER)
; INSERT LEADING SIGNS, BLANKS, ZEROES
SUB A,Z ;NUMBER OF LEADING SPACES
;;#GL# DCS 2-6-72 (1-1) EXTRA CHAR ONLY IF NEG. AND NO PADDING POSSIBLE
;;#GL# CANCELLED 2-8-72 BECAUSE I COULDN'T FIGURE IT ALL OUT
MOVEI C," "
JUMPE A,E4 ;NO LEADING SPACES
SKIPL WDTH(USER) ;F FORMAT
JRST E3
;; #GL#
JUMPE FF,.+2 ;LEADING ZEROS - NO SIGN, GO DO ZEROES
MOVEI C,"-"
IDPB C,TOPBYTE(USER)
MOVEI C,"0"
E5: IDPB C,TOPBYTE(USER) ;FILL WITH ZEROS
SOJG A,E5
JRST C1
E3: IDPB C,TOPBYTE(USER) ;FILL WITH BLANKS
SOJG A,E3
;; #GL#
E4: JUMPE FF,.+2 ;NO SIGN, BLANKS ALL DONE
;;#GL#
MOVEI C,"-" ;THEN THE SIGN
IDPB C,TOPBYTE(USER)
; CVF,CVE,CVG CONTD.
C1: MOVEI Z,10
SKIPL (P)
JRST C6
MOVE Y,X ;CVF NUMBER OF DIGITS
MOVM A,DIGS(USER) ;NUMBER OF DECIMALS
SUB Y,A ;POS OF DECIMAL POINT
JUMPGE Y,C5 ;IF POSITIVE
SUB Z,Y
MOVM X,DIGS(USER)
SETZ Y, ;OTHERWISE ZERO
JRST C5
C6: SETZ Y,
SKIPG (P)
JRST C5
JUMPL D,C5 ;CVG IF NEG TAKE CVE
CAMLE D,X ;IF ENOUGH DIGITS
JRST C5
MOVE Y,D ;SHIFT DECIMAL POINT
MOVEI D,0 ;AND ADJUST EXPONENT
C5: PUSH P,[D1] ;RECURSIVE NUMBER PRINTER
C2: CAIE X,(Y) ;DECIMAL POINT NOW
JRST C3
SOJ Z,
MOVEI C,"." ;YES
SKIPE DIGS(USER) ;IF ZERO DIGITS
JRST C4
JUMPN B,C4
MOVEI C," "
SKIPL -1(P)
JRST C9
SOJA X,C3
C9: MOVE Y,-1(P)
CAIE Y,2
JRST C4
POP P,Y
MOVE Y,[ASCII/ 0 /]
JRST D8
C3: CAILE X,(Z) ;IF MORE THAN 8 DIGITS
JRST [MOVEI C,"0" ;PUSH A ZERO
JRST C4]
IDIVI B,=10
IORI C,"0"
C4: HRLM C,(P)
SOSL X
C8: PUSHJ P,C2
C7: HLRZ C,(P) ;PUSH NUMBER OUT
IDPB C,TOPBYTE(USER)
POPJ P,
D1: SKIPGE (P)
JRST D7
SKIPN DIGS(USER)
SOJA D,D2
JUMPE D, [MOVE Y,[ASCIZ / /] ;EXPONENT ZERO SO STORE
JRST D8] ;FOUR BLANKS
D2: SETZ Y, ;ACCUMULATE EXPONENT STRING
SETZ FF, ;EXPONENT SIGN
JUMPL D, [SETO FF, ;NEGATIVE
MOVN D,D ;MAKE POSITIVE
JRST D4]
HRLI Y," "=11 ;NUMBER POS SO TRILING BLANK
D4: CAIGE D,=10
JRST [MOVEI X," "
LSHC X,-7
JRST D5]
D5: IDIVI D,=10
IORI X,"0"
LSHC X,-7 ;PUSH INTO Y
JUMPG D,D5
;;%DY% 2! GJA/JFR 1-13-77
SKIPN X,EXPCHR(USER) ;WHAT THE LOSER WANTED
MOVEI X,"@" ;NOT THERE, USE DEFAULT
IDPB X,TOPBYTE(USER)
MOVEI X,"-" ;MINUS SIGN
SKIPE FF
D6: IDPB X,TOPBYTE(USER) ;AND EXPONENT
JUMPE Y,D7
D8: LSHC X,7
JRST D6
D7: JRST RESTR ; RETURN
; CVF,CVG,CVE CONTD.
BOUND: SETZB FF,D ;TENS EXPONENT
MOVE B,-3(P) ;INPUT NUMBER
JUMPE B,ZERO
JUMPG B,POS
;;#QB# RFS MAKE LARGEST NEG NUMBER WORK
SETOB FF,A ;NUM IS NEG
LSHC A,11 ;SEPERATE BIN EXPONENT
LSH B,-1
SETCA A, ;BIN EXPONENT + 200
JUMPE B,LARN ;LARGEST NEGATIVE???
TLO B,400000 ;
MOVNS B
JRST OK
LARN: HRLOI B,177777 ; LARGEST NEG SHIFTED RIGHT 1 BIT
AOJA A,OK
;;#QB#
POS: SETZ A,
LSHC A,11 ;SEPERATE BIN EXPONENT
LSH B,-1
OK: SUBI A,200 ;BIN EXP IN A, ABS (BIN FRACT) IN B,
;BINARY POINT LEFT OF BIT 1 SIGN OF NUMBER IN FF
CAIL A,34
JRST MULTI ;USE NEGATIVE POWERS OF TEN
CAIG A,27 ;N LESS THAN 34
JRST FRACT ;USE POSITIVE POWERS OF TEN
CAIL A,33 ;30.2 LEQ N LESS THAN 34
JRST TOPQ
CAIG A,30 ;30.2 LEQ N LESS THAN 33
JRST BOT
DONE: SUBI A,43 ;31.2 LEQ N LESS THAN 33
ASHC B,(A)
TLNE C,200000 ;ROUND
AOJ B,
ADDI D,10
ZERO: POPJ P,
TOPQ: CAMLE B,MF ;33.2 LEQ N LESS THAN 34
JRST MULTI ;33.276 LESS THAN N LESS THAN 34
JRST DONE ;33.2 LEQ N LEQ 33.276
BOT: CAMGE B,LF ;30.2 LEQ N LEQ 30
JRST FRACT ;30.2 LEQ N LESS THAN 30.230
JRST DONE ;30.230 LEQ N LESS THAN 30
; CVF,CVG,CVE CONTD.
MULTI: MOVEI X,13 ;33.276 LESS THAN N
M2: ASH D,1
ADD A,.CH.(X) ;NEGATIVE POWERS OF TEN
CAIG A,31
JRST M1 ;N LESS THAN 32
PUSHJ P,LFMP ;31.2 LESS THAN N
M6: IORI D,1 ;SET EXPONENT BIT
CAIL A,34
SOJA X,M2 ;35.2 LESS THAN N STILL TOO LARGE
CAIE A,33 ;31.2 LESS THAN N LESS THAN 34
JRST M3 ;31.2 LESS THAN N LESS THAN 33
CAMLE B,MF ;33.2 LESS THAN N LESS THAN 34
JRST M4 ;33.276 LESS THAN N LESS THAN 34
M3: ASH D,-6(X) ;33.2 LESS THAN N LEQ 33.276
JRST DONE
M1: CAIL A,30 ;N LESS THAN 32
JRST M5 ;29.2 LESS THAN N LESS THAN 32
M8: SUB A,.CH.(X) ;N LESS THAN 30 NO GOOD
SOJA X,M2 ;TRY NEXT POWER
M4: CAIE X,6 ;33.276 LESS THAN N LESS THAN 34
SOJA X,M2
MOVE B,MF ;33.276=N
JRST DONE
M5: MOVE Y,B ;SAVE B AND A
MOVE Z,A
PUSHJ P,LFMP
CAIL A,31 ;29.2 LESS THAN N LESS THAN 32
JRST M6 ;31.2 LESS THAN N LESS THAN 32
CAIG A,27 ;29.2 LESS THAN N LESS THAN 31
JRST M7 ;29.2 LESS THAN N LESS THAN 30
CAML B,LF ;30.2 LESS THAN N LESS THAN 31
JRST M6 ;30.230 LESS THAN N LESS THAN 31
CAILE X,6 ;30.2 LESS THAN N LESS THAN 30.230
JRST M7 ;STILL SOME TO GO
MOVE B,LF ;B=30.230
JRST M6
M7: MOVE B,Y ;RESTORE
MOVE A,Z
JRST M8
; CVF,CVG,CVE CONTD.
FRACT: MOVEI X,5 ;N LESS THAN 30.230
L2: ASH D,1
ADD A,.CH.(X)
CAIL A,33
JRST L1 ;32.2 LEQ N
PUSHJ P,LFMP ;N LESS THAN 33
L6: IORI D,1
CAIGE A,30
SOJA X,L2 ;N LESS THAN 30
CAIE A,30 ;30.2 LEQ N LESS THAN 33
JRST L3 ;31.2 LEQ N LESS THAN 33
CAMGE B,LF ;30.2 LEQ N LESS THAN 31
JRST L4 ;30.2 LEQ N LESS THAN 30.230
L3: ASH D,(X) ;30.2300 LEQ N LESS THAN 31
L9: MOVNS D
JRST DONE
L1: CAIG A,34 ;32.2 LEQ N
JRST L5 ;32.2 LEQ N LESS THAN 35
L8: SUB A,.CH.(X) ;34.2 LEQ N
SOJA X,L2
L4: SOJGE X,L2 ;30.230 LEQ N LESS THAN 31
MOVE B,LF ;N30.230
JRST L9
L5: MOVE Y,B ;SAVE B AND A
MOVE Z,A
PUSHJ P,LFMP
CAIG A,32 ;32.2 LEQ N LESS THAN 35
JRST L6 ;32.2 LEQ N LESS THAN 33
CAIL A,34 ;33.2 LEQ N LESS THAN 35
JRST L7 ;34.2 LEQ N LESS THAN 35
CAMG B,MF ;33.2 LEQ N LESS THAN 34
JRST L6 ;33.2 LEQ N LESS THAN 34
JUMPG X,L7 ;33.276 LESS THAN N LESS THAN 34
MOVE B,MF ;N=33.276
JRST L6
L7: MOVE B,Y ;RESTORE
MOVE A,Z
JRST L8
LFMP: MUL B,.MT.(X)
TLNE B,200000
POPJ P,
ASHC B,1
SOJA A,.+1
POPJ P,
LF: 230455000000
MF: 276570177400
BEND
ENDCOM(CVF)
COMPIL(SUB,<SUBST,SUBSR>,<SAVE,RESTR,X22,.SKIP.,GOGTAB>,<SUBSTRING ROUTINES>)
DSCR "STRING"_SUBST("STRING",END CHAR,STARTING CHAR);
CAL SAIL
DES CALL GENERATED BY SAIL FOR STR[X FOR Y] OPERATION
HERE (SUBST)
MOVE LPSA,-2(P) ;END LOC
JRST SBSTR ;GO FINISH UP
; SUBSI NO LONGER NEEDED, REMOVED
DSCR "STRING"_SUBSR("STRING",#CHARS, START CHAR #);
CAL SAIL
DES CALL GENERATED BY SAIL FOR STR[X TO Y] OPERATION
ALGORITHM IS AS FOLLOWS:
1) !SKIP!_FALSE; "NOSKIP" IF ALL OK
< 2) IF END LOC > LENGTH, REPLACE IT BY LENGTH, (RH(!SKIP!)_TRUE;
3) NOW IF START < 1 OR END-START < -1 (-1 means ZERO LENGTH REQUEST),>>
LH(!SKIP!)_TRUE, SET START TO 1 OR LENGTH+1
4) ADJUST LENGTH AND BP IN DESCRIPTOR
NOTICE THAT STR[INF+1 TO INF+1+(non-neg integer)] IS LEGAL, RETURNING NULL,
AND TURNING ON !SKIP!
HERE (SUBSR)
SOS LPSA,-2(P) ;#CHARS
ADD LPSA,-1(P) ;-1 + START = END
SBSTR: MOVE TEMP,GOGTAB ;FOR A MOMENT
POP P,UUO1(TEMP) ;SAVE RETURN -- NONSTANDARD!!
SETZM .SKIP. ;ASSUME ALL OK
MOVE USER,(P) ;START LOC
HRRZ TEMP,-1(SP) ;LENGTH OF STRING
JUMPL LPSA,[ TDZA LPSA,LPSA ;END LOC CANNOT BE NEGATIVE
NO4: MOVE LPSA,TEMP ;NOR GREATER THAN LENGTH
HLLOS .SKIP. ;TELL THE USER END WAS WRONG
JRST OKS1]
CAMLE LPSA,TEMP ;END LOC CANNOT BE GREATER THAN LENGTH
JRST NO4
OKS1: CAIL USER,1(LPSA) ;NEW STRING MUST HAVE NON-NEG LENGTH
JRST NO1 ;ADJUST TO 1(LPSA)
JUMPLE USER,[NO2: MOVEI USER,1 ;NON-POS, ADJUST TO 1
JRST NO3
NO1: MOVEI USER,1(LPSA) ;1 PAST END OF REQUEST
NO3: HRROS .SKIP. ;TELL USER START IS BAD
JRST OKS] ;NOW CAN DO SUBSTRING
OKS: SUBI LPSA,-1(USER) ;NEW STRING LENGTH
HRRM LPSA,-1(SP) ;GET RID OF IT, FORGET IT
MOVE LPSA,(SP) ;BP
LDB TEMP,[POINT 3,LPSA,5]
TRC TEMP,4 ;# CHARS FROM BEG OF CURRENT BP
ADDI TEMP,-1(USER) ;+ # ADDITIONAL CHARS DUE TO SUBSTR
CAILE TEMP,4 ;CAN WE AVOID DIV OR SUB?
JRST DIVSUB ;NO
GETPTF: HLL LPSA,PTBL(TEMP) ;GET POINTER AND SIZE FIELDS
PTWAY: MOVEM LPSA,(SP) ;RESULT BP
SUB P,X22 ;RID SELF OF ARGUMENTS
JRST @3(P) ;RETURN
DIVSUB: CAILE TEMP,9 ;CAN WE AVOID DIV?
JRST DIV ;NO
SUBI TEMP,5 ;PUT # IN RANGE 0 TO 4
ADDI LPSA,1 ;INCREMENT BP
JRST GETPTF ;FINISH UP
; N.B. -- LPSA=13, TEMP=14, USER=15 -- CHANGE THIS CODE IF YOU MODIFY THESE
; ASSIGNMENTS
DIV: IDIVI TEMP,5 ;# WORDS TO USER, # CHARS TO TEMP
ADD LPSA,TEMP ;INCREMENT BP ADR FIELD
HLL LPSA,PTBL(USER) ;GET POINTER AND SIZE FIELDS
JRST PTWAY ;FINISH UP
PTBL: POINT 7,0
POINT 7,0,6 ;POINTER AND SIZE FIELDS FOR 7-BIT BYTES
POINT 7,0,13
POINT 7,0,20
POINT 7,0,27
POINT 7,0,35
ENDCOM (SUB)
COMPIL(EQU,<EQU>,<X44>,<EQU>)
DSCR BOOLEAN_EQU("STR1","STR2");
CAL SAIL
HERE (EQU)
; NOTE USER NOT SET UP BECAUSE CAN BE NO ERROR MESSAGES
PUSH P,B ;SAVE EXTRA AC
HRRZ A,-1(SP) ;LENGTH OF ONE STRING
HRRZ B,-3(SP) ;LENGTH OF THE OTHER
CAME A,B ;SAME?
JRST NOTEQ ; NO, NOT EQUAL STRINGS
MOVE LPSA,(SP) ;ONE BYTE POINTER
MOVE USER,-2(SP) ;THE OTHER
JRST CLUP1 ;ENTER THE LOOP AT ITS BASE
CLUP: ILDB TEMP,LPSA ;ONE CHAR
ILDB B,USER ;ANOTHER
CAMN TEMP,B ;QUIT IF NOT EQUAL
CLUP1: SOJGE A,CLUP ;CONTINUE UNTIL ALL PERUSED OR SOME NOT EQUAL
JUMPL A,.+2 ;IF -1, THEY'RE EQUAL, USE -1 TO BE TRUE
NOTEQ: MOVEI A,0 ;NOT EQUAL
POP P,B ;RESTORE AC
SUB SP,X44 ;GET RID OF ARGS
POPJ P, ;RETURN
ENDCOM (EQU)
COMPIL(CVD,<CVD,CVO>,<SAVE,RESTR,X11,X22>,<CVD AND CVO ROUTINES>)
DSCR INTEGER_CVD("STRING");
CAL SAIL
HERE (CVD)
PUSHJ P,SAVE
MOVEI A,=10
JRST CV
DSCR INTEGER_CVO("STRING");
CAL SAIL
HERE (CVO)
PUSHJ P,SAVE
JOV .+1 ;CLEAR ANY OVERFLOWS
MOVEI A,10
CV: SETZB B,Y ;COLLECT RESULT IN B, Y IS +/- FLAG
MOVE LPSA,X11
HRRZ C,-1(SP) ;STRING COUNT
MOVE D,(SP) ;BYTE POINTER
CVL: SOJL C,CVDUN
ILDB X,D ;GET A CHAR
CAIG X," " ;IGNORE LEADING " "s AND SUCH
JRST CVL
CAIN X,"-" ;NEGATIVE?
TLCA Y,10000 ;NEGATE PREVIOUS NOTION
CAIN X,"+" ;PLUS?
JRST CVL ; GO BACK FOR MORE LEADING "BLANKS"
; NOW IT IS A DIGIT OR THE END
CNV: CAIL X,"0" ;IN RANGE?
CAIL X,"0"(A) ;A IS RADIX
JRST CVDUN ;NOT IN RANGE, DONE
IMUL B,A ;NUM=NUM*10+NEWDIG
;; #QI# THESE THREE USED TO BE DOWN AT CVDUN
JOV [CAIN A,10 ;CVO?
TLC B,400000 ;YES, THIS SPECIAL HACK ALLOWS TYPING AN
JRST .+1] ;UNSIGNED OCTAL NO. WITH BIT 0 ON
;; #QI#
ADDI B,-"0"(X)
SOJL C,CVDUN ;DONE WHEN NEGATIVE
ILDB X,D
JRST CNV
CVDUN:
IOR Y,[MOVEM B,RACS+1(USER)] ;MOVEM OR MOVNM
XCT Y
SUB SP,X22
JRST RESTR
ENDCOM(CVD)
COMPIL(CVS,<GETFORMAT,SETFORMAT,CVS,CVOS>
,<GOGTAB,INSET,X33,SAVE,RESTR,X11,X22,STRNGC>
,<GETFORMAT, SETFORMAT, CVS, CVOS ROUTINES>)
DSCR "STR"_CVS(INTEGER);
CAL SAIL
HERE(CVS) PUSHJ P,SAVE
PUSHJ P,CVSET ;SET UP FOR CONVERSION
MOVEI D,=10 ;WILL DIVIDE DECIMAL
SKIPL B,-2(P) ;IF NUMBER IS NEGATIVE,
JRST FRNP ; PRINT A MINUS SIGN,
MOVM B,B ;PRINT ABS VALUE
JFCL 10,.+1 ;
MOVEI Y,"-" ;Y IS NOT ZERO, SIGNALS BLKIN BELOW
MOVEI A,1 ;ACCOUNT FOR EXTRA CHARACTER
;; #PG# (1 OF 2) MAKE CVS WORK FOR '400000000000
JUMPGE B,FRNP ;GO PRINT
; ACCOUNT FOR LARGEST NEGATIVE NUMBER ('400000,0)
MOVE B,[=3435973836] ;34359738368 IS LARGEST NUMBER REP IN MACHINE
MOVEI C,"8"
HRLM C,(P) ;PUT ON STACK
AOJA A,FRNP1 ;ACCOUNT FOR CHARACTER
;; #PG#
DSCR "STR"_CVOS(INTEGER);
CAL SAIL
HERE (CVOS) PUSHJ P,SAVE
PUSHJ P,CVSET
MOVEI D,10 ;OCTAL DIVIDE
MOVE B,-2(P) ;GET THE DATA
LSHC B,-3 ;MAKE SURE NUMBER BEING
LDB C,[POINT 3,C,2] ;DIVIDED IS + BY SIMULATING
JRST FRNX ; THE FIRST RESULT.
FRNP: IDIV B,D ;FAMOUS RECURSIVE NUMBER PRINTER
FRNX: IORI C,"0"
HRLM C,(P)
ADDI A,1
JUMPE B,BLKIN ;GO TEST FOR LEADING BLANKS
;; #PG# ! LABEL OTHER ENTRY POINT
FRNP1: PUSHJ P,FRNP
POPOFF: HLRZ C,(P)
IDPB C,TOPBYTE(USER)
POPJ P,
BLKIN: MOVEI D," " ;GIVE LEADING BLANKS IF WDTH POS,
SKIPL WDTH(USER) ; LEADING 0'S IF NEG.
JRST LEDBLK ;BLANKS
MOVEI D,"0"
JUMPE Y,LEDBLK ;NEGATIVE?
IDPB Y,TOPBYTE(USER) ;YES, PUT IN SIGN
MOVEI Y,0 ;DON'T DO IT AGAIN!
LEDBLK: CAML A,X ;NEED MORE FILL?
JRST POPOF1 ; NO
IDPB D,TOPBYTE(USER) ; YES, DROP IN ONE MORE
AOJA A,LEDBLK ;AND CONTINUE
POPOF1: JUMPE Y,POPOFF ;NEGATIVE, WERE FILLING BLANKS
IDPB Y,TOPBYTE(USER) ; YES, PUT SIGN IN AFTER BLANKS
JRST POPOFF ;GO PUT OUT NUMBER
FRNPDN: HRROM A,-1(SP) ;CHAR COUNT, NON-CONST STRING
MOVEI TEMP,=15 ;GIVE BACK WHAT WASN'T USED
CAMGE TEMP,X ; (15 IF GT WDTH, ELSE WDTH
MOVE TEMP,X ; USED FOR CALCULATION)
SUB A,TEMP
ADDM A,REMCHR(USER) ;UPDATE REMCHR
JRST RESTR
CVSET:
SKIPE SGLIGN(USER) ;IF ALIGNING,
PUSHJ P,INSET ; ALIGN
MOVE LPSA,X22
MOVM X,WDTH(USER) ;TOTAL FIELD SIZE, UNLESS NUMBER IS BIGGER
MOVEI A,=15 ;CHECK THAT THERE WILL
CAMGE A,X ; BE ROOM FOR THE NUMBER
MOVE A,X ; (USE 15 OR WDTH, WHICHEVER IS BIGGER
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC ;NO ROOM
MOVEI A,0
MOVEI Y,0 ;NOT NEG AS OF YET
PUSH SP,A ;A IS COUNT, SAVE STRING NO WORD SPACE
PUSH SP,TOPBYTE(USER);AND RESULTANT BYTE POINTER
POP P,D ;RETURN ADDR
PUSH P,[FRNPDN] ;CALLED IN-LINE FIRST TIME
JRST (D)
HERE (SETFORMAT)
MOVE USER,GOGTAB
POP P,TEMP ;RETURN ADDRESS
POP P,DIGS(USER) ;#DIGS TO RIGHT OF .
POP P,WDTH(USER) ;TOTAL FIELD WIDTH
JRST (TEMP)
DSCR GETFORMAT(@WIDTH,@DIGS);
CAL SAIL
HERE(GETFORMAT)
MOVE USER,GOGTAB
MOVEW (<@-1(P)>,<DIGS(USER)>)
MOVEW (<@-2(P)>,<WDTH(USER)>) ;GIVE USER RESULTS
SUB P,X33
JRST @3(P) ;RETURN
ENDCOM(CVS)
COMPIL(SCC,<SCANC>,<GETBREAK,SETBREAK,RELBREAK,SCAN>,<SCANC ROUTINE>)
DSCR
STRING PROCEDURE SCANC(STRING ARG,BRK,OMIT,MODE); BEGIN "SCANC"
INTEGER TBL,BRCHAR;
TBL_GETBREAK; SETBREAK(TBL,BRK,OMIT,MODE);
RSLT_SCAN(ARG,TBL,BRCHAR);
RELBREAK(TBL);
RETURN(RSLT) END "SCANC";
HEREFK(SCANC,SCANC.)
PUSHJ P,GETBREAK;
PUSH P,A ;SAVE TABLE NUMBER
PUSH P,A ;TABLE
PUSHJ P,SETBREAK ;GOBBLE DOWN ALL STRINGS BUT ARG
PUSH P,[0] ;SPACE FOR BRCHAR;
MOVEI A,(SP)
PUSH P,A ;LOC(ARG)
PUSH P,-2(P) ;TABLE #
MOVEI A,-2(P) ;LOC(BRCHAR)
PUSH P,A
PUSHJ P,SCAN
POP SP,-2(SP) ;CLOBBER ARG WITH RSLT
POP SP,-2(SP)
POP P,(P) ;REMOVE BREAK CHARACTER
PUSHJ P,RELBREAK ;GOBBLE SAVED TABLE NUMBER
POPJ P,
ENDCOM(SCC)
COMPIL(SCN,<SCAN,BKTCHK>
,<INSET,SAVE,RESTR,X44,STRNGC,BRKMSK,CORGET>
,<SCAN ROUTINE>)
DSCR "STR"_SCAN(@"STRING",BRKTBL,@BRCHAR);
CAL SAIL
HERE (SCAN)
..SCAN: PUSHJ P,SAVE
SKIPE SGLIGN(USER)
PUSHJ P,INSET
MOVE LPSA,X44
SOS C,-3(P) ;PTR TO STRING TO BE SCANNED
HRRZ A,(C) ;#CHARS IN INPUT STRING
;;%BK% USED TO DO GC CHECKING HERE (NOW DO IT LATER)
JUMPE A,NULSCN ;IF NO CHARS TO SCAN
MOVE B,1(C) ;INPUT BYTE POINTER
MOVEI Z,0
MOVE X,-2(P) ;TABLE #
MOVEI TEMP,-1 ;ERROR IF BLOCK NOT THERE OR NOT INIT'ED
PUSHJ P,BKTCHK ;CHECK OUT TABLE #
JRST ENDSCN ;ERROR OF SOME SORT
;CHNL IS NOW 1 TO 18, CDB POINTS AT CORGET BLOCK
SCNNX: MOVE D,BRKMSK(CHNL) ;HAS BITS ON FOR THIS TABLE
TRNE D,@BRKCVT(CDB) ;WANT CONVERSION?
;;%##% LDE 3-JAN-73 LET US ALLOW LOWER TO UPPER CASE CONVERSION
TLOA C,400000 ; YES
TLZ C,400000 ; NO
SETZM @-1(P) ;BREAK CHAR WORD
MOVE Y,CDB
ADD Y,[XWD X,BRKTBL];RLC+BRKTBL(CDB)
ADD CHNL,CDB ;RELOCATE 1 TO 18
;;%BK% SEE IF WE MUST COPY
TRNN D,@BRKOMT(CDB) ;COPY IF OMIT CHARS
JUMPGE C,NOCPY ;OR IF DOING CONVERSION
ADDM A,REMCHR(USER) ;WE MUST COPY THE STRING
SKIPLE REMCHR(USER) ;THE "OUT OF SPACE DANCE"
PUSHJ P,STRNGC
PUSH SP,A
PUSH SP,TOPBYTE(USER) ;RESULT BYTE POINTER
;;%SW% ! the garbage collector may get in
MOVE B,1(C) ;GET BYTE POINTER BACK
SCNLUP: SOJL A,SCNDUN ;STRING EXHAUSTED
ILDB X,B ;GET A CHAR
;;%##% UC CONVERSION
JUMPGE C,NOCNVS ;ONLY CONVERT IF WANTED
CAIL X,"a"
CAILE X,"z"
JRST .+2
TRZ X,40 ;MAKE IT UPPER CASE
NOCNVS: TDNE D,@Y ;TDNE D,BRKTBL+RLC(X)
JRST SCNSPC ;OMIT OR BREAK
IDPB X,TOPBYTE(USER)
AOJA Z,SCNLUP
SCNSPC: HLLZ TEMP,@Y ;NOW SEE IF WE
TDNN TEMP,D ;OMIT OR BREAK
JRST SCNLUP ; OMIT
SCNBRK: MOVEM X,@-1(P) ;SET BREAK CHAR WORD
SCNDUN: SKIPN TEMP,DSPTBL(CHNL) ;WHAT DO WE DO WITH BRCHAR?
JRST ENDSCN ; NOTHING
JUMPL TEMP,SCNAPN ;APPEND TO END OF STRING
SCNRET: SOS B ;LEAVE FOR NEXT TIME
REPEAT 4,<IBP B
>
JUMPL A,ENDSCN ;STRING WAS EXHAUSTED
AOJA A,ENDSCN ;PUT ONE BACK
SCNAPN:
;;#FM# 11-15-71 DCS (1-1)
JUMPL A,ENDSCN ;SCANNED OFF END, NOTHING LEFT TO APPEND
;;#FM#
IDPB X,TOPBYTE(USER)
ADDI Z,1
;;#GI# DCS 2-5-72 REMOVE TOPSTR
ENDSCN: MOVE TEMP,Z ;#CHARS IN NEW STRING
SUB TEMP,-1(SP) ;NUMBER RESERVED BUT NOT USED
ADDM TEMP,REMCHR(USER);UNRESERVE THEM
HRROM Z,-1(SP) ;NOT A CONSTANT, NEW STRING SIZE
JUMPGE A,.+2 ;IF EXHAUSTED, USE 0
MOVEI A,0
HRRM A,(C) ;UPDATE OLD COUNT
;;#GI#
MOVEM B,1(C) ;UPDATED ORIGINAL BYTE POINTER
JRST RESTR ;POPJ P,
NULSCN: SETZM @-1(P) ;NO BREAKS
;;%BK%
PUSH SP,A ;NULL STRING RESULT
PUSH SP,A ;
JRST RESTR
NOCPY: PUSH SP,(C) ;COPY COUNT WRD FROM INPUT (WILL MUNCH)
PUSH SP,1(C) ;BYTE POINTER TO START
;;#TF# (=D4=) LDE ! IF NO BREAK CHAR, DON'T HANDLE ONE
SCNLP2: SOJL A,ENDSC2 ;COUNT DOWN
ILDB X,B ;GET NEXT CHAR
TDNN D,@Y ;IS BREAK CHAR ON (KNOW NOT OMIT)
AOJA Z,SCNLP2 ;JUST REGULAR
MOVEM X,@-1(P) ;IT WAS THE BREAK CHAR
SCNDN2: SKIPN TEMP,DSPTBL(CHNL) ; FIGURE OUT WHAT TO DO WITH BRK CHR
JRST ENDSC2 ;NICHTS
JUMPL TEMP,SCNAP2 ;APPEND IT
; SOS B ;BACK UP BYTE POINTER TO LEAVE CHAR
; IBP B ;
;; IBP B ;
; IBP B ;
; IBP B ;
;; JRL - FOLLOWING "OPTIMIZATION" FOR ABOVE CODE DUE TO REG
;;#TH# RHT 9-16-74 THE ADD & SUBTRACT CAN OVERFLOW
ADD B,[070000,,0] ;BACK UP BYTE POINTER
JFCL 17,.+1 ;SO OVERFL STAYS HAPPY
JUMPG B,.+3
SUB B,[430000,,1] ;BACK UP ONE WORD WHEN NECESSARY
JFCL 17,.+1 ;SO OVERFL STAYS HAPPY
;
AOJA A,ENDSC2 ;& WE HAVE ONE MORE LEFT
SCNAP2: ADDI Z,1 ;APPEND ONE MORE CHAR TO RESULT
ENDSC2: HRRM Z,-1(SP) ;
CAIGE A,0 ;NEVER PUT NEG COUNT
MOVEI A,0 ;THERE YOU GO
HRRM A,(C) ;FIX INPUT BYTE CNT
MOVEM B,1(C) ;NEW INPUT BYTE PTR
JRST RESTR ;ALL DONE
;;%BK%
DSCR BKTCHK
Checks break table number for break table routines
(SCAN,INPUT,TTYIN,PTYIN,BREAKSET,STDBRK)
CAL PUSHJ P,BKTCHK
PAR USER set up
X break table number
TEMP flags
left half: what to do if CORGET block is not there
0error, -1get a block
right half: whether table must be initialized
0no, -1yes
SID uses X,Y,CDB,CHNL (also B,C if it is necessary to call CORGET)
RET +1 error of some sort
+2 no error. CDB points at the CORGET block
CHNL is the table number modulo 18 in the range 1 to 18
HERE(BKTCHK)
;;#%%# ! MAKE BREAKTABLE 0 A SPECIAL CASE JFR 11-2-74
JUMPE X,.BKCKZ
ADDI X,=17 ;TABLE # NOW IN RANGE 0 THROUGH 71
SKIPN BKTPRV(USER) ;PRIVILEGED?
CAIL X,=18 ;LOWEST FOR ORDINARY USERS
CAILE X,=71 ;MAX FOR EVERYBOCY
;;#TP# BETTER ERROR MESSAGE JFR 10-26-74
JRST [MOVE X,X
ERR <BKTCHK: Breaktable out of range: >,7
JRST CPOPJ]
IDIVI X,=18
MOVEI CHNL,1(Y) ;CHNL NOW IN RANGE 1 TO 18
MOVE Y,X ;SAVE FOR POSSIBLE ERROR MESSAGE
ADD X,USER ;RELOCATE GROUP NUMBER
SKIPN CDB,BKTPTR(X) ;POINTER TO COREGET BLOCK
JRST .BKCKN ;BLOCK NOT THERE
TRNN TEMP,-1 ;NEED INITIALIZATION?
JRST CPOPJ1 ;NO
HRRZ X,BKJFFO(CDB) ;INITIALIZATION BITS
TDNN X,BRKMSK(CHNL) ;WAS IT INIT'ED?
;;#TP# BETTER ERROR MESSAGE JFR 10-26-74
JRST [.BKCKE: IMULI Y,=18 ;RECONSTUCT THE NUMBER SO WE CAN DISPLAY IT
ADD Y,CHNL
SUBI Y,=18
ERR <BKTCHK: Uninitialized break table: >,7
JRST CPOPJ]
CPOPJ1: AOS (P) ;SUCCESS, SKIP RETURN
CPOPJ: POPJ P,
.BKCKN: JUMPGE TEMP,.BKCKE ;IF INIT REQ'D AND BLOCK NOT THERE, ERROR
PUSH P,CHNL ;SAVE 1 TO 18
PUSH P,X ;SAVE LOCATION FOR POINTER
MOVEI C,BRKDUM+1 ;AMOUNT TO GET
PUSHJ P,CORGET
ERR <BKTCHK: CORGET failed>
MOVE CDB,B ;ADDR OF BLOCK
SETZM (B) ;CLEAN IT OUT
HRLI B,(B) ;
HRRI B,1(B)
BLT B,BRKDUM(CDB) ;
POP P,X
POP P,CHNL
MOVEM CDB,BKTPTR(X) ;SAVE FOR FUTURE REFERENCE
JRST CPOPJ1 ;SUCCESS
;;#%%# MAKE SPECIAL CASE FOR BREAKTABLE 0 JFR 11-2-74
.BKCKZ: SETZ CHNL, ;CHEAT ON "RANGE 1 TO 18"
MOVEI X,1(USER)
SKIPN CDB,BKTPTR(X) ;POINTER FOR CORGET BLOCK, TABLES 1 TO 18
JRST .BKCKN+1 ;CORGET BLOCK NOT THERE: FETCH, FIDO
JRST CPOPJ1 ;SUCCESS
ENDCOM(SCN)
COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR,CV6STR,CVASTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
,<CVSIX, CVASC, CVSTR, CVXSTR, CV6STR -- CHARACTER CONVERSION ROUTINES>)
DSCR SIXBIT INTEGER_CVSIX("STRING");
CAL SAIL
;;#LA# THIS ROUTINE USED TO CALL FILNAM
HERE (CVSIX)
MOVEI A,0 ;WILL DPB THE SIXBIT INTO HERE
HRRZ TEMP,-1(SP) ;BYTE COUNT
JUMPE TEMP,CVSXX ;NULL
CAILE TEMP,6 ;ONLY USE FIRST SIX CHARS
MOVEI TEMP,6 ;
MOVE LPSA,[POINT 6,A];
PUSH P,B ;NEEDED 1 MORE AC
MOVE B,(SP) ;BYTE POINTER
CVSXXL: ILDB USER,B ;THE CHARACTER
TRZN USER,100 ;MOVE 100 BIT TO 40
TRZA USER,40 ;
TRO USER,40 ;
IDPB USER,LPSA ;PUT AWAY
SOJG TEMP,CVSXXL ;LOOP
POP P,B ;GET BACK THE EXTRA AC
CVSXX: SUB SP,X22 ;EXIT
POPJ P,
DSCR ASCII INTEGER_CVASC("STRING");
CAL SAIL
HERE (CVASC)
PUSHJ P,SAVE
POP SP,X
POP SP,B
HRRZS B ;STRING ARG
MOVEI C,5
MOVE D,[POINT 7,A]
MOVEI A,0
LUP: SOJL B,DUNN
ILDB Y,X
IDPB Y,D
SOJG C,LUP ;COLLECT CHARS IN A
DUNN: MOVEM A,RACS+1(USER) ;RESULT
MOVE LPSA,X11
JRST RESTR
DSCR "STR"_CVSTR(ASCII INTEGER);
CAL SAIL
HERE (CVSTR)
PUSHJ P,SAVE
MOVEI A,5
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC
PUSHJ P,INSET ;ALIGN TO FW BDRY
;;#GI# DCS 2-5-72 REMOVE TOPSTR
PUSH SP,[XWD 40,5] ;BEST NON-CONSTANT STRING REP
;;#GI#
PUSH SP,TOPBYTE(USER)
;; \UR#9\ MAKE SURE BIT 35 OFF (JRL)
; MOVEW @TOPBYTE(USER),-1(P)
;;; bit 35 sometimes left on. screws string compare in compiler
move 14,-1(p)
trz 14,1
movem 14,@topbyte(user);
;;;
;; \UR#9\
AOS TOPBYTE(USER)
MOVE LPSA,X22
JRST RESTR
DSCR "STR"_CVXSTR(SIXBIT INTEGER);
CAL SAIL
HERE (CVXSTR)
PUSHJ P,SAVE
;;%BW% !
MOVEI C,0 ;A FLAG
CVXST1: SKIPE SGLIGN(USER)
PUSHJ P,INSET
MOVEI A,6
ADDM A,REMCHR(USER) ;UPDATE REMAINING CHAR COUNT
SKIPLE REMCHR(USER) ;IS THERE ROOM FOR THIS STRING?
PUSHJ P,STRNGC ;NO, TRY TO GET IT
;;#GI# DCS 2-5-72 REMOVE TOPSTR
PUSH SP,[XWD 40,6] ;NON-CONST,,COUNT FOR RESULT
;;#GI#
PUSH SP,TOPBYTE(USER) ;RESULT STARTS HERE
MOVEI A,6
MOVE B,[POINT 6,-1(P)] ;POINT AT INPUT SIXBIT
;;%BW% MAKE THIS CODE WORK FOR CV6STR TOO
CVXLP: ILDB TEMP,B ;GET A SIXBIT CHAR
JUMPE C,CVXST2
JUMPE TEMP,CVXST3
CVXST2: ADDI TEMP,40 ;CONVERT TO ASCII
IDPB TEMP,TOPBYTE(USER) ;PUT IN RESULT STRING, UPDATE TOPBYTE
SOJG A,CVXLP ;DO IT ALL
CVXST3: MOVN A,A ;MAKE REMCHR HONEST
ADDM A,-1(SP) ;AS WELL AS BYTE CNT IN STRING
ADDM A,REMCHR(USER)
MOVE LPSA,X22 ;REMOVE ARG, RETURN ADDRESS
JRST RESTR ;AND RETURN
DSCR "STR"_CV6STR(SIXBIT INTEGER);
CAL SAIL
DES LIKE CVXSTR BUT STOPS ON SPACE.
HEREFK(CV6STR,CV6ST.)
PUSHJ P,SAVE
MOVEI C,1
JRST CVXST1
;;%BW% ^
;;%CA%
DSCR "STR"_CVASTR(INTEGER)
CAL SAIL
DES LIKE CVSTR BUT STOPS ON A NULL CHARACTER
HEREFK(CVASTR,CVAST.)
PUSHJ P,SAVE
MOVEI A,5 ;BE SURE HAVE ENOUGH ROOM
ADDM A,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC
PUSH SP,[XWD 40,5] ;STERILE STRING CNT WD
PUSH SP,TOPBYTE(USER) ;WHAT THE DESCR WILL BE
MOVE 4,-1(P); ;
MOVEI 5,0 ;
MOVNI A,5 ;
MOVE TEMP,[POINT 7,4] ;
CVALP: ILDB C,TEMP ;PICK UP A CHARACTER
JUMPE C,CVALDN ;DONE WHEN SEE NULL
IDPB C,TOPBYTE(USER) ;PUT IT DOWN
AOJA A,CVALP
CVALDN: ;CORRECT REMCHR
ADDM A,REMCHR(USER)
ADDM A,-1(SP) ;AND STRING DESCR
MOVE LPSA,X22 ;RETURN
JRST RESTR
;; %CA% ^
ENDCOM(CVC)
COMPIL(CVL,<CVFIL>,<SAVE,RESTR,X22,X33,FILNAM,.SKIP.>,<CVFIL>)
DSCR SIXBIT INTEGER_CVFIL("FILE STRING",@RESULT EXTENSION,@RESULT PPN);
CAL SAIL
HERE (CVFIL)
PUSHJ P,SAVE
SETZM .SKIP. ;ASSUME NO PROBLEMS
PUSHJ P,FILNAM ;GET FILENAME COMPONENTS FROM STRING ARG
SETOM .SKIP. ;NO GOOD SPEC, REPORT IF HE'S INTERESTED
MOVE TEMP,FNAME(USER)
MOVEM TEMP,RACS+1(USER) ;AMJOR RESULT (NAME) TO R1
MOVE TEMP,FNAME+1(USER)
MOVEM TEMP,@-2(P) ;EXTENSION TO REF ARG.
MOVE TEMP,FNAME+3(USER)
MOVEM TEMP,@-1(P) ;PPN TO REF ARG.
;;=I09= IF SFD POINTER, SET .SKIP. = 1, FOR OLD PROGRAMS
SFDS<
SKIPE .SKIP. ;IF REAL ERROR, DON'T DO THIS
JRST .+4
JUMPE TEMP,.+3
TLNN TEMP,777777 ;IF NOT REAL PPN
AOS .SKIP. ;SET .SKIP. = 1
> ;SFDS
MOVE LPSA,X33
JRST RESTR
ENDCOM(CVL)
COMPIL(BRK,<BREAKSET,SETBREAK>
,<SAVE,RESTR,BRKMSK,BKTCHK,X22,X33>
,<BREAKSET, SETBREAK ROUTINES>)
DSCR BREAKSET(TABLE #,"STRING",WAY);
CAL SAIL
HERE(BREAKSET)
PUSHJ P,SAVE ;SAVE ACS AND THINGS
MOVE LPSA,X33
SUB SP,X22
MOVE X,-2(P) ;TABLE #
MOVSI TEMP,-1 ;GET BLOCK IF NOT THERE, NO NEED TO INIT
PUSHJ P,BKTCHK ;CHECK OUT TABLE #
JRST RESTR ;ERROR RETURN
MOVE B,BRKMSK(CHNL) ;BITS FOR THIS TABLE
IORM B,BKJFFO(CDB) ;MARK THIS TABLE RESERVED & INIT'ED
HLLZS B ;LEFT HALF ONLY
ADD CHNL,CDB ;RELOCATE RANGE 1-18
MOVE C,[ANDCAM B,(D)] ;USUAL CLEARING INSTR
LDB X,[POINT 4,-1(P),35] ;COMMAND
TRZN X,10 ;LEFT OR RIGHT HALF OF TABLE?
SKIPA X,BKCOM(X) ;RIGHT HALF
HLRZ X,BKCOM(X) ;LEFT HALF
JRST (X) ;DISPATCH
BKCOM: XWD XCLUDE,PASLINS ;X,,P
XWD INCL,PENDCH ;I,,A
;;%DQ% ! JFR 8-17-76 to let INPUT handle NULs
XWD ZSET,RETCH ;Z,,R
;;%##% ADD BREAK MODE FOR COERCIONS
XWD UCASE,SKIPCH ;K,,S
XWD BRKLIN,RESTR ;L,,D
XWD ILLSET,ERMAN ;-,,E
;;%BG% ! ADD WAY TO UNDO "K"
XWD NOLINS,LCASE ;N,,F
XWD OMIT,ILLSET ;O,,-
ILLSET: ERR <ILLEGAL COMMAND TO BREAKSET>,1
JRST RESTR
;;%BK% OMISION NOW MUST SET ANOTHER FLAG, TOO
;;XCLUDE: SKIPA C,[IORM B,(D)] ;YES, SET ALL TO 1 TO INITIALIZE
;;OMIT: MOVSS B ;OMIT, PUT BIT IN RH
XCLUDE: MOVE C,[IORM B,(D)] ;EXCLUSION MEANS YOU FIRST SET TO ONE
JRST INCL ;GO DO IT
OMIT: MOVSS B ;OMIT HAS BIT IN RH
HRRZ A,1(SP) ;SET BIT ONLY IF HAVE SOME OMIT CHARS
IORM B,BRKOMT(CDB) ;ASSUME HAVE SOME
CAIN A,0 ;HAVE ANY
ANDCAM B,BRKOMT(CDB) ;NO
;;%BK%
INCL: MOVSI D,-200
HRRI D,BRKTBL(CDB) ;RELOCATABLE IOWD
BRKLUP: XCT C ;CLEAR (OR SET) PROPER (HALF OF PROPER) TABLE
AOBJN D,BRKLUP
MOVE C,[IORM B,BRKTBL(D)] ;USUAL SETTING INSTR
CAIN X,XCLUDE ;BY EXCEPTION?
MOVE C,[ANDCAM B,BRKTBL(D)] ;YES, WANT TO TURN OFF BITS
ADDI C,(CDB) ;RELOCATE IT
HRRZ A,1(SP) ;LENGTH OF STRING
MOVE X,2(SP) ;BYTE POINTER
JRST BRKL2
BRKL1: ILDB D,X ;GET A CHAR
XCT C ;DO RIGHT THING TO RIGHT BIT
BRKL2: SOJGE A,BRKL1
;;%DQ% JFR 8-17-76 IF "I" OR "X" THEN CLEAR "Z"
HLRZ B,B ;B= IF "O" THEN 0 ELSE BIT
ANDCAM B,BRKDUM(CDB) ;CLEAR "Z"
;;%DQ% ^
JRST RESTR
PASLINS: TDZA B,B ;PASS LINE NOS. SINE COMMENT
NOLINS: MOVEI B,-1 ;INFORM IN THAT IT SHOULD
MOVEM B,LINTBL(CHNL) ; DELETE LINE NOS.
JRST RESTR
BRKLIN: SKIPA B,[-1] ;MARK BREAK ON LINE NOS. FOR THIS TBL
ERMAN: MOVSI B,-1 ;LH NEG SIGNALS ERMAN'S SCHEME
MOVEM B,LINTBL(CHNL)
JRST RESTR
PENDCH: SETOM DSPTBL(CHNL) ;APPEND TO END OF INPUT
JRST RESTR
SKIPCH: TDZA B,B ;CHAR NEVER APPEARS IN INPUT STRING
RETCH: MOVEI B,-1 ;RETAIN FOR NEXT TIME
MOVEM B,DSPTBL(CHNL)
JRST RESTR
;;%##%
UCASE: MOVSS B ;INTO RIGHT HLF
IORM B,BRKCVT(CDB)
JRST RESTR
;;%BG% =A1=
LCASE: MOVSS B
ANDCAM B,BRKCVT(CDB)
JRST RESTR
;;%DQ%
ZSET: MOVSS B
IORM B,BRKDUM(CDB)
JRST RESTR
COMMENT Setbreak
TBL IS AS IN BREAKSET
BRKSTRNG IS USED FOR ANY "I" OR "X" APPEARING IN MODESTRNG
OMITSTRNG (IF NOT NULL) IS USED TO SET THE "OMIT" SIDE OF THE TABLE
MODESTRNG CAN CONTAIN ANY OF THE VALID BREAKSET "MODE" CHARACTERS
I,X,O,N,R,A,P, or S.
This function is not attainable by the user unless he declares it.
DSCR SETBREAK(TABLE,"BREAKSTRING","OMITSTRING",MODESTRING");
CAL SAIL
HERE (SETBREAK)
HRRZ TEMP,-3(SP) ;DO OMIT STRING, IF PRESENT
JUMPE TEMP,NO.O ;NULL STRING DOESN'T COUNT
PUSH P,-1(P) ;TABLE #
PUSH SP,-3(SP) ;OMIT CHARACTERS
PUSH SP,-3(SP)
PUSH P,["O"] ;OMIT!
PUSHJ P,BREAKSET ;DO THAT
NO.O: HRRZS -1(SP) ;COUNT OF # OF COMMANDS
BKSLUP: SOSGE -1(SP) ;DONE?
JRST BKSDUN ; YES
PUSH P,-1(P) ;TABLE #
ILDB TEMP,(SP) ;COMMAND
PUSH P,TEMP
PUSH SP,-5(SP)
PUSH SP,-5(SP) ;STRING TO USE IF NECESSARY
PUSHJ P,BREAKSET
JRST BKSLUP ;DO IT -- AGAIN
BKSDUN: SUB P,X22
SUB SP,[XWD 6,6]
JRST @2(P)
ENDCOM(BRK)
COMPIL(SBK,<STDBRK>,<.SKIP.,OPEN,LOOKUP,GOGTAB,BKTCHK,ARRYIN,RELEASE,X22>,<STDBRK>)
IFE ALWAYS,<
TENX<
EXTERNAL $OSTYP
> ;TENEX
> ;IFE ALWAYS
DSCR STDBRK(CHANNEL);
CAL SAIL
HERE(STDBRK)
PUSH P,-1(P) ;CHANNEL
GSYSIN ;[clh] sysind _ 0 for tenex, 2 for 20
PUSH SP,STDBDV(SYSIND) ;[clh]
PUSH SP,STDBDV+1(SYSIND) ;[clh]
PUSH P,[14] ;MODE 14
PUSH P,[2] ;INPUT BUFFERS
PUSH P,[0] ;OUTPUT BUFFERS
PUSH P,[0] ;COUNT
PUSH P,[0] ;BRCHAR
PUSH P,[.SKIP.] ;EOF
SETOM .SKIP. ;[clh] Return if errors
PUSHJ P,OPEN ;OPEN CHANNEL
SKIPE .SKIP. ;ERROR?
ERR <Can't open STDBRK channel>,1,STDEXT
PUSH P,-1(P)
GSYSIN ;[clh]
PUSH SP,STDBFL(SYSIND) ;[clh]
PUSH SP,STDBFL+1(SYSIND) ;[clh]
PUSH P,[.SKIP.]
SETZM .SKIP.
PUSHJ P,LOOKUP
SKIPE .SKIP.
ERR <Can't lookup STDBRK file>,1,STDEXT
PUSH P,-1(P) ;CHANNEL
MOVE USER,GOGTAB
MOVEI X,1 ;ORDINARY USER TABLE #
SKIPE BKTPRV(USER) ;PRIVILEGED?
MOVEI X,0 ;YES
MOVSI TEMP,-1 ;GET BLOCK IF NOT THERE, NO NEED TO INIT
PUSHJ P,BKTCHK ;CHECK OUT SITUATION
JRST STDEXT ;ERROR OF SOME SORE
;;%DQ% !
SETZM BRKDUM(CDB) ;STANDARD TABLES HAVE NO "Z" MODES
PUSH P,CDB ;WHERE TO PUT IT
PUSH P,[BRKDUM] ;HOW MUCH TO READ
PUSHJ P,ARRYIN ;READ IN ARRAY
PUSH P,-1(P) ;CHANNEL
PUSH P,[0] ;CLOSE INHIBIT
PUSHJ P,RELEASE ;RELEASE THE FILE
STDEXT:
SUB P,X22 ;CLEAR STACK
JRST @2(P)
STDBFL:
BKTFIL
STDBDV: BKTDEV ;[clh]
ENDCOM(SBK)
COMPIL(ABK,<GETBREAK,RELBREAK>,<SAVE,RESTR,BKTCHK,BRKMSK,CORREL,X11,X22>
,<BREAK TABLE ALLOCATION>)
DSCR GETBREAK
returns the number of a free break table
CAL SAIL
HERE (GETBREAK)
PUSHJ P,SAVE
SKIPN BKTPRV(USER) ;PRIVILEGED?
JRST GTBK03 ;NO
MOVSI D,-4 ;YES, SEARCH ALL 4 GROPS
HRRI D,BKTPTR(USER) ;START AT FIRST GROUP
SETZ A, ;INITIALIZE RESULT
JRST GTBK04
GTBK03: MOVSI D,-3 ;ORDINARY USER, SEARCH LAST 3
HRRI D,BKTPTR+1(USER)
MOVEI A,=18 ;INITIALIZE RESULT
GTBK04:
SETZ C, ;INITIAL RESULT
;;#TP# ! TYPO--USED TO BE SKIPE JFR 10-26-74
GTBK02: SKIPN CDB,(D) ;POINTER TO GROUP OF 18 TABLES
JRST GTBK18 ;NO POINTER, SO WHOLE BLOCK OF 18 FREE
SETCM B,BKJFFO(CDB) ;GET RESERVATION WORD
JUMPE B,GTBK01 ;JUMP IF ALL 18 ARE RESERVED AND INIT'ED
JFFO B,.+1 ;FIND FIRST UNRESERVED TABLE
CAILE C,=17 ;CHECK ONLY RESERVATIONS, NOT INIT'S
JRST GTBK01 ;ALL 18 RESERVED
ADD A,C ;FOUND ONE
ADDI C,1
;;#TP# ! USED TO BE MOVE JFR 10-26-74
GTBKRT: HLLZ B,BRKMSK(C) ;RESERVE THIS TABLE
IORM B,BKJFFO(CDB)
;;#TP# IMPROVE REENTERABILITY
MOVSS B ;BIT INTO RIGHT HALF
ANDCAM B,BKJFFO(CDB) ;NOT INIT'ED
ANDCAM B,BRKCVT(CDB)
ANDCAM B,BRKOMT(CDB)
;;%DQ% !
ANDCAM B,BRKDUM(CDB)
ADDI C,(CDB) ;RELOCATE 1 TO 18
SETZM LINTBL(C)
SETZM DSPTBL(C)
;;#UO# =E7= JFR 7-28-75 explicitly zero the bits for each character
MOVEI CDB,BRKTBL(CDB) ;FWA OF CHAR TAB
HRLI CDB,-200 ;AOBJN COUNT
HRLI B,(B) ;BIT IN EACH HALF
ANDCAM B,(CDB) ;ZAP!
AOBJN CDB,.-1
;;#UO# ^
GTBKF2: SUBI A,=17 ;ADJUST FOR INITIAL OFFSET
MOVEM A,RACS+A(USER) ;RESULT
MOVE LPSA,X11
JRST RESTR ;DONE
GTBK01: ADDI A,=18
AOBJN D,GTBK02 ;TRY NEXT GROUP OF 18
GTBKF: MOVNI A,1 ;FAILURE
JRST GTBKF2
;;#TP# REVISED TO USE BKTCHK JFR 10-26-74
;;#%%# BUG FIX JFR 11-13-74
GTBK18: MOVE X,A ;TABLE NUMBER
SUBI X,=17 ;CORRECT
MOVSI TEMP,-1 ;CALL CORGET, NO INIT CHECK
PUSHJ P,BKTCHK
JRST GTBKF ;ERROR RETURN
MOVE C,CHNL
JRST GTBKRT
DSCR RELBREAK
release a break table
CAL SAIL
HERE (RELBREAK)
PUSHJ P,SAVE
RLBK01: MOVE X,-1(P) ;TABLE #
ADDI X,=17 ;NEG TAB NUMS FOR PRIV USERS CAUSE PROBS
SKIPN BKTPRV(USER) ;PRIVILEGED?
CAIL X,=18 ;LOWEST FOR ORDINARY USER
CAILE X,=71 ;MAX FOR EVERYBODY
JRST RLBKRT ;RELEASE ALWAYS WORKS
IDIVI X,=18
MOVEI A,1(Y) ;A NOW IN RANGE 1 TO 18
ADD X,USER ;RELOCATE GROUP NUMBER
SKIPN B,BKTPTR(X) ;B GETS POINTER TO CORRECT GROUP OF TABLES
JRST RLBKRT ;NON-FATAL ERROR
MOVE TEMP,BRKMSK(A) ;BITS FOR THE TABLE
ANDCAB TEMP,BKJFFO(B) ;UNRESERVE
JUMPN TEMP,RLBKRT ;IF STILL SOME RESERVED
SETZM BKTPTR(X) ;THIS GROUP DEFUNCT
PUSHJ P,CORREL ;RELEASE BLOCK POINTED TO BY B
RLBKRT: MOVE LPSA,X22
JRST RESTR
ENDCOM(ABK)
COMPIL(PRN,<$PRINT,$$PRIN,SETPRINT,GETPRINT,$PINT,$PREL,$PITM,$PSET,$PLST,$PREC,$PSTR,$PLRL>
,<GOGTAB,X22,OUT,OUTSTR,INCHWL,OPEN,GETCHAN,ENTER,.SKIP.,RELEASE,CAT,GETFOR,SETFOR,CATCHR,CVIS,X33,CVS,CVG,CVEL>
,<STRING PRINTING ROUTINE>)
COMMENT $print
NOTTTY __ 400000 ; WANT PRINT OUTPUT TO THE TELETYPE
WNTFLE __ 200000 ; WANT PRINT OUTPUT TO A FILE
HAVFLE __ 100000 ; HAVE A FILE FOR OUTPUT
WNTTTY __ 000000 ; DONT WANT ANY OUTPUT AT ALL
;;%BF% GENERAL STRING OUTPUT ROUTINE
BEGIN STRPRN
;; CONTROL BITS:
UROUTB __ 400000 ; IF ON THEN JRST (CTRL)
RTNSTR __ 200000 ; IF ON THEN RETURN(S) ELSE RETURN (NULL)
TTYYES __ 100000 ; IF ON THEN ALWAYS DO OUTSTR
TTYNOT __ 040000 ; IF ON THEN DONT OUTSTR UNLESS TTYYES ON
CHNSPC __ 020000 ; IF ON THEN RH(CTRL) IS CHANNEL (OR JFN)
CHNNOT __ 010000 ; IF ON THEN DO NOT PUT OUT ANYTHING ON DEFAULT
; CNANNEL
;ALSO THERE IS A WORD PRNINF(USER) THAT CONTAINS SOME "DEFAULTS"
DSCR STRING PROC $PRINT("S",CTRL(0))
DES ROUTINE (ROUGHLY) IS:
BEGIN
I_PRNINF(USER);
IF UROUTB LAND CTRL THEN JRST @RH(CTRL);
IF UROUTB LAND I THEN JRST @RH(I);
$$PRIN: COMMENT THE ENTRY POINT AFTER TRAPPING OUT TO THE USER;
IF (TTYYES LAND CTRL) THEN
OUTSTR(S)
ELSE IF NOT (TTYNOT LAND CTRL) THEN
BEGIN
IF NOT ( (TTYYES!TTYNOT) LAND I) THEN
<SET TTY DEFAULTS>;
IF TTYYES LAND I THEN OUTSTR(S);
END;
IF CHNSPC LAND CTRL THEN OUTF(RH(CTRL),S);
IF NOT (CHNNOT LAND CTRL) THEN
BEGIN
IF NOT ( (CHNNOT!CHNSPC) LAND I) THEN
<SET OUTPUT CHANNEL DEFAULTS>;
IF CHNSPC LAND I THEN OUTF(RH(I),S);
END;
IF RTNSTR LAND CTRL THEN RETURN(S) ELSE RETURN(NULL);
END;
;; $PRINT ACTUAL CODE
HERE($$PRIN)
TDZA A,A
HERE($PRINT)
MOVEI A,1
MOVE C,-1(P) ;CONTROL BITS
MOVE USER,GOGTAB ;
MOVE B,PRNINF(USER) ;"DEFAULT" BITS
JUMPE A,SPRN.1 ;CAME FROM STRPR1?
TLNE C,UROUTB ;USER ROUTINE?
JRST (C) ;YES
TLNE B,UROUTB ;USER SPEC ONE HERE?
JRST (B) ;YES
SPRN.1: ;STRPR1 COMES IN HERE
TLNE C,TTYYES ;DID HE DEMAND OUTSTR?
JRST .OSTRC ;YES
TLNE C,TTYNOT ;DID HE DEMAND NOT?
JRST SPRN.3 ;YES
TLNN B,TTYNOT!TTYYES ;IS A DEFAULT ESTABLISHED?
PUSHJ P,PDFSET ;NO, DO SO
SPRN.2: TLNN B,TTYYES ;DOES HE WANT IT?
JRST SPRN.3 ;NO
.OSTRC: PUSH SP,-1(SP) ;
PUSH SP,-1(SP) ;
PUSHJ P,OUTSTR ;OUTSTR(S);
SPRN.3: TLNE C,CHNSPC ;SPECIFIED CHANNEL?
JSP D,OUTFN ;OUT(SPEC CHAN,S);
JUMP (C) ;EFFECTIVE ADDRESS IS CHANNEL NO
SPRN.4: TLNE C,CHNNOT ;DID HE SAY THAT IS ALL?
JRST SPRN.5 ;YES
TLNN B,CHNNOT!CHNSPC ;DEFAULTS SET YET?
PUSHJ P,PDFSET ;NOPE DO IT NOW
TLNE B,CHNSPC ;CHANNEL SPECIFIED NOW?
JSP D,OUTFN ;OUTPUT FUNCTION
JUMP (B) ;PASS CHANNEL NUMBER THIS WAY
SPRN.5: TLNN C,RTNSTR ;DID WE WANT S KEPT?
SETZM -1(SP) ;RETURN A NULL INSTEAD OF S
SUB P,X22 ;RETURN
JRST @2(P) ;
OUTFN: MOVEI A,@(D) ;GET CHANNEL NUMBER
PUSH P,A ;PUSH IT
PUSH SP,-1(SP) ;
PUSH SP,-1(SP) ;COPY IS LIKELY FOOLISH
PUSHJ P,OUT ;
JRST 1(D) ;RETURN --RELY ON OUT TO SAVE ACS
PDFSET: PUUO 3,[ASCIZ/
$PRINT called without initialization.
Output to teletype?/]
MOVSI B,TTYYES!CHNNOT ;INITIALLY, ASSUME TTYON
PUSHJ P,$YN
MOVSI B,TTYNOT!CHNNOT ;NO WE DONT
PUUO 3,[ASCIZ/Output to file?/];
PUSHJ P,$YN ;ASK ABOUT IT
JRST OPTSET ;NO
TLC B,CHNNOT!CHNSPC ;YES, WE WILL
DOOP: PUSHJ P,GETCHAN ;CHANNEL NUMBER
HRR B,A ;REMEMBER HERE,TOO
PUSH P,A ;CHANNEL NO
PUSH SP,[3] ;DSK
PUSH SP,[ POINT 7,[ASCIZ/DSK/]]
PUSH P,[0] ;MODE 0
PUSH P,[0] ;NO INPUT
PUSH P,[3] ;3 OUTPUT BUFFERS
PUSH P,[0]
PUSH P,[0]
PUSH P,[.SKIP.] ;EOF VAR
SETZM .SKIP.
OPIT: PUSHJ P,OPEN ;OPEN THE CHANNEL
SKIPE .SKIP.
ERR <OPEN LOST>,1,DOOP
ENIT: PUUO 3,[ASCIZ /File Id=/]
PUSH P,A
PUSHJ P,INCHWL
PUSH P,[.SKIP.]
PUSHJ P,ENTER
SKIPE .SKIP.
JRST ENIT
OPTSET: MOVEM B,PRNINF(USER)
POPJ P,
$YN: PUSHJ P,INCHWL
HRRZ FF,-1(SP);
JUMPE FF,YNRET;
ILDB FF,(SP)
CAIE FF,"Y"
CAIN FF,"y"
AOS (P) ;SKIP RET IF YES
YNRET: SUB SP,X22
POPJ P,
INTERNAL P.FIN
HERE(P.FIN)
BEGIN P.FIN
MOVE USER,GOGTAB
SKIPE B,PRNINF(USER) ;FIRST CLOSE $PRINT FILE
TLNE B,UROUTB
JRST CONTIN
TLNN B,CHNSPC
JRST CONTIN
HRRZS B
PUSH P,B
PUSH P,[0]
PUSHJ P,RELEASE
CONTIN: SKIPE B,PRTINF(USER) ;NOW CLOSE PRINT FILE (WOW!)
TLNN B,HAVFLE
POPJ P,
HRRZS B
PUSH P,B
PUSH P,[0]
PUSHJ P,RELEASE
POPJ P,
BEND P.FIN
BEND STRPRN
DSCR PRINT routines
The SETPRINT and GETPRINT change the output conditions for
the PRINT statement (not CPRINT).
There are three things that may be happening: the user
may or may not have a file open, if so it may or may not be
selected for output; and the user may want output to go to the
terminal. This makes 6 possibilites. Each is represented by
a letter that suggests the meaning.
Bits indicating what is happening are stored in the
left half of user table entry PRTINF; the right half contains
the channel number. Bits indicate if the teletype is NOT selected,
if a file is open, and if the file is selected. These are, symbolically,
WNTTTY, HAVFLE, and WNTFLE. Note that 0 for the entire word means
to just use the teletype for output. This is because the user
table gets zeroed at the start, and so it is given the meaning
of the letter "T".
HEREFK(SETPRINT,SETPR.)
BEGIN SETPRINT
DEFINE TST(X,Y) <
CAIN D,"X"
MOVSI B,Y
>;
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
MOVE D,-1(P) ;GET ARGUMENT
CAIL D,"a"
CAILE D,"z"
SKIPA
SUBI D,40 ;CONVERT TO UPPER CASE
SETO B,
CAIN D,"C" ;CONSOLE?
JRST [MOVE B,PRTINF(USER)
TLZ B,NOTTTY ;TURN ON TELETYPE
JRST SETRET]
CAIN D,"I" ;IGNORE TERMINAL
JRST [MOVE B,PRTINF(USER)
TLO B,NOTTTY
JRST SETRET]
TST T,WNTTTY
TST F,NOTTTY+WNTFLE+HAVFLE
TST B,WNTTTY+WNTFLE+HAVFLE
TST N,NOTTTY
TST S,NOTTTY+HAVFLE
TST O,WNTTTY+HAVFLE
CAME B,[-1] ;NOT LEGAL OPTION
JRST OKSET
PUUO 1,D ;PRINT A CHAR
ERR <
SETPRINT: Above mode is not legal>,1
MOVSI B,WNTTTY ;FOR DEFAULT ASSUME TTY
JRST SETRET
OKSET:
MOVE D,PRTINF(USER) ;GET OLD VALUE
TLNE D,HAVFLE ;IF HAVE A FILE
TLNE B,HAVFLE ;BUT DONT WANT IT
JRST OKREL
HRRZS D
PUSH P,D
PUSH P,[0] ;CLOSE INHIBIT BITS
PUSHJ P,RELEASE ;RELEASE FILE
JRST SETRET ;AND RETURN
OKREL:
TLNE D,HAVFLE ;IF WE HAVE A FILE
TLNN B,HAVFLE ;AND WANT A FILE
JRST CHKNEED
HRR B,D ;THEN USE IT
JRST SETRET
CHKNEED:
TLNN B,HAVFLE ;WANT A FILE?
JRST SETRET
NOTENX<
HRRZ A,-1(SP)
JUMPG A,.+2 ;HAVE A FILE NAME?
PUSHJ P,GETNAME ;NEED A NAME
GETDSK:
PUSHJ P,GETCHAN ;GET A CHANNEL
CAMN A,[-1]
ERR <SETPRINT: GETCHAN failed>
HRR B,A ;PUT CHANNEL NUMBER IN RH(B)
PUSH P,A ;CHANNEL ARG
PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/DSK/],-1]
PUSH P,[0] ;MODE 0
PUSH P,[0] ;INPUT BUFFERS
PUSH P,[3] ;OUTPUT BUFFERS
PUSH P,[0] ;COUNT WORD
PUSH P,[0] ;BRCHAR
SETZM .SKIP.
PUSH P,[.SKIP.] ;END OF FILE
PUSHJ P,OPEN ;CALL FUNCTION
SKIPE .SKIP. ;A PROBLEM
ERR <SETPRINT: OPEN to the DSK has failed>,1,GETDSK
DOENT: PUSH P,A ;CHANNEL
PUSH SP,-1(SP)
PUSH SP,-1(SP) ;FILE NAME
PUSH P,[.SKIP.]
PUSHJ P,ENTER
SKIPE .SKIP.
JRST [PUUO 3,[ASCIZ/SETPRINT: ENTER failed, type file name
/]
PUSHJ P,GETNAME
JRST DOENT]
JRST SETRET
GETNAME:
PUUO 3,[ASCIZ/
File for PRINT output */]
PUSHJ P,INCHWL
POP SP,-2(SP)
POP SP,-2(SP)
POPJ P,
>;NOTENX
TENX<
EXTERNAL OPENFILE
GETDSK:
PUSH P,B
HRRZ A,-1(SP) ;COUNT OF FILENAME
JUMPG A,.+2 ;CHECK LENGTH
PUUO 3,[ASCIZ/
File for PRINT output */]
PUSH SP,-1(SP)
PUSH SP,-1(SP) ;FILE NAME
PUSH SP,[2]
PUSH SP,[POINT 7,[ASCIZ/WC/],-1]
PUSHJ P,OPENFILE
POP P,B
HRR B,A ;CHANNEL NUMBER
JRST SETRET
>;TENX
SETRET:
MOVEM B,PRTINF(USER)
SUB SP,X22
SUB P,X22
JRST @2(P) ;RETURN
BEND SETPRINT
HEREFK(GETPRINT,GETPR.)
BEGIN GETPRINT
DEFINE TST(X,Y) <
CAIN TEMP,X
MOVEI A,"Y"
>;
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
HLRZ TEMP,PRTINF(USER)
SETO A,
TST WNTTTY,T
TST NOTTTY+WNTFLE+HAVFLE,F
TST WNTFLE+WNTTTY+HAVFLE,B
TST NOTTTY,N
TST NOTTTY+HAVFLE,S
TST HAVFLE+WNTTTY,O
CAMN A,[-1]
ERR <GETPRINT: Illegal mode>,1
POPJ P,
BEND GETPRINT
DSCR $PRSTR -- final string printer
PROCEDURE $PRSTR(STRING S)
Called for either PRINT or CPRINT. Actually does the final output.
CAL PUSHJ (EFFECTIVELY -- ACTUALLY JRST)
ARG STRING ON SP STACK
CHANNEL ON P STACK, -1 FOR TELETYPE
RET THE STRING IS CLEARED FROM THE SP STACK, AND POPJ RETURN
SID NOTHING IS SAFE IF USER ROUTINE CALLED
$PRSTR:
BEGIN $PRSTR
MOVE USER,GOGTAB
SKIPE TEMP,$$PROU(USER)
JRST WNTOWN ;OWN OUTPUTTING FN.
PRINT1: MOVE TEMP,-1(P) ;GET CHANNEL NUMBER
CAME TEMP,[-1] ;IS IT -1?
JRST WNTCHN ;NO, MUST BE A CHANNEL
SKIPN B,PRTINF(USER) ;SEE IF SETPRINT DONE
JRST OUTSTR ;JUST DEFAULT SETPRINT, THAT'S ALL
TLNE B,NOTTTY ;TELETYPE WANTED?
JRST NOTTY ;NO
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSHJ P,OUTSTR
NOTTY: TLNN B,WNTFLE ;FILE WANTED?
JRST [SUB SP,X22
POPJ P,]
HRRZS B
PUSH P,B
JRST WNTCH1
WNTCHN: PUSH P,TEMP ;THE CHANNEL NUMBER
WNTCH1: PUSHJ P,OUT ;STRING ON STACK
POPJ P, ;AND RETURN
WNTOWN: PUSH P,-1(P) ;PUSH CHANNEL NO.
PUSHJ P,(TEMP) ;CALL USER FUNCTION
POPJ P,
BEND $PRSTR
DSCR
These funtions are the top-level functions called from SAIL
for the PRINT and CPRINT statement, for argument types that
are passed on the P stack. The other case, of course, is
a string value, which follows directly.
The calls for the PRINT or CPRINT statement are generated
by first pushing the channel number onto the P stack (-1 for Teletype),
then calling a special routine for each basic syntactic type
encountered. After all calls for the syntactic types, the
channel is removed from the P stack, by a SUB P,[xwd 1,1] instruction
following the calls to the PRINT routines.
CAL PRINT or CPRINT statements
ARG standard SAIL argument passing
CHANNEL is on the P stack, -1 if Teletype
ARG is on the P stack
SID nothing saved
RES nothing
DEFINE PMAK ! (X,X1,Y,Z) <
HEREFK(X,X1)
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
PUSH P,-1(P) ;PUSH THE ARGUMENT
SKIPE TEMP,Z(USER) ;USER FORMATTING FUNCTION
JRST PRTOWN
PUSHJ P,Y ;NO, CALL STANDARD FORMATTING
JRST PRRET
>;PMAK
;FUNCTION
;CODE COMMON TO ALL PRINTING FUNCTIONS
PRTOWN: PUSHJ P,(TEMP)
PRRET: POP P,-1(P) ;SPLICE ARG OUT FROM STACK
JRST $PRSTR ;AND RETURN
PMAK $PINT,$PINT.,CVS,$$FINT
PMAK $PREL,$PREL.,CVG,$$FREL
PMAK $PITM,$PITM.,PN,$$FITM
PMAK $PSET,$PSET.,PSET1,$$FSET
PMAK $PLST,$PLST.,PLST1,$$FLST
PMAK $PREC,$PREC.,PREC,$$FREC
HEREFK($PLRL,$PLRL.)
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
PUSH P,-2(P) ;PUSH THE ARGUMENT
PUSH P,-2(P)
SKIPN TEMP,$$FLRL(USER) ;USER FORMATTING FUNCTION
MOVEI TEMP,CVEL ;NONE, USE STANDARD
PUSHJ P,(TEMP)
POP P,-1(P) ;SPLICE OUT ARG
POP P,-1(P)
JRST $PSTR
HEREFK($PSTR,$PSTR.)
MOVE USER,GOGTAB
MOVE TEMP,(P)
MOVEM TEMP,UUO1(USER)
SKIPE TEMP,$$FSTR(USER) ;SPECIAL STRING FORMATTER?
PUSHJ P,(TEMP) ;YES
JRST $PRSTR ;PRINT AND RETURN
DSCR Utility routines for PRINT statement.
DSCR PN
STRING PROCEDURE PN(ITEM X)
returns the PNAME of X if one exists, else ITEM!XXX, where XXX is the item number.
Special provision is made for the special items of the SAIL runtime system.
PN:
BEGIN PN
PUSH P,[0] ;USE STACK FOR VARIABLE
MOVEI A,(P)
PUSH P,-2(P) ;ARGUMENT X NOW
PUSH P,A ;ADDRESS OF FLAG
PUSHJ P,CVIS ;GET STRING ON STRING STACK
SKIPN (P) ;FLAG OK?
JRST RET ;YES OK
SUB SP,X22 ;CLEAR OFF STACK
MOVE A,-2(P) ;GET ITEM NUMBER
CAILE A,3 ;BIGGER THAN BUILTIN RANGE?
JRST USENUM ;YES, USE THE NUMBER
PUSH SP,[36612](A)
PUSH SP,[440700,,STRN
170700,,STRN
100700,,STRN+1
440700,,STRN+3](A)
JRST RET
USENUM: PUSH SP,[5]
PUSH SP,[POINT 7,[ASCII/ITEM!/],-1]
PUSH P,-2(P) ;ARGUMENT AGAIN
PUSH P,[-4] ;FOR ACVS
PUSHJ P,ACVS ;GO OFF AND DO IT
PUSHJ P,CAT ;CONCATENATE
RET: SUB P,X33 ;CLEAR OFF EVERYTHING
JRST @2(P) ;AND RETURN
STRN: ASCII/ANYMAINPIBINDITEVENT!TYPE/
BEND PN
DSCR ACVS
STRING PROCEDURE ACVS(INTEGER I,F)
Returns the CVS representation of I by first setting the format
control to F. Used to ensure that there are no leading spaces etc.
ACVS:
PUSH P,[0]
PUSH P,[0]
MOVEI A,-1(P)
PUSH P,A
MOVEI A,-1(P)
PUSH P,A
PUSHJ P,GETFORMAT ;GET FORMAT INTO STACK LOCATIONS
PUSH P,-3(P) ;F ARGUMENT
PUSH P,[0] ;DOESNT MATTER
PUSHJ P,SETFORMAT
PUSH P,-4(P) ;I ARGUMENT
PUSHJ P,CVS ;GET STRING ONTO STRING STACK
PUSHJ P,SETFORMAT
SUB P,X33 ;CLEAR OFF STACK
JRST @3(P) ;AND RETURN
DSCR GODOWN
STRING PROCEDURE GODOWN(LIST or SET S)
CDR's down S creating a string of the PN's of the items in S.
Does not copy structure etc. Returns the string representing
this list, sans braces, which are added in the calling function.
GODOWN: BEGIN GODOWN
PUSH SP,[0]
PUSH SP,[0] ;PREPARE FOR STRING
MOVE 1,-1(P)
HRRZ 1,(1)
LOOP: JUMPE 1,DONE
HLRZ 2,(1) ;J _ CAR(I)
HRRZ 1,(1) ;I _ CDR(I)
PUSH P,1 ;SAVE
PUSH P,2 ;SAVE
PUSH P,2 ;ARGUMENT
PUSHJ P,PN ;GET STRING
PUSHJ P,CAT ;HOOK ON STRING
POP P,2 ;RESTORE
POP P,1
JUMPE 1,DONE
PUSH SP,[2]
PUSH SP,[POINT 7,[ASCIZ/, /],-1]
PUSHJ P,CAT
JRST LOOP
DONE: SUB P,X22
JRST @2(P) ;RETURN
BEND GODOWN
DSCR PSET1 -- default formatter for sets
PSET1: BEGIN PSET1
SKIPN -1(P) ;EMPTY?
JRST RETPHI ;YES
PUSH SP,[1]
PUSH SP,[POINT 7,[BYTE (7) 173,173],-1]
PUSH P,-1(P)
PUSHJ P,GODOWN
PUSHJ P,CAT
PUSH SP,[1]
STANFO <
PUSH SP,[POINT 7,[BYTE (7) 176,176],-1]
>
NOSTANFO <
PUSH SP,[POINT 7,[BYTE (7) 175,175,0,0,0],-1]
>
PUSHJ P,CAT
RET: SUB P,X22
JRST @2(P)
RETPHI: PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/PHI/],-1]
JRST RET
BEND PSET1
DSCR PLST1 -- default formatter for lists
PLST1: BEGIN PLST1
SKIPN -1(P) ;ANYTHING THERE?
JRST RETNIL ;NO
PUSH SP,[2]
PUSH SP,[POINT 7,[BYTE (7) 173,173],-1]
PUSH P,-1(P)
PUSHJ P,GODOWN
PUSHJ P,CAT
PUSH SP,[2]
STANFO <
PUSH SP,[POINT 7,[BYTE (7) 176,176],-1] ;STANFORD CROCK "ASCII"
>
NOSTANFO <
PUSH SP,[POINT 7,[BYTE (7) 175,175,0,0,0],-1]
>
PUSHJ P,CAT
RET: SUB P,X22
JRST @2(P)
RETNIL: PUSH SP,[3]
PUSH SP,[POINT 7,[ASCIZ/NIL/],-1]
JRST RET
BEND PLST1
DSCR PREC -- default printer for record pointers
PREC: BEGIN PREC
MOVE 3,-1(P) ;RECORD
JUMPE 3,NULLREC ;SPECIAL FOR NULL!RECORD
MOVE 3,(3) ;POINTER TO CLASS
MOVE 3,5(3) ;POINTER TO WD2 OF STRING
;DESCR FOR CLASS NAME
PUSH SP,-1(3)
PUSH SP,(3) ;STRING TO STACK
PUSH P,["."]
PUSHJ P,CATCHR
PUSH P,-1(P)
PUSH P,[0]
PUSHJ P,ACVS
PUSHJ P,CAT
RECRET: SUB P,X22
JRST @2(P)
NULLREC:
PUSH SP,[=11]
PUSH SP,[POINT 7,[ASCIZ/NULL!RECORD/],-1]
JRST RECRET
BEND PREC
ENDCOM(PRN)
IFE ALWAYS,<
COMPIL(DM5,<P.FIN>,,<DUMMY $PRINT FINISHER>)
^^P.FIN:
POPJ P,
ENDCOM(DM5)
>;IFE ALWAYS
COMPIL(DVF,<CVEL>,<GOGTAB,STRNGC,SAVE,RESTR>,<LONG REAL TO STRING CONVERSION>)
;#ZF# ^ ^
;TITLE DOUBT. V.030.0.140 DOUBLE PRECISION OUTPUT PDP-10
;SUBTTL 28-APR-71 /DMN
;FROM V.027U 9-NOV-70 /DMN
;FROM V.022- 1-DEC-69 /TWE
;FROM V.020-APRIL 23,1969 /TWE
;V.005 10-MAR-67
; DOUBT. OUTPUTS ONE DOUBLE PRECISION WORD. IT IS
; CALLED BY
; PUSH 17,FMTWRD
; MOVE 0,A
; MOVE 1,A+1
; PUSHJ P,DOUBT.
; WHERE A IS THE ADDRESS OF THE DOUBLE PRECISION WORD
; AND FMTWRD IS A FORMAT WORD AS DESCRIBED IN FLOUT.
BEGIN CVEL
AC__0 ;AC+1 IS ALSO USED
MUL__AC+1 ;MUL+1 IS ALSO USED
BITS__3
IN__5
XP__4
D$__5
W__1
FR__10 ;FR+1 IS ALSO USED
IGN__6 ;*****
S__13
DIG__14
R__7 ;*****
Q__7 ;*****
NAC__15
MAXDIG__=18 ; *EJG* 06/26/76
MINDIG__=9 ;NO. OF DIGITS IF LS. WORD NOT SIGNIFICANT
BITNEG__40000
BITZ__100000
LZEROB__200000
ABLANK__40
APLUS__53
AMINUS__55
APOINT__56
AZERO__60
AD__104
AO__117
HEREFK(CVEL,CVEL.)
DMOVE AC,-2(P) ;FETCH THE ARGUMENT
MOVE USER,GOGTAB
PUSHJ P,SAVE ;#ZF#
PUSHJ P,DOUBT. ;CONSTRUCT STRING
MOVE LPSA,[3,,3] ;RET. WD AND LONG REAL #ZF#
JRST RESTR ;#ZF#
DOUBT.:
MOVE BITS,-1(P) ;GET FORMAT WORD
TLZ BITS,BITNEG+BITZ+LZEROB ;SET INDICATORS OFF
JUMPE AC,ZERO ;THE TRIVIAL CASE
JUMPG AC,POS ;IS NUMBER NEGATIVE?
DFN AC,AC+1 ;YES, MAKE IT POSITIVE
TLO BITS,BITNEG ;REMEMBER THE MINUS
POS: JUMPN AC+1,POS1 ;IF LS. WORD _ 0
LDB S,[POINT 9,AC,8] ;AND EXPONENT OF MS. WORD GT. 33
CAIG S,33
TLO BITS,LZEROB ;SET LZEROB
POS1: MOVEI IN,13 ;TOP OF COMPARE TABLE
MOVEI XP,0 ;INITIAL DECIMAL EXPONENT
CAML AC,TAB.P2 ;IS NUMBER >_ 1.0?
JRST LUPP ;YES, BRING IT DOWN
CAMN AC,TAB.M1 ;...
CAML AC+1,TAB.M2 ;...
CAMGE AC,TAB.M1 ;...
JRST LUPM ;YES, BRING IT UP
REND: LDB S,[POINT 9,AC,8];GET BINARY EXP
TLZ AC,777000 ;CLEAR EXP OUT OF FRACTION
ASHC AC,8-200(S) ;MOVE FRACTION TO BINAL POINT
MOVE FR,AC ;PLACE IN FRACTION REGISTER
MOVE FR+1,AC+1 ;...
ZEROH:
MOVM D$,DIGS(USER) ;DIGITS OF SIGNIFICANCE
MOVM W,WDTH(USER) ;WIDTH OF FIELD
SETZ S, ;SCALING
JUMPN W,DIGITS ;IS THIS UNSPECIFIED FORMAT?
MOVEI D$,MAXDIG ;YES, SET TO D$<MAXDIG>+8.<MAXDIG>
MOVEI W,MAXDIG+=8 ;...
DIGITS:
MOVEI 1,(W)
ADDM 1,REMCHR(USER)
SKIPLE REMCHR(USER)
PUSHJ P,STRNGC
PUSH SP,[-1,,0] ;INITIAL STRING
PUSH SP,TOPBYTE(USER)
JUMPLE S,.+2 ;+ SCALE IMPLIES D$+1 DIGITS SIGNIFICANCE
ADDI D$,1
MOVM DIG,S ;DIGITS OF SCALING
CAILE D$,MAXDIG ;MAXIMUM SIGNIFICANCE EXCEEDED?
MOVEI D$,MAXDIG ;NO IT ISN'T.
TLZN BITS,LZEROB ;IF LZEROB SET
JRST .+3
CAILE D$,MINDIG ;CHECK NO MORE THAN
MOVEI D$,MINDIG ;ONE WORD OF DIGITS
MOVE R,D$ ;SET ROUNDING POINT
CAMGE DIG,D$ ;MAXF (S,D$)
MOVE DIG,D$ ;...
HRREI IGN,-7(W) ;W-7-DIGITS #ZF# CHANGE 6 TO 7
SUBB IGN,DIG ;...
JUMPG S,SCAL ;IF PLUS SCALE, THEN LEFT ROUTINE
SCAR: JUMPLE IGN,RNBLK ;JUMP IF NO LEADING BLANKS
TLO BITS,LZEROB ;SPACE FOR LEADING ZERO
SOJE DIG,RNBLK ;JUMP IF LEADING ZERO WAS ONLY SPACE
MOVEI AC,ABLANK ;ASCII BLANK
PUSHJ P,OUTCH ;OUTPUT IT
SOJG DIG,.-2 ;JUMP IF MORE BLANKS
RNBLK: ADD R,S ;ONLY ROUND ON SIGNIFICANT DIGITS
PUSHJ P,SGNRND ;OUTPUT SIGN AND ROUND
MOVEI AC,AZERO ;LEADING ZERO
TLNE BITS,LZEROB ;WAS THERE SPACE FOR IT?
PUSHJ P,OUTCH ;YES, OUTPUT
MOVEI AC,APOINT ;MAY THERE ALWAYS BE A DECIMAL POINT
PUSHJ P,OUTCH ;...
ADD D$,S ;SCALE FACTOR IMPLIES EXTRA ZEROS
JUMPGE S,OGDIG ;NOT FOR THIS NUMBER
MOVEI AC,AZERO ;ASCII 0
PUSHJ P,OUTCH ;OUTPUT
AOJL S,.-2 ;ANY MORE ZEROS?
JRST OGDIG ;NO.
SGNRND: MOVEI AC,ABLANK ;ASCII BLANK
TLNE BITS,BITNEG ;WAS NUMBER -?
MOVEI AC,100000+AMINUS ;ASCII MINUS
PUSHJ P,OUTCH ;OUTPUT SIGN
JUMPL R,NORND ;NOT ENUF TO ROUND
CAILE R,MAXDIG ;PERHAPS NO ROUND REQUIRED
JRST NORND ;ALL DIGITS OUTPUT
;V.005 TO V.020 ON NEXT INSTRUCTION
TLO FR+1,400000 ;SET SIGN BIT TO AVOID OVERFLOW
;ON NEXT ADD. RNDL ENTRIES ARE ALWAYS .GE.0
ADD FR+1,RNDL(R) ;LO ORDER ROUND
;V.005 TO V.020 ON NEXT 2 INSTRCTNS.
TLO FR,(1B0) ;TAKE CARE OF OVERFLOW TO HIGH WORD
TLZN FR+1,400000 ;CLEAR BIT. WAS THERE CRY1?
ADDI FR,1 ;YES. PROPOGATE CARRY
RND1: ADD FR,RNDH(R) ;HI ORDER ROUND
TLC FR,(1B0) ;BACK AS IT WAS UNLESS OVERFLOW
JUMPGE FR,NORND ;DID ROUND OVERFLO?
MOVE FR,[31463146314];YES,SET TO 0.1
MOVE FR+1,[314631463147]
AOJA XP,NORND ;INDICATE TO EXP
SCAL: JUMPLE IGN,LNBLK ;IS THERE SPACE FOR BLANKS?
MOVEI AC,ABLANK ;YES, OUTPUT SOME
PUSHJ P,OUTCH ;...
SOJG DIG,.-2 ;OUTPUT SOME MORE
LNBLK: SUB D$,S ;SCALE DIGITS OF SIGNIF.
HRREI DIG,-MAXDIG(S) ;S-MAXIMUM SIGNIF
JUMPLE DIG,.+2 ;IS S>MAXDIG?
MOVEI S,MAXDIG ;PROHIBIT PRINTOUT OF GIGO
ADD R,S ;ROUND AFTER SCALING DIGITS
PUSHJ P,SGNRND ;OUTPUT SIGN AND ROUND
PUSHJ P,OUTDIG ;DIGITS BEFORE DECIMAL POINT
SOJG S,.-1 ;OUTPUT MOST OF SCALE DIGITS
JUMPLE DIG,DECPNT ;MORE SCALE DIGITS?
MOVEI AC,AO ;MAKE SURE THEY'RE INSIGNIFICANT
PUSHJ P,OUTCH ;...
SOJG DIG,.-2 ;UNTIL SCALE FULFILLED
DECPNT: MOVEI AC,APOINT ;DECIMAL POINT
PUSHJ P,OUTCH ;...
OGDIG: TLNE BITS,BITZ ;IS THE NUMBER 0?
JRST ZEROP ;YES, PRINT 0
JUMPLE D$,EXPP ;ANY DIGITS REMAINING?
PUSHJ P,OUTDIG ;OUTPUT NEXT DIGIT
SOJG D$,.-1 ;LOOP IF MORE DIGITS
EXPP: ;EXPONENT PRINT
MOVEI AC,"@"
PUSHJ P,OUTCH
MOVEI AC,"@"
PUSHJ P,OUTCH
MOVEI AC,APLUS ;ASCII +
JUMPGE XP,XTEN ;IS EXP +?
MOVEI AC,AMINUS ;NO, ASCII -
MOVNS XP ;MAKE EXP +
XTEN: PUSHJ P,OUTCH ;OUTPUT SIGN OF EXP
IDIVI XP,=100 ;EXP MODULO 100.
MOVE XP,XP+1 ;...
IDIVI XP,=10 ;SPLIT INTO TWO DIGITS
MOVEI AC,60(XP) ;OUTPUT TENS DIGIT
PUSHJ P,OUTCH ;TENS POSITION
MOVEI AC,60(XP+1) ;OUTPUT UNITS DIGIT
PUSHJ P,OUTCH ;...
OVT:
NORND: POPJ P,
LUPP: ASH XP,1 ;DECIAML EXPONENT *02
CAMN AC,TAB.P(IN) ;IS NUMBER NOW >_ TABLE
CAML AC+1,TAB.P1(IN) ;...
CAMGE AC,TAB.P(IN) ;...
JRST PNO ;NO, DON'T MULTIPLY
MOVEI Q,TAB.M(IN) ;MULTIPLY BY SELECTED NEGATIVE
CAIE IN,13 ;E-32?
JRST NOTE32 ;NO
SUBI Q,2 ;USE E-16
PUSHJ P,DFM.. ;TWICE
NOTE32: PUSHJ P,DFM.. ;...
ADDI XP,1 ;INDICATE MULTIPLICATION
PNO: SOJL IN,REND ;END OF TABLE?
SOJG IN,LUPP ;MOVE TABLE POINTER AND LOOP
JRST LUPP+1 ;EXP IN RIGHT PLACE
LUPM: ASH XP,1 ;DECIMAL EXPONENT * 2
CAMN AC,TAB.M(IN) ;IS NUMBER < TABLE?
CAMGE AC+1,TAB.M1(IN) ;...
CAMLE AC,TAB.M(IN) ;...
JRST MNO ;NO, DON'T MULTIPLY
MOVEI Q,TAB.P(IN) ;MULTIPLY BY SELECTED POSITIVE
PUSHJ P,DFM.. ;...
SUBI XP,1 ;INDICATE MULTIPLICATION
MNO: SOJLE IN,REND ;END OF TABLE?
SOJA IN,LUPM ;NO, MOVE TABLE POINTER AND LOOP
; *EJG* 06/26/76
DFM..: DFMP AC,(Q) ; *EJG* 06/26/76
JOV .+1 ; *EJG* 06/26/76
POPJ P, ; *EJG* 06/26/76
ZERO: TLO BITS,BITZ ;SET INDICATOR
SETZB FR,FR+1 ;MAKE FRACTION PART 0
JRST ZEROH ;SCALING,IF NEEDED
ZEROP: MOVEI AC,"0" ;OUTPUT A ZERO
PUSHJ P,OUTCH ;...
MOVEI IN,3(D$) ;OUTPUT ENUF BLANKS
MOVEI AC,ABLANK ;ASCII BLANK
PUSHJ P,OUTCH ;...
SOJG IN,.-2 ;...
JRST OVT ;GO RETURN
;NEXT 11 INSTRUCTIONS CHANGE V.005 TO V.020
OUTDIG: MOVE MUL,FR+1 ;MULTIPLY FRACTION BY 10.
MULI MUL,=10 ;*LOW HALF BY 10.
MOVE FR+1,MUL+1 ;STORE NEW LOW HALF IN FR+1
MOVE MUL+1,MUL ;SAVE LOW HALF CARRIES
MOVE AC,FR ;GET HIGH HALF OF FRACTION
MULI AC,=10 ;* HIGH HALF BY 10.
TLO MUL,400000 ;SET SIGN TO STOP OVERFLOW
ADD MUL,MUL+1 ;ADD LOW HALF CARRIES TO HIGH HALF
TLZN MUL,400000 ;CLEAR SIGN. WAS THERE CRY1?
ADDI AC,1 ;YES, PROPOGATE CARRY
MOVE FR,MUL ;PUT HIGH PART OF NEW FRACTION BACK
ADDI AC,AZERO ;ASCII NUMBERS START AT 0
OUTCH: AOJG IGN,DEPOT. ;OUTPUT OR IGNORE?
POPJ P, ;RETURN
DEPOT.: IDPB AC,TOPBYTE(USER)
AOS -1(SP)
POPJ P,
SUBTTL ROUNDING TABLES
RNDH: OCT 200000000000
OCT 14631463146
OCT 1217270243
OCT 101422335
OCT 6433342
OCT 517426
OCT 41433
OCT 3265
OCT 253
OCT 21
OCT 1
OCT 0,0,0,0,0,0,0,0,0
RNDL: OCT 0
OCT 146314631464
OCT 327024365604
OCT 57065176763
OCT 353070414545
OCT 261070664360
OCT 336405536661
OCT 374515274536
OCT 314356106043
OCT 56027640466
OCT 267633766353
OCT 53765777027
OCT 4313631402
OCT 341134115
OCT 26411156
OCT 2200727
OCT 163225
OCT 13416
OCT 1116
OCT 73
DEFINE DEXP(A,B)<AB>
TAB.M=.+1 ; *EJG* 07/01/76
DEXP 175631463146,146314631463 ;1.0E-1 ; *EJG* 07/01/76
TAB.M2=.+1 ; *EJG* 07/01/76
TAB.M1: DEXP 175631463146,146314631463 ;1.0E-1 ; *EJG* 07/01/76
DEXP 172507534121,353412172703 ;1.0E-2 ; *EJG* 07/01/76
DEXP 163643334272,307041454513 ;1.0E-4 ; *EJG* 07/01/76
DEXP 146527461670,214106071677 ;1.0E-8 ; *EJG* 07/01/76
DEXP 113715126245,366104674127 ;1.0E-16 ; *EJG* 07/01/76
DEXP 026637304365,152123462457 ;1.0E-32 ; *EJG* 07/01/76
; *EJG* 07/01/76
TAB.P=.+1 ; *EJG* 07/01/76
TAB.P2: DEXP 201400000000,0 ;1.0 ; *EJG* 07/01/76
TAB.P1: DEXP 204500000000,0 ;1.0E+1 ; *EJG* 07/01/76
DEXP 207620000000,0 ;1.0E+2 ; *EJG* 07/01/76
DEXP 216470400000,0 ;1.0E+4 ; *EJG* 07/01/76
DEXP 233575360400,0 ;1.0E+8 ; *EJG* 07/01/76
DEXP 266434157115,370100000000 ;1.0E+16 ; *EJG* 07/01/76
DEXP 353473426555,101267026547 ;1.0E+32 ; *EJG* 07/01/76
BEND CVEL
ENDCOM(DVF)
IFN ALWAYS,<
BEND STRSER>
SUBTTL IO SERVICE ROUTINES