perm filename STRSER[S,AIL]12 blob
sn#118977 filedate 1974-09-08 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00022 PAGES VERSION 17-1(28)
RECORD PAGE DESCRIPTION
00001 00001
00007 00002 HISTORY
00011 00003 Discussion
00014 00004 COMPIL(CAT,<CAT,CATCHR,CHRCAT,CHRCHR,CAT.RV>
00022 00005 COMPIL(PTC,<PUTCH>,<GOGTAB,STRNGC,INSET>,<PUTCH -- PUT 1 CHARACTER ROUT>)
00024 00006 COMPIL(PNT,<POINT,BBPP.>,<GOGTAB,X22,X44>,<POINT, BBPP.>)
00025 00007 COMPIL(CVF,<CVF,CVG,CVE>
00029 00008 CVF,CVE,CVG CONTD.
00032 00009 CVF,CVG,CVE CONTD.
00034 00010 CVF,CVG,CVE CONTD.
00036 00011 CVF,CVG,CVE CONTD.
00038 00012 COMPIL(SUB,<SUBST,SUBSR>,<SAVE,RESTR,X22,.SKIP.,GOGTAB>,<SUBSTRING ROUTINES>)
00043 00013 COMPIL(EQU,<EQU>,<X44>,<EQU>)
00045 00014 COMPIL(CVD,<CVD,CVO>,<SAVE,RESTR,X11,X22>,<CVD AND CVO ROUTINES>)
00047 00015 COMPIL(CVS,<GETFORMAT,SETFORMAT,CVS,CVOS>
00052 00016 COMPIL(SCN,<SCAN>,<INSET,SAVE,RESTR,X44,STRNGC,BRKMSK>,<SCAN ROUTINE>)
00058 00017 COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
00062 00018 COMPIL(CVL,<CVFIL>,<SAVE,RESTR,X22,X33,FILNAM,.SKIP.>,<CVFIL>)
00064 00019 DSCR BREAKSET(TABLE #,"STRING",WAY)
00069 00020 Setbreak
00071 00021 Stdbrk
00074 00022 $print
00081 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000034 ⊗;
COMMENT ⊗
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
MOVEI X,"@" ;PUSH @
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(SCN,<SCAN>,<INSET,SAVE,RESTR,X44,STRNGC,BRKMSK>,<SCAN ROUTINE>)
DSCR "STR"←SCAN(@"STRING",BRKTBL,@BRCHAR);
CAL SAIL
⊗
HERE (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
SOSL CDB,-2(P) ;TABLE #, CHECK IT
CAILE CDB,=17 ;FOR IN RANGE
ERR <SCAN: There are only 18 break tables>,1,SCNNR
SCNNX: MOVE D,BRKMSK+1(CDB) ;HAS BITS ON FOR THIS TABLE
;;%##% LDE 3-JAN-73 LET US ALLOW LOWER TO UPPER CASE CONVERSION
TRNE D,@BRKCVT(USER) ;WANT CONVERSION?
TLOA C,400000 ; YES
TLZ C,400000 ; NO
ADDI CDB,1(USER) ;RLC+ORIG CHNL #
SETZM @-1(P) ;BREAK CHAR WORD
HRRZ Y,USER
ADD Y,[XWD X,BRKTBL];RLC+BRKTBL(USER)
;;%BK% SEE IF WE MUST COPY
TRNN D,@BRKOMT(USER) ;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
SCNNR: MOVNI CDB,1 ;USE TABLE 0;
JRST SCNNX
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(CDB) ;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(CDB) ; 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
ADD B,[070000,,0] ;BACK UP BYTE POINTER
JUMPG B,.+2
SUB B,[430000,,1] ;BACK UP ONE WORD WHEN NECESSARY
;
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%
ENDCOM(SCN)
COMPIL(CVC,<CVSIX,CVASC,CVSTR,CVXSTR>,<SAVE,RESTR,X11,X22,INSET,STRNGC,FLSCAN>
,<CVSIX, CVASC, CVSTR, CVXSTR -- 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)
MOVEW @TOPBYTE(USER),-1(P)
AOS TOPBYTE(USER)
MOVE LPSA,X22
JRST RESTR
DSCR "STR"←CVXSTR(SIXBIT INTEGER);
CAL SAIL
⊗
HERE (CVXSTR)
PUSHJ P,SAVE
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
CVXLP: ILDB TEMP,B ;GET A SIXBIT CHAR
ADDI TEMP,40 ;CONVERT TO ASCII
IDPB TEMP,TOPBYTE(USER) ;PUT IN RESULT STRING, UPDATE TOPBYTE
SOJG A,CVXLP ;DO IT ALL
MOVE LPSA,X22 ;REMOVE ARG, RETURN ADDRESS
JRST RESTR ;AND RETURN
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.
MOVE LPSA,X33
JRST RESTR
ENDCOM(CVL)
COMPIL(BRK,<BREAKSET,SETBREAK,STDBRK>
,<SAVE,RESTR,BRKMSK,SIMIO,GOGTAB,X22,X33,OPEN,LOOKUP,ARRYIN,RELEASE,.SKIP.>
,<BREAKSET, SETBREAK, STDBRK ROUTINES>)
DSCR BREAKSET(TABLE #,"STRING",WAY);
CAL SAIL
⊗
;REMOVAL OF HACK SHOULD ALSO REMOVE NOTENX-TENX STUFF
NOTENX <
NOHACK <
HERE (BREAKSET)
>;NOHACK
>;NOTENX
TENX <
HERE (BREAKSET)
>;TENX
HACK <
HEREFK(BREAKSET,BRE.KSET)
>;HACK
PUSHJ P,SAVE ;SAVE ACS AND THINGS
MOVE LPSA,X33
SUB SP,X22
SKIPLE A,-2(P) ;TABLE #
CAILE A,=18
ERR <THERE ARE ONLY 18 BREAK TABLES>
HLLZ B,BRKMSK(A) ;BREAK MASK FOR THIS TABLE
ADD A,USER
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
XWD ILLSET,RETCH ;-,,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(USER) ;ASSUME HAVE SOME
CAIN A,0 ;HAVE ANY
ANDCAM B,BRKOMT(USER) ;NO
;;%BK%
INCL: MOVSI D,-200
HRRI D,BRKTBL(USER) ;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,(USER) ;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
JRST RESTR
PASLINS: TDZA B,B ;PASS LINE NOS. SINE COMMENT
NOLINS: MOVEI B,-1 ;INFORM IN THAT IT SHOULD
MOVEM B,LINTBL(A) ; 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(A)
JRST RESTR
PENDCH: SETOM DSPTBL(A) ;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(A)
JRST RESTR
;;%##%
UCASE: MOVSS B ;INTO RIGHT HLF
IORM B,BRKCVT(USER)
JRST RESTR
;;%BG% =A1=
LCASE: MOVSS B
ANDCAM B,BRKCVT(USER)
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
⊗
HACK <
HEREFK(SETBREAK,SETB.K)
>;HACK
NOTENX <
NOHACK <
HERE (SETBREAK)
>;NOHACK
>;NOTENX
TENX <
HERE (SETBREAK)
>;TENX
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)
COMMENT ⊗Stdbrk ⊗
DSCR STDBRK(CHANNEL);
CAL SAIL
⊗
HACK <
HEREFK(STDBRK,STDB.K)
>;HACK
NOTENX <
NOHACK <
HERE (STDBRK)
>;NOHACK
>;NOTENX
TENX <
HERE (STDBRK)
>;TENX
PUSH P,-1(P) ;CHANNEL
PUSH SP,STDBDV
PUSH SP,STDBDV+1
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
SETZM .SKIP.
PUSHJ P,OPEN ;OPEN CHANNEL
SKIPE .SKIP. ;ERROR?
ERR <Can't open STDBRK channel>,1,STDEXT
PUSH P,-1(P)
PUSH SP,STDBFL
PUSH SP,STDBFL+1
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 LPSA,DSPTBL(USER)
PUSH P,LPSA
PUSH P,[=19+=19+=128]
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)
NOTENX<
STDBFL:
=9
POINT 7,[ASCIZ/BKTBL.BKT/]
STDBDV: =3
POINT 7,[ASCIZ/SYS/]
>;NOTENX
TENX<
STDBFL:
BKTFIL ;DEFINED IN HEAD
STDBDV: =3
POINT 7,[ASCIZ/DSK/],-1
>;TENX
NOHACK <
HERE(BRKSP1) ; SPARES *******
HERE(BRKSP2);
ERR <DRYROT IN BRK SPARES>
>;NOHACK
HACK <
HEREFK(BRKSP1,BRKS.1) ; SPARES *******
HEREFK(BRKSP2,BRKS.2) ;
ERR <DRYROT IN BRK SPARES>
>;HACK
ENDCOM(BRK)
COMPIL(PRN,<$PRINT,$$PRIN>
,<GOGTAB,X22,OUT,OUTSTR,INCHWL,OPEN,GETCHAN,ENTER,.SKIP.,RELEASE>
,<STRING PRINTING ROUTINE>)
COMMENT ⊗$print⊗
;;%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
HEREFK($$PRIN,$$PRI.)
TDZA A,A
HEREFK($PRINT,$PRIN.)
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
HEREFK(P.FIN,P.FIN.)
MOVE USER,GOGTAB
SKIPE B,PRNINF(USER)
TLNE B,UROUTB
POPJ P,
TLNN B,CHNSPC
POPJ P,
HRRZS B
PUSH P,B
PUSH P,[0]
PUSHJ P,RELEASE
POPJ P,
BEND STRPRN
ENDCOM(PRN)
IFE ALWAYS,<
COMPIL(DM5,<P.FIN>,,<DUMMY $PRINT FINISHER>)
↑↑P.FIN:
POPJ P,
ENDCOM(DM5)
>;IFE ALWAYS
IFN ALWAYS,<
BEND STRSER>
SUBTTL IO SERVICE ROUTINES