software: Added more and more

[pdp8.git] / sw / os8 / v3d / sources / system / dectapes / dectape3 / IOH.SB

/IOH SUBROUTINE                     OS8 FORTRAN II LIBRARY
/
/
/
/
/
/
/
/
/
/COPYRIGHT  (C)  1974,1977 BY DIGITAL EQUIPMENT CORPORATION
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
/CORPORATION.  DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/FOR ANY ERRORS THAT MAY APPEAR IN THIS MANUAL.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
/
/DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
/OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
/DIGITAL.
/
/
/
/
/
/
/
/
/
/
\f/	VERSION 10A
/	APRIL 28,1977
/	INPUT OUTPUT CONVERSION SUBROUTINE
/	FOR 8K ALICS-FORTRAN SYSTEM
/	VERSION NUMBER IS AVAILABLE AT ENTRY POINTS
/
	ABSYM SACH 23		/SAVE FPAC FOR MANIPULATION OF AC
	ABSYM SACM 24
	ABSYM SACL 25
	ABSYM N2 175		/LAST ACCUMULATED NUMBER
	ABSYM ARGUMT 176
	DUMMY	ARGUMT
	DUMMY	FPNT
	ENTRY	READ
	ENTRY	WRITE
	ENTRY	IOH
/
/	THE FOLLOWING IS NECESSARY BECAUSE CERTAIN SUBROUTINES SKIP
/
	OPDEF TADI 1400
	OPDEF DCAI 3400
	OPDEF ANDI 0400
	OPDEF JMPI 5400
	OPDEF JMSI 4400
	OPDEF ISZI 2400
	SKPDF JMSKP 4000
	LAP

/
A2,	BLOCK	14
/
/	IOH ERROR ROUTINES
/
ERRNO,	BLOCK	1
ERR2,	ISZ	WHI	/SEE IF THIS WAS I FORMAT OR THE EXPONENT
ERR3,	ISZ	ERRNO	/IN E FORMAT
	ISZ	ERRNO
	SKP
ERR1,	ISZ	DV	/ERR1 IS ALWAYS FATAL
	CLA
	TAD	DV
	SNA CLA		/WAS THIS AN INPUT ERROR FROM THE TELETYPE?
	CLA CLL CML RAR		/YES - NON-FATAL
	TAD	(615
	DCA	IO
	TAD	ERRNO		/IOH ERROR NUMBER
	TAD	(2461		/MAKE INTO BCD
	DCA	SW		/TO ERROR COMMENT
	CALL	1,ERROR
	ARG	IO

	JMP	RETRY		/DO ENTIRE READ STATEMENT OVER
DV,	0			/SAVE DEVICE CODE
CS,	A2			/INITIAL PUSH POINTER
PARN,	0
	NOP		/CDF N
	TADI	WRITE#
	INC	WRITE#
	JMP I	PARN
CH,	0
TW,	12
READ,	BLOCK 1
	10			/ENTRY POINT FOR READ
RETRY,	TAD	READ		/SNEAK IN
	DCA	WRITE
	TAD	READ#
	DCA	WRITE#		/SAVE SECOND RETURN WORD
	JMP	ET
	CPAGE 4
IO,	0
SW,	0			/LEFT OR RIGHT HALF OF FORMAT
WRITE,	BLOCK 1
	10			/ENTRY POINT
	CLA IAC 		/INITIALIZE SWITCH
ET,	DCA	IO
	DCA	CH		/CLEAR CHARACTER
	DCA	ERRNO		/ZERO ERROR NUMBER IN CASE ERROR RESTART
	TAD	WRITE
	DCA	PARN#
	JMS	PARN
	DCA	DEVNO1
	JMS	PARN
	DCA	7
DEVNO1,	NOP		/CDF N
	CLA CMA
	TADI	7		/PICK UP DEVICE NUMBER
	CLL RTR			/ROTATE IT INTO BITS 0-3
	RTR
	RAR
	DCA	DV
	TAD	CS		/INITIALIZE PUSH STACK
	DCA	PUSH		/-
	JMS	PARN
	DCA	FPNT01
	JMS	PARN
	DCA	FPNT
	CLA IAC		/SET UP "SW" TO START FORMAT
	DCA	SW	/FROM SECOND CHARACTER (FIRST IS LPAREN)
	DCA	BA	/ZAP END-OF-LINE SWITCH
	TAD	PENTER	/FAKE RE-ENTRY TO SET UP FIRST LPAREN
	DCA	GLST	/ON PUSHDOWN STACK
	RETRN	WRITE
PENTER,	FENTER

FPNT,	0
GFRM,	0
	TAD	SW
	INC	SW
	CLL RAR
	TAD	FPNT		/FORM ADDRESS IN AC AND LEFT/RIGHT
	DCA	7		/SWITCH IN LINK
FPNT01,	NOP			/CDF N
	TADI	7
	SZL			/LEFT OR RIGHT?
	JMP	HR
	RTR
	RTR
	RTR
HR,	AND	(77
	JMP I	GFRM
	CPAGE	5
	0		/I1000
	0		/I100
	0		/I10
I1,	0		/I1
	4000
SV,	BLOCK 3		/FLOATING POINT TEMPORARY
	CPAGE 3
TN,	2045		/10.0
	0
	0
\f	PAGE		/EXPERIMENTAL
RETN,	DCA	SACH		/SET SACH TO 0
RTUR,	JMS	GFRM		/GET NEXT CHAR IN FORMAT
	CPAGE 24
	JMS	CHTYPE	/CLASSIFY FORMAT CHARACTER
	DG		/DIGIT EXIT
	-57;	SL
	-56;	PER
	-54;	CM
	-51;	RPAR
	-50;	LP
	-47;	QT
	-40;	RTUR
	0;	SVCHR
SVCHR,	DCA	CH
	JMS	NU		/GET THE ACCUMULATED NUMBER
	CMA			/KRONK IT
	DCA	N1		/AND SAVE	COUNT FOR ALL CONVERSIONS
	TAD	CH
	AND	(7757
	TAD	(7770		/THIS TESTS IF CH IS AN ,X, OR ,H,
	SNA CLA
CM,	JMS	PR		/IT WAS	, PROCESS IT
	JMP	RETN		/NOT X OR H, KILL NUMBER AND TRY AGAIN
N1,	0

SL,	JMS	PR		/GO PROCESS THE PREVIOUS ITEM (IF ANY)
	JMS	EJ
	JMP	RETN
QT,	JMS	PR		/PROCESS PREVIOUS ITEM, IF ANY
QT1,	JMS	GFRM
	TAD	(-47
	SNA			/ANOTHER QUOTE?
	JMP	RETN
	TAD	(47
	JMS	PRINT		/PRINT CHAR
	JMP	QT1
DG,	JMS	DGT		/ACCUMULATE DIGIT INTO SACH
	JMP	RTUR		/TRY ANOTHER CHARACTER
LP,	ISZ	PUSH		/LEFT PAREN
	CLA CMA 		/COUNT NESTING DEPTH, NEGATIVE
	TAD	NPAR
	DCA	NPAR
	TAD	SW		/PICK UP THE FORMAT POINTER
	DCA I	PUSH		/CRAM IT INTO THE LIST
	ISZ	PUSH		/KICK AGAIN
	JMS	NU		/THERE MAY BE AN ACCUMULATED NUMBER
	CIA			/SAVE NUMBER
	DCA I	PUSH		/*
	CLA CLL CML RTL		/HERE WE SEE IF THIS IS A POSSIBLE
	TAD	NPAR		/RESTART POINT
	SPA CLA 		/IF FIRST SAVE SW IN S1
	JMP	RETN		/NOPE- FORGET IT
	TAD	SW		/YES--FIRST CRAM FORMAT---
	DCA	S1		/---INTO SAVE1
	TAD I	PUSH		/AND THAT STUFF IN THE LIST---
	DCA	S2		/---GOES INTO SAVE 2
	JMP	RETN		/READY FOR ANYTHING, HERE WE GO
PUSH,	0		/PARENTHESIS PUSHDOWN LIST POINTER

RPAR,	JMS	PR		/PROCESS PREVIOUS ITEM, IF ANY
	ISZ I	PUSH
	JMP	TR
	CLA CLL CMA RAL		/-2
	TAD	PUSH		/DELETE THIS ITEM FORM THE LIST
	DCA	PUSH		/PUSH = PUSH-2
	ISZ	NPAR		/NPAR = NPAR +1 ]-1[ SINCE MINUS COUNT
	JMP	RETN
	JMS	WH		/THIS PAREN WAS THE BALANCING PAREN
	TAD	S1		/GET THE FORMAT POINTER OF THE--
	DCA	SW		/RESTART POINT AND CRAM IT
	TAD	S2		/GET SWITCH AND THE COUNT
	CIA
FENTER,	DCA	SACH
	CLA CMA
	TAD	SW		/TEST TO SEE IF SW IS ORIGINAL POINTER
	SNA CLA
	JMP	L2		/YES - FAKE A RESTART
	ISZ	PUSH		/NO - PUSH ORIGINAL POINTER
	CLA IAC			/SINCE WE ARE RETURNING TO DEPTH 2
	DCA I	PUSH
	ISZ	PUSH
	CLA CMA 		/SET COUNT = 1, SWITCH = 1
	DCA I	PUSH
	CMA
L2,	DCA	NPAR		/PARNRN = -1
	JMP	LP

TR,	CLA CMA 		/GET OUT THE FORMAT POINTER--
	TAD	PUSH		/*
	DCA	N3
	TAD I	N3
	DCA	SW		/HAA-- IT IS NOW RESTORED
	JMP	RETN		/AWAY WE GO
N3,	0			/W FOR E AND F CONVER
PER,	JMS	NU		/GOT A PERIOD, MUST BE	OR F TYPE
	DCA	N3
	JMP	RETN
S1,	0
S2,	0			/SAVE THE COUNT AND SWITCH
NPAR,	0
\f	PAGE		/EXPERIMENTAL

EX,	JMS	GLST		/THIS IS E FORMAT CONVERSION
EE,	JMS	NR	/CHECK IF INPUT - IF NOT, GET NUMBER INTO [.1,1]
	TAD	C
	DCA	GLST		/STORE C AWAY IN A SAFE PLACE
	DCA	C
	CLA CMA
	DCA	EFLG		/SET "E FORMAT FAKEOUT" FLAG
	TAD	(-5
	JMP	FFAKE		/FAKE OUT "F" FORMAT TO PRINT DIGITS
PRNTE,	TAD	(5		/PUT OUT THE E
	JMS	PRINT


/	NOW PRINT 'C' DIGITS UNDER I3 FORMAT
	TAD	GLST
	SPA SNA CLA
	CLA CLL CMA RAL
	TAD	(55
	JMS	PRINT		/PRINT A MINUS OR PLUS
	TAD	GLST
	SPA
	CIA
	CALL	1,DIV
	ARG	TW
	TAD	(60
	JMS	PRINT		/PRINT
	CPAGE 4
	CALL	0,IREM		/IREM NEEDS AN ARGUMENT TO IGNORE
EFLG,	0
CRX,	0
	TAD	(60
	JMS	PRINT		/PRINT SECOND DIGIT
	JMP	EX		/DONE, DO NEXT

FX,	CLA
	JMS	GLST		/THIS IS F	FORMAT CONVERSION
FF,	JMS	NR	/CHECK IF INPUT - IF NOT, GET NUMBER INTO [.1,1]
	DCA	EFLG
	TAD	C		/C CONTAINS NUMBER OF MULTS TO RANGE NUMBER
	SMA
	CLA CMA			/0 MULTS NEEDED OR ALREADY THERE
FFAKE,	TAD	N3		/NUM3 IS THE FIELD WIDTH
	CIA			/MINUS SPACE FOR DADP+DP
	TAD	N2
	JMS	SA		/PUT OUT REQUIRED BLANKS + SIGN
	TAD	C
	SMA
	JMP	PRZRO	/NO LEADING DIGIT - PRINT A ZERO FOR LOOKS
	CIA
	JMS	DT
PRDCPT,	TAD	(56
	JMS	PRINT
	TAD	C		/GET MULTIPLY COUNT
	SPA SNA
	JMP	PAS2
	CMA			/THEY WERE MULTIPLIES, 0 TO N OF THEM
	DCA	CRX
	TAD	N2		/DIGITS AFTER DEC POINT, DADP
	CMA
	DCA	NR
	JMP	PASA		/TEST FOR 0 MULTIPLIES
RETR,	TAD	(60		/PUT OUT A ZERO
	JMS	PRINT		/ALL MULTIPLIES REPRESENTED
PASA,	ISZ	CRX		/NO, TRY RUN OFF FIELD
	SKP
	JMP	PASS		/YES
	ISZ	NR		/ALL WIDTH ACCOUNTED FOR%
	JMP	RETR		/NO, TRY NEXT POSITION


PASS,	TAD	C		/YES, GET MULT COUNT
	CIA			/-MULT COUNT
	SKP
PAS2,	CLA
	TAD	N2		/N2-MULT COUNT
	SMA SZA			/IS MULT COUNT .GE. N2?
	JMS	DT		/NO - PRINT REMAINING DIGITS
	ISZ	EFLG		/WERE WE FAKED OUT BY "E" FORMAT?
	JMP	FX		/NO
	JMP	PRNTE		/YES - GO PRINT EXPONENT
PRZRO,	CLA
	TAD	(60
	JMS	PRINT
	JMP	PRDCPT		/GO BACK TO PRINT THE DECIMAL POINT

SA,	0
	TAD	SN
	SMA			/THIS IS -(NUM OF BLANKS)
	JMP	AS3		/POSITIVE, NUMBER TOO BIG FOR FIELD
	DCA	CRX
	SKP CLA
RETC,	JMS	PRINT		/HERE WE PUT OUT THAT MANY BLANKS
	TAD	(40
	ISZ	CRX
	JMP	RETC		/YES
	CLA
	TAD	SN
	SNA CLA			/IS SIGN MINUS?
	JMP I	SA		/EVIDENTLY NOT
	TAD	(55
	JMS	PRINT		/PUT OUT A MINUS SIGN
	JMP I	SA

\f	PAGE		/EXPERIMENTAL
FN,	TAD	N3		/GET WIDTH, INPUT FOR E OR F FORMAT
	CMA			/1'S COMPLEMENT
	DCA	CR		/TO COUNTER
	DCA	D1		/0 TO D1
	CALL	0,CLEAR
	CMA
	DCA	D2		/-1 TO DECIMAL POINT SWITCH
	CMA		/-0 TO SGN FLAG
RRTSGN,	DCA	SN
RRT,	CLA
	ISZ	CR		/INDEX TO SEE IF WIDTH EXCEEDED
	SKP
	JMP	FP		/GET AN INPUT CHARACTER AND TEST IT
	JMS	GCHR
	CPAGE 20
	JMS	CHTYPE	/CLASSIFY INPUT CHAR
	FDIGIT		/DIGIT
	-56;	PUNT
	-40;	RRT
	-53;	RRT
	-55;	RRTSGN
	-5;	EPRO
	0
PERR3,	ERR3
FDIGIT,	DCA	IS
	CALL	1,FMP
	ARG	TN
	CALL	1,STO		/SAVE FLOATING POINT ACCUMULATOR
	ARG	SV
	TAD	IS
	CALL	0,FLOT		/FLOAT NEW DIGIT
	CALL	1,FAD
	ARG	SV
	INC	D1		/COUNT OF DIGITS
	JMP	RRT
PUNT,	ISZ	D2		/TST DP SWITCH
	JMPI	PERR3		/***** TWO DECIMAL POINTS *****
	DCA	D1
	JMP	RRT
EPRO,	CLA CMA 		/AN E
FP,	DCA	IS		/-1 TO IS IF E, 0 TO IS IF END OF FIELD
	ISZ	D2		/TEST DP SWITCH
	JMP	FA		/ONE HAS OCCURRED
	TAD	N2		/ONE HAS NOT OCCURRED, GET NDP
	SKP
FA,	TAD	D1		/COUNT OF DIGITS AFTER EXPLICIT DP
	CMA			/-COUNT
	JMS	DH		/DIVIDE FPAC BY TEN COUNT TIMES
	TAD	ACH		/IF ACH=0,DON'T CHK. SIGN
	SNA
	JMP	ZR		/ZERO-DON'T CHECK
	ISZ	SN		/TEST SIGN
	TAD	(4000		/SET SIGN BIT
	DCA	ACH
ZR,	ISZ	IS	/DID WE GET AN "E"?
	JMP	VZA	/NO - STORE RESULT AND GET OUT
	JMP	VQ	/YES - FAKE INTEGER ROUTINE TO ACCEPT EXPONENT
D1,	0
D2,	0
IS,	0
CR,	0

PRO2,	CMA		/GOT EXPONENT - MAKE IT NEGATIVE
	ISZ	SN	/WHAT WAS ITS ORIGINAL SIGN?
	JMP	VZB	/NEGATIVE - DIVIDE BY 10^EXP
	DCA	D1		/SAVE COUNT
	JMP	VZD
VZC,	CALL	1,FMP
	ARG	TN
VZD,	ISZ	D1		/INDEX COUNT
	JMP	VZC
	JMP	VZA
VZB,	JMS	DH
VZA,	CALL	1,ISTO		/STORE IN PLACE
	ARG	ARGUMT
	JMP	FX
\f	PAGE		/EXPERIMENTAL
XX,	JMS     MR		/TEST FOR MORE
	TAD     IO		/TEST FOR INPUT-OUTPUT
	SNA CLA
	JMP     XX1		/INPUT, PSEUDO-JUMP
	TAD     (40		/OUTPUT A BLANK
	JMS     PRINT
	JMP     XX		/CYCLE
XX1,	JMS	GCHR		/IGNORE SPACES ON INPUT
	CLA
	JMP	XX

HH,	JMS	MR	/THE H FIELD PROCESSOR
	JMS	GFRM	/SAME AS XXX, BUT PRINT NEXT
	JMS	PRINT	/----- FORMAT CHARACTER
	JMP	HH	/OUTPUT ONLY

PRINT,	0
	TAD	(-40
	SPA
	TAD	(100		/CONVERT 6-BIT TO 8-BIT
	TAD	(240
	TAD	DV		/ADD ON DEVICE NUMBER IN BITS 0-3
	CALL	0,GENIO
	JMP I	PRINT

WH,	0
	JMS	EJ	/END THE RECORD
	TAD	ARGUMT#
	SNA CLA 	/TEST PARAMETER FOR 0
	JMS	GLST	/RETURN TO MAIN PROGRAM ON 0 PAR
	JMP I	WH	/MORE AGRUMENTS RETURN

EJ,	0			/ROUTINE TO END RECORD
	TAD	IO
	SZA CLA			/INPUT OR OUTPUT?
	JMP	E1		/OUTPUT
E2,	CLA
	TAD	BA
	SZA CLA
	JMP	BG		/CARRIAGE RETURN SEEN - GOODBYE
	JMS	GCHR		/GET A CHARACTER
	JMP	E2		/KEEP LOOKING FOR CR
BG,	DCA	BA
	JMP I	EJ
E1,	TAD	(7715		/7715 TRANSLATES TO 215
	JMS	PRINT
	TAD	(7712
	JMS	PRINT		/PRINT CR-LF
	JMP I	EJ

BA,	0		/THIS IS THE END OF LINE SWITCH
BH,	ISZ	BA	/ENTRY TO LOOK FOR AN END OF LINE
BL,	TAD	(40
	AND	(77		/KEEP THIS - BL IS REFERENCED BY GCHR
	JMP I	GCHR

GCHR,	0		/GET AN INPUT STRING CHARACTER
JD,	CLA
	TAD	BA	/GET EOR SWITCH
	SZA CLA
	JMP	BL	/IS EOR, RETURN BLANK
	CLA CLL CML RTR		/****** IF # OF DEVICES IS CHANGED,
	TAD	DV		/THIS SHOULD BE CHANGED TOO *****
	CALL	0,GENIO		/CALL GENIO WITH OFFSET DEVICE NUMBER
	AND	(177		/STRIP PARITY
	TAD	(7763
	SNA			/CARRIAGE RETURN?
	JMP	BH
	TAD	(7655
	CLL
	TAD	(100		/IS CHAR IN RANGE 237<CHAR<340?
	SNL
	JMP	JD		/NO - IGNORE
	JMP	BL		/CONVERT TO SIXBIT AND RETURN
\f	PAGE		/EXPERIMENTAL
/     GET F.P. NUMBER INTO THE RANGE	.1 .LE. N .L. 1.0
NR,	0
	JMSKP	BB	/CHECK DIRECTION OF I/O
	JMP	FN	/INPUT
	CALL	1,IFAD	/OUTPUT - LOAD NUMBER INTO FLOATING AC
	ARG	ARGUMT
	DCA	SN	/CLEAR THESE LOCS
	DCA	C
	TAD	ACH
	SNA
	JMP	NREX	/NUMBER IS ZERO
	SMA		/IS IT A MINUS F P NUMBER
	JMP	RETM
	TAD	(4000	/YES-- MAKE IT POSITIVE
	ISZ	SN	/SET SIGN
	DCA	ACH
RETM,	CLA			/MULTIPLY BY 10 UNTIL NR .GT. (1.0)
	TAD	ACH
	TAD	(5764
	SMA CLA
	JMP	TB	/GOT IT IT IS .GE.1
	CALL	1,FMP
	ARG	TN
	ISZ	C	/AND COUNT
	JMP	RETM	/GO TRY TO DO IT AGAIN
TB,	JMS	SE	/NOTE SE ' XR-1
	CALL	1,STO
	ARG	SV
	TAD	(2004
	DCA	ACH	/200400000000=.50000 IN AC
	TAD	CH	/TEST FORMAT
	TAD	(7772
	SNA CLA		/IS IT E FORMAT?
	TAD	C	/NO - COUNT # OF MULTS NEEDED
	CIA
	TAD	N2	/< DADP
	SMA
	CMA		/NUMBER OF THIMES TO DIVIDE .5 BY 10 TO RND
	JMS	DH	/DO THE DIVIDES
	CALL	1,FAD
	ARG	SV
	JMS	SE	/REDUCE TO NORMAL RANGE AGAIN


GD,	TAD	ACH
	RAL
	SPA CLA
	JMP	ZP	/NUMBER IS ? 1/2
	TAD	ACH
	CLL RAR 	/WE ARE GETTING EXP TO 200
	DCA	ACH
	TAD	ACM
	RAR
	DCA	ACM
	TAD	ACL
	RAR
	DCA	ACL
	TAD	ACH
	AND	(7774
	TAD	ACH
	TAD	(10
	DCA	ACH
	JMP	GD
ZP,	TAD	ACH
	AND	(7
	DCA	ACH
NREX,	JMP I	NR
SN,	0

C,	0			/COUNTER FOR DEC. EXP.
SE,	0			/DIVIDE BY 10 UNTIL N < 1.0
XR,	TAD	ACH		/TEST NUMBER FOR .GE. 1
	TAD	(5764
	SPA CLA
	JMP I	SE		/NUMBER IS IN RANGE, RETURN
	CLA CLL CMA RAL
	JMS	DH
	CLA CMA 		/REDUCE COUNT
	TAD	C
	DCA	C
	JMP	XR
\f	PAGE		/EXPERIMENTAL
GLST,	0		/GET NEXT ARGUMENT ROUTINE
	CALL	0,CLEAR	/CLEAR FLOATING AC
	ISZ	IOHCNT	/ARE WE IN AN ARRAY I/O LOOP?
	JMP	ARMORE	/YES - GET NEXT ELEMENT
	INC	IOH#
	RETRN	IOH	/RETURN TO USERS PROGRAM FOR MORE DATA
ARMORE,	TAD	ARGUMT#
	TAD	IOHINC	/BUMP ARGUMENT POINTER BY ELEMENT LENGTH
	JMP	IOHBAK	/RESUME I/O CONVERSIONS WITH UPDATED ARGUMT

	CPAGE 33
IOH,	BLOCK	1
	10	
	SZA CLA		/IS THIS A SCALAR OR AN ARRAY CALL?
	JMP	IOHAR	/AN ARRAY CALL
	CLA CMA
IOGTAR,	DCA	IOHCNT	/SET UP ARGUMENT COUNT FOR THIS CALL
	TAD	IOH
	DCA	IOH1
IOH1,	NOP		/SET DATA FIELD TO ARGUMENT LIST
	TADI	IOH#
	DCA	ARGUMT
	INC	IOH#
	TADI	IOH#
IOHBAK,	DCA	ARGUMT#
	JMP I	GLST	/RETURN TO I/O CONVERSION
IOHAR,	INC	IOH#
	CLA CLL CML RAR
	AND I	IOH	/GET TYPE OF ARRAY
	CLL RTL
	CML RAL		/FORM A 1 OR A 3, DEPENDING ON ARRAY TYPE
	DCA	IOHINC
	CLA CLL CMA RAR
	ANDI	7	/GET THE ELEMENT COUNT
	CIA
	INC	IOH#
	JMP	IOGTAR	/SAVE IT AND GET ARRAY POINTER
IOHINC,	0
IOHCNT,	0

CHTYPE,	0		/SUBROUTINE TO CLASSIFY CHARACTERS
	DCA	CHCH
	TAD	CHCH
	TAD	(7706
	CLL
	TAD	(12
	SZL		/IS THE CHARACTER NUMERIC?
	JMP	JMPOUT	/YES - TAKE FIRST EXIT
	INC	CHTYPE
CHLOOP,	CLA
	TAD I	CHTYPE
	INC	CHTYPE
	SNA		/CHARACTER LIST EXHAUSTED?
	JMP	JMPOTX	/YES - TAKE LAST EXIT WITH CHAR IN AC
	TAD	CHCH
	SNA CLA		/MATCH?
	JMP	JMPOUT	/YES - TAKE EXIT WITH AC=0
	INC	CHTYPE
	JMP	CHLOOP	/NO MATCH - GO ON TO NEXT CHAR
JMPOUT,	DCA	CHCH
JMPOTX,	TAD I	CHTYPE
	DCA	CHTYPE
	TAD	CHCH
	JMP I	CHTYPE
CHCH,	0

DT,	0
	CIA
	DCA	CHCH	/STORE COUNT
RETT,	JMS	LS	/LEFT SHIFT 1
	TAD	ACL	/SAVE THE FPAC
	DCA	SACL
	TAD	ACM
	DCA	SACM
	TAD	ACH
	AND	(17
	DCA	SACH
	TAD	SACH
	DCA	ACH	/TRIM AC TO 28 BITS
	JMS	LS	/LEFT SHIFT 2
	JMS	LS
	TAD	ACL	/ADD THE DSAVE TO THE ACC
	TAD	SACL
	DCA	ACL
	RAL		/*
	TAD	ACM
	TAD	SACM
	DCA	ACM
	RAL		/*
	TAD	ACH
	TAD	SACH
	DCA	ACH
	TAD	ACH
	CLL RAR 	/ROTATE 3 RIGHT
	RTR
	AND	(17
	TAD	(60	/MAKE DIGIT
	JMS	PRINT	/DUMP IT AND SEE IF ANY MORE
	ISZ	CHCH	/LOOP ON COUNT
	JMP	RETT	/*
	JMP I	DT

LS,	0		/LEFT SHIFT THE FPAC 1
	TAD	ACL
	CLL RAL
	DCA	ACL
	TAD	ACM
	RAL
	DCA	ACM
	TAD	ACH
	RAL
	DCA	ACH
	JMP I	LS	/DONE
\f	PAGE		/EXPERIMENTAL
PR,	0
	TAD	SACH	/GET THE LAST NUMBER ACCUMULATED
	DCA	N2	/SAVE IT
PR2,	TAD	CH
	SNA
	JMP I	PR	/NOTHING TO DO
	CPAGE 22
	JMS	CHTYPE	/CLASSIFY CH
	ERR1		/DIGIT IS ILLEGAL
	-30;XX
	-11;II
	-10;HH
	-6;FF
	-5;EE
	-1;AA
	0;ERR1

MR,	0		/MORE?
	ISZ	N1	/SEE IF IT GOES TO ZERO
	JMP I	MR
	DCA	CH	/NO MORE FIELDS, FIRST WIPE CHAR
	JMP I	PR	/GO BACK TO FORMAT SCANNER
NU,	0		/ROUTINE TO FETCH THE ACCUM NUMB
	TAD	SACH
	SNA		/IF IT IS ZERO, SET IT TO 1
	CLA IAC 	/IT IS AND WE DO
	JMP I	NU	/GO HOME
BB,	0
	JMS	MR	/MORE?
	TAD	ARGUMT#
	SNA CLA		/IF ARG=0,
	JMS	WH	/END RECORD AND RETURN TO USERS PROGRAM
	TAD	IO	/TEST IN OUT SWITCH
	SZA CLA 	/OUTPUT
	INC	BB	/INPUT
	JMP I	BB
AX,	JMS	GLST
AA,	TAD	N2
	CIA
	DCA	CX
	JMSKP	BB
	JMP	AR
AS,	JMS	GADR	/GET CHARACTER ADDRESS
	TADI	7
	SZL
	JMP	ASNORT
	RTR
	RTR
	RTR
ASNORT,	AND	(77	/MASK 6 BITS
	JMS	PRINT
	ISZ	CX
	JMP	AS	/LOOP FOR CHARACTER COUNT
	JMP	AX	/GET NEXT ARGUMENT(IF ANY)

AR,	JMS	GCHR
	DCA	DH	/GET AND SAVE INPUT CHAR
	JMS	GADR	/GET CHARACTER POINTER
	TAD	DH
	SZL		/WHICH HALF?
	JMP	ARNORT	/RIGHT HALF
	IAC
	RTL
	RTL
	RTL
	SKP
ARNORT,	TADI	7
	TAD	(7740	/CANCEL BLANK CHAR
ARCOMN,	DCAI	7
	ISZ	CX
	JMP	AR
	JMP	AX

GADR,	0		/SUBR TO COMPUTE CHARACTER ADDR FOR "A" FMT
	TAD	ARGUMT
	DCA	AS1
	TAD	N2
	TAD	CX
	CLL RAR
	TAD	ARGUMT#	/AC=WORD POINTER, LINK=LEFT/RIGHT FLAG
	DCA	7
AS1,	NOP		/SET UP DATA FIELD OF ARGUMENT
	JMPI	GADR
CX,	0

DH,	0
	DCA	CX	/DIVIDE FPAC BY TEN CX TIMES
	JMP	DTA
DTB,	CALL	1,FDV
	ARG	TN
DTA,	ISZ	CX
	JMP	DTB
	JMP I	DH
AS3,	CLA		/PRINT ASTERISKS FOR WHOLE FIELD SIZE
	TAD	N3	/GET FIELD SIZE, E OR F
	CMA
	DCA	CX	/-COUNT
	JMP	QQ
QQA,	TAD	(52	/PRINT CX ASTERISKS
	JMS	PRINT
QQ,	ISZ	CX	/INDEX COUNT
	JMP	QQA
	JMS	GLST	/TEST FOR MORE
	JMP	PR2	/RETURN TO FORMAT PROCESSOR, SAME TYPE
\f	PAGE		/EXPERIMENTAL
IN,	TAD	N2	/INTEGER INPUT, GET WIDTH OF FIELD
	CMA		/1,S COMP TO COUNTER, CR
	DCA	CR
	CMA
VQ,	DCA	WHI	/-1 TO NUMBER ACCUMULATED
	CMA		/-1 TO SIGN
RRSIGN,	DCA	SN
	DCA	SACH
RRS,	ISZ	CR	/HAS WHOLE NUMBER BEEN ACCUMULATED
	SKP
	JMP	PRO
	JMS	GCHR
	CPAGE 14
	JMS	CHTYPE	/CLASSIFY CHARACTER
	DIGIT		/ITS A DIGIT
	-40;	RRS
	-53;	RRS
	-55;	RRSIGN
	0;	ERR2
DIGIT,	JMS	DGT	/ACCUMULATE DIGIT INTO SACH
	JMP	RRS	/GET NEXT DIGIT
PRO,	TAD	SACH	/WE HAVE AN INTEGER ...
	ISZ	WHI	/WHAT KIND?
	JMP	PRO2
	ISZ	SN	/ 'I' FORMAT
	CIA
	DCA I	ARGUMT

IX,	CLA
	JMS	GLST	/INTEGER CONVERSION
II,	JMSKP	BB	/TEST MORE AND NON ZERO CURRENT LIST ITEM
	JMP	IN	/INPUT
	TAD	AB
	DCA	SACL	/OUTPUT
	TAD	(-4
	DCA	WHI	/-4
	DCA	SN	/0
	TAD I	ARGUMT
	SMA		/SET SN 0 FOR PLUS, 1 FOR MINUS
	JMP	XZ	/PLACE MAGNITUDE IN 20
	CIA
	ISZ	SN
XZ,	CALL	1,DIV
	ARG	TW
	DCA	SACH
	CPAGE 4
	CALL	0,IREM	/IREM NEEDS AN ARGUMENT TO IGNORE
AB,	I1
WHI,	0


	DCA I	SACL	/SAVE REMAINDER
	CMA
	TAD	SACL	/SACL=SACL-1
	DCA	SACL
	ISZ	WHI	/INDEX COUNT
	TAD	SACH	/AND CHECK NUM FOR 0
	SZA
	JMP	XZ	/CYCLE
IB,	TAD	N2
	DCA	N3	/IN CASE OF OVERFLOW
	TAD	N2
	CMA
	TAD	WHI
	TAD	(4	/COMPUTE NUMBER OF LEADING BLANKS
	JMS	SA	/PRINT LEADING BLANKS AND SIGN
ID,	INC	SACL	/POINT TO DIGIT TO PRINT NEXT
	TAD I	SACL	/GET IT
	SPA		/TERMINATOR?
	JMP	IX	/YUP
	TAD	(60
	JMS	PRINT	/NOPE - PRINT THE DIGIT
	JMP	ID	/GET NEXT

DGT,	0
	DCA	SACM
	TAD	SACH
	CLL RTL
	TAD	SACH
	RAL
	TAD	SACM
	DCA	SACH
	JMP I	DGT

	END
\f