--- /dev/null
+/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
projects / pdp8.git / blobdiff