Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0072/scat2.mac
There are 2 other files named scat2.mac in the archive. Click here to see a list.
TITLE SCAT2 STANDARD COMPLEX ALGEBRA TRANSLATER V.2.
SUBTTL ACCUMULATOR DEFINITIONS
TWOSEG
VCODE==1
VMAJOR==2
VMINOR==3
VEDIT==62
T0==0 ;TEMPORARY ACS FOR LOCAL USE
T1==1
T2==2
T3==3
T4==4
T5==5
G1==6 ;GLOBALS FOR PASSING ARGS BETWEEN S/R'S
G2==7
G3==10 ;COUNT ON LINE
A1==11 ;ARITHMETIC REGISTERS
A2==12
A3==13
A4==14
PS1==15 ;STACK POINTERS
PS2==16
PSB==17
L==16 ;LINK REGISTER
F1==A1 ;FLAGS NEEDED DURING DECODING
F2==A2
T6==A4 ;EXTRA TEMP NEEDED DURING DECODING
INTERN .JBVER
.JBVER==137
LOC .JBVER
BYTE (3)VCODE(9)VMAJOR(6)VMINOR(18)VEDIT
RELOC 0
RELOC 400000
PAGE
SUBTTL INITIALISATION
START: RESET
MOVE PSB, [IOWD 100, SUBSTK]
SETZM VARTAB ;ZERO VARTAB TO IMAG
MOVE T0, [XWD VARTAB,VARTAB+1]
BLT T0, S1-1
OUTSTR [ASCIZ /SCAT (26-MAR-74) READY
/]
PAGE
SUBTTL NEW COMMAND INITIALISATION
NEWCOM: SETZM S1 ;ZERO S1 TO WFROM
MOVE T0, [XWD S1, S1+1]
BLT T0, WFROM
SETZ G3, G3 ;ZERO LINE COUNT
MOVE F1, [23,,23] ;SET CHECK FLAGS
JFCL 17, .+1 ;CLEAR ERROR FLAGS
MOVE PS1, [IOWD 100, S1] ;SET UP STACK POINTERS
MOVE PS2, [IOWD 100, S2]
MOVE PSB, [IOWD 100, SUBSTK]
OUTCHR ["*"] ;INDICATE READY
ADDI G3, 1 ;POSITION ON LINE
PAGE
SUBTTL INPUT AND DECODING
INNOC: PUSHJ PSB, GETCHR ;HERE IF NO CHAR READY
INMITC: ;HERE IF ALREADY HAVE CHAR
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+5 ;NO
CAIL T0, "A" ;IS IT A LETTER?
CAILE T0, "Z"
SKIPA ;NO
JRST LETTER ;YES A LETTER
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+3 ;NO
CAIN T0, "(" ;COMPLEX NO.?
JRST CNUMBR ;YES
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+9 ;NO
CAIE T0, "*" ;AN OPERATOR?
CAIN T0, "/"
JRST OPR ;YES *,/
CAIE T0, "+"
CAIN T0, "-"
JRST OPR ;YES +,-
CAIN T0, "^"
JRST OPR ;YES ^
TRNN T0, 777626
JRST OPR
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+3 ;NO
CAIN T0, "_" ;ASSIGNMENT?
JRST ASSIGN
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+3 ;NO
CAIN T0, "[" ;BRACE?
JRST BRACE ;YES
PUSHJ PSB, SKCHCK ;IS THIS ONE WANTED
JRST .+3
CAIN T0, "]" ;LAST CHANCE
JRST BACBRA ;WHEW
JRST PROCIG ;NAUGHTY, NAUGHTY
PAGE
SUBTTL PROCESS EACH TYPE OF INPUT
; A VARIABLE NAME **********
LETTER: PUSHJ PSB, CONST ;GET ITS VALUE OR STACK IT
PUSH PS2, G2 ;NO ASSIGNMENT
PUSH PS2, G1 ;ASSIGNMENT - IMAG PART
MOVE F1, [54,,54]
JRST INMITC ;BACK FOR NEXT PROCESS
; A COMPLEX PAIR **********
CNUMBR: PUSHJ PSB, RCPAIR ;GET ITS VALUE
PUSH PS2, G1 ;REAL PART
PUSH PS2, G2 ;IMAG PART
MOVE F1, [44,,44]
JRST INNOC ;NEXT ONE
; AN OPERATOR **********
OPR: TLNE PS1, 77 ;IS S1 EMPTY?
JRST NOTEMP ;NO
FALLEV: PUSH PS1, T0 ;YES OR LEVEL TEST FALSE
MOVE F1, [23,,23]
JRST OPRET
NOTEMP: PUSHJ PSB, LEV ;IS CHAR LEV .LE. TOP S1
JRST FALLEV ;NO
POP PS1, T1 ;YES
PUSH PS2, T1
JRST OPR ;TRY AGAIN
OPRET: TRNE T0, 777626
JRST INNOC
MOVEI T0, "["
JRST BRACE
;AN OPENING BRACE OR ASSIGNMENT **********
BRACE: PUSH PS1, T0 ;PUT IT AWAY
MOVE F1, [63,,63]
JRST INNOC ;GET NEXT ONE
; ASSIGNMENT **********
ASSIGN: PUSH PS1, T0 ;PUT ON STACK
MOVE F1, [23,,23]
JRST INNOC ;RETURN
; A CLOSING BRACE **********
BACBRA: MOVE F1, [44,,44]
BACB1: TLNN PS1, 77 ;IS S1 EMPTY?
JRST UNB ;YES
POP PS1, T1 ;NO
CAIN T1, "[" ;IS IT [
JRST INNOC ;YES
PUSH PS2, T1 ;NO - PUT IT ON S2
JRST BACB1 ;TRY AGAIN
UNB: HRLI G3, 9 ;UNB PARENTHESES
ADDI G3, 1
JRST ERRH
UNB1: HRLI G3, 9 ;ENTER ERROR HANDLER
HRRZ T5, G3 ; AT ERPRNT
HLRZ T4, G3
MOVE T3, [-1]
JRST ERPRNT
; HERE FOR OTHER CHARACTERS **********
PROCIG: CAIN T0, 12 ;IS IT <LF>
JRST POSFIN ;YES
CAIN T0, " " ;IGNORE BLANKS
JRST BLPRC
CAIN T0, 15 ;IGNORE CR IN ANTICIPATION
JRST INNOC ; OF LF
HRLI G3, 1 ;OTHER IS ILLEGAL
ADDI G3, 1
JRST ERRH ;JUMP TO ERROR HANDLER
BLPRC: LSH F1, ^D-12 ;RESTORE FLAG
HRL F1, F1 ; AND DUPLICATE
JRST INNOC
; HERE FOR END OF POSTFIX STRING **********
POSFIN: TLNN PS1, 77 ;S1 EMPTY
JRST POSTR ;YES
POP PS1, T2 ;NO TRANSFER S1 TO S2
CAIN T2, "[" ;IF [ APPEARS IT
JRST UNB1 ; IS UNBAL.
PUSH PS2, T2
JRST POSFIN ;TRY AGAIN
; TRANSFER WHOLE STRING TO S1
; IN REVERSE ORDER
POSTR: TLNN PS2, 77 ;S2 EMPTY?
JRST PROCES ;YES
POP PS2, T0 ;EXCHANGE
PUSH PS1, T0
JRST POSTR
PAGE
SUBTTL PROCESSING OF POLISH STRING
;
; NOW WE HAVE A POLISH STRING IN S1 TO EXECUTE
;
PROCES: SETZ T1, T1 ;ZERO ACS 0-14
MOVE T0, [XWD T1, T2]
BLT T0, A4
;
; PREPARE TO DO ARITHMETIC
;
TPOP: TLNN PS1, 77 ;S1 EMPTY?
JRST RESOUT ;YES
POP PS1, T0 ;GET TOP CHAR
CAIN T0, "+" ;IS IT +
JRST CPL
CAIN T0, "-" ;IS IT -
JRST CMIN
CAIN T0, "/" ;IS IT /
JRST CDIV
CAIN T0, "*" ;IS IT *
JRST CMUL
CAIN T0, "^" ;IS IT ^
JRST CUP
CAIN T0, "_" ;IS IT _
JRST CASS
HRRZ T1, T0
CAIN T1, 151
JRST FUNCTH
PUSH PS2, T0 ;MUST BE NO.
JRST TPOP
PAGE
SUBTTL DO ARITHMETIC
; DO ADDITION
CPL: PUSHJ PSB, GET4 ;UNSTACK LAST VALUES
FADR A1, A3
FADR A2, A4
PUSHJ PSB, STOR2 ;PUT BACK
JRST TPOP
; DO SUBTRACTION
CMIN: PUSHJ PSB, GET4 ; UNSTACK LAST VALUES
FSBR A1, A3 ; SUBTRACT
FSBR A2, A4
PUSHJ PSB, STOR2 ;RE-STORE
JRST TPOP
; DO MULTIPLICATION
CMUL: PUSHJ PSB, GET4
MOVE T1, A1 ;DO REAL PART
FMPR T1, A3
MOVE T2, A2
FMPR T2, A4
FSBR T1, T2 ;REAL PART IN T1
MOVE T2, A2 ;DO IMAG PART
FMPR T2, A3
MOVE T3, A1
FMPR T3, A4
FADR T2, T3 ;IMAG PART IN T2
MOVE A1, T1 ;PUT THEM AWAY
MOVE A2, T2
PUSHJ PSB, STOR2
JRST TPOP
; DO DIVISION
CDIV: PUSHJ PSB, GET4
MOVE T0, A3 ;GET DIVISOR
FMPR T0, A3 ;SQUARE
MOVE T1, A4
FMPR T1, A4 ;SQUARE
FADR T0, T1 ;ADD
MOVE T1, A1 ;DO REAL PART
FMPR T1, A3
MOVE T2, A2
FMPR T2, A4
FADR T1, T2 ;REAL IN T1
MOVE T2, A2 ;DO IMAG PART
FMPR T2, A3
MOVE T3, A1
FMPR T3, A4
FSBR T2, T3 ;IMAG IN T2
FDVR T1, T0 ;DIVIDE
FDVR T2, T0
MOVE A1, T1 ;AND PUT AWAY
MOVE A2, T2
PUSHJ PSB, STOR2
JRST TPOP
; DO EXPONENTIATION
CUP: PUSHJ PSB, GET4
MOVEM L, SAVL ;SAVE 16
MOVEI L, A3 ;POINTER TO POWER
MOVE T0, A1 ;BASE IN T0,T1
MOVE T1, A2
PUSHJ PSB, CEXP.3## ;SYSTEM ROUTINE
MOVE L, SAVL ;RESTORE L
MOVE A1, T0 ;RESULT IN T0,T1
MOVE A2, T1
PUSHJ PSB, STOR2 ;STORE
JRST TPOP
; DO ASSIGNMENT
CASS: PUSHJ PSB, GET2 ;GET TWO VALUES
POP PS2, T1 ;VAR NAME
PUSHJ PSB, WR6STR ;WRITE O/P
SETOM ASSFLG ;SET FLAG
MOVNI G1, 50 ;COUNTER
ASSLOP: MOVE T0, VARTAB+50(G1) ;SEARCH VARTAB
CAMN T0, T1 ;FOR VARIABLE
JRST ASSFND
JUMPE T0, ASSNFD ;OR NULL
AOJL G1, ASSLOP
MOVEI T5, 0 ;ERROR IF OUT END
MOVEI T4, 7
MOVEI T3, [-1]
JRST ERPRNT
ASSNFD: MOVEM T1, VARTAB+50(G1) ;NEW VARIABLE
ASSFND: MOVEM A1, REAL+50(G1) ;OLD "
MOVEM A2, IMAG+50(G1)
PUSHJ PSB, STOR2
JRST TPOP
; FUNCTION HANDLER
FUNCTH: PUSHJ PSB, GET2
CAMN T0, ['MAG',,151]
JRST MAG
CAMN T0, ['ANG',,151]
JRST ANG
CAMN T0, ['SNH',,151]
JRST SNH
CAMN T0, ['TNH',,151]
JRST TNH
CAMN T0, ['CSH',,151]
JRST CSH
CAMN T0, ['CAR',,151]
JRST CAR
CAMN T0, ['POL',,151]
JRST POL
ERRFUN: PUSHJ PSB, STOR2
HRRZI T4, 12
SETZ T5, T5
MOVE T3, [-1]
JRST ERPRNT
MAG: JSA L, CABS##
EXP A1
MOVE A1, T0
MOVEI A2, 0
PUSHJ PSB, STOR2
JRST TPOP
ANG: JSA L, ATAN2##
ARG A2
ARG A1
FMPR T0, [57.29577951]
MOVE A1, T0
MOVEI A2, 0
PUSHJ PSB, STOR2
JRST TPOP
SNH: PUSHJ PSB, SINH
PUSHJ PSB, STOR2
JRST TPOP
CSH: PUSHJ PSB, COSH
PUSHJ PSB, STOR2
JRST TPOP
TNH: MOVE A3, A1
MOVE A4, A2
PUSHJ PSB, SINH
EXCH A3, A1
EXCH A4, A2
PUSHJ PSB, COSH
;SINH IN A3,A4
;COSH IN A1,A2
MOVE T0, A3
MOVE T1, A4
MOVEI L, A1
PUSHJ PSB, CFDM.0##
PUSHJ PSB, STOR2
JRST TPOP
SINH: JSA L, CEXP##
EXP A1
MOVE T2, T0
MOVE T3, T1
FMPR A1, [-1.0]
FMPR A2, [-1.0]
JSA L, CEXP##
EXP A1
FSBR T2, T0
FSBR T3, T1
MOVEM T2, A1
MOVEM T3, A2
FDVR A1, [2.0]
FDVR A2, [2.0]
POPJ PSB,
COSH: JSA L, CEXP##
EXP A1
MOVE T2, T0
MOVE T3, T1
FMPR A1, [-1.0]
FMPR A2, [-1.0]
MOVE T2, T0
MOVE T3, T1
JSA L, CEXP##
EXP A1
FADR T0, T2
FADR T1, T3
MOVEM T0, A1
MOVEM T1, A2
FDVR A1, [2.0]
FDVR A2, [2.0]
POPJ PSB,
CAR: JSA L, SIND##
ARG A2
MOVEM T0, T5
JSA L, COSD##
ARG A2
;SIN IN T5, COS IN T0
FMPR T0, A1
FMPR T5, A1
CARRET: MOVEM T0, A1
MOVEM T5, A2
PUSHJ PSB, STOR2
JRST TPOP
POL: JSA L, CABS##
EXP A1
MOVEM T0, T5
JSA L, ATAN2##
EXP A2
EXP A1
FMPR T0, [57.29577951]
EXCH T0, T5
JRST CARRET
PAGE
SUBTTL NOW OUTPUT RESULTS
RESOUT: SKIPGE ASSFLG ;NEED 'RESULT = '
JRST NUMPRT
MOVE T1, [SIXBIT /RESULT/]
PUSHJ PSB, WR6STR
PUSHJ PSB, GET2 ;AND GET RESULTS
NUMPRT: PUSHJ PSB, WCPAIR ;WRITE NUMBER
OUTSTR CRLF
JRST NEWCOM
PAGE
SUBTTL SWITCH HANDLER
SWITCH: MOVE T0, [XWD T1, SAV] ;SAVE ACS
BLT T0, SAV+4
NSW: PUSHJ PSB, INSW ;GET SW CHAR
CAIE T0, 33 ;ESCAPE OR
CAIN T0, 175 ;ALTMODE - LAST SWITCH
JRST LASTSW
CAIN T0, "D" ;D - DUMP
JRST DUMP
CAIN T0, "E" ;E - EXIT
EXIT
CAIN T0, "R" ;R - RESTART COMMAND
JRST RE
CAIN T0, "Q" ;Q - QUERY ERRORS
JRST QUERY
CAIN T0, "L" ;L - LIST ERRORS AND IMPLICIT R
JRST ERRSW
CAIN T0, "C" ;C - CLEAR ERROR COUNT
JRST ECLR
CAIN T0, "H" ;H - HELP
JRST HELP
CAIN T0, "X" ;X SWITCH - DELETE VARIABLES
JRST DELVAR
; UNRECOGNIZED SWITCH **********
OUTSTR [ASCIZ /
UNRECOGNIZED SWITCH /]
OUTCHR T0
HRRI G3, ^D36
NSMES: OUTSTR [ASCIZ /, NEXT SWITCH $/]
JRST NSW
; LAST SWITCH **********
LASTSW: OUTSTR [ASCIZ /
CONTINUE, NOTHING HAS BEEN CHANGED
/]
LASTNO: MOVE T0, [XWD SAV, T1]
BLT T0, T5 ;RESTORE ACS
PUSHJ PSB, GETCHR
POPJ PSB, ;RETURN
; ERROR QUERY **********
QUERY: HLRZ T1, G3 ;GET ERROR COUNT
JUMPE T1, QNO ;NO ERRORS
OUTSTR [ASCIZ /
ERRORS/] ;THERE ARE SOME
HRRI G3, ^D21
JRST NSMES
QNO: OUTCHR ["$"] ;TERMINATE SWITCH LIST
ADDI G3, 1
JRST LASTNO ;AND RETURN AS THO NOTHING HAPPENED
; DUMP OF VARIABLES **********
DUMP:
SKIPE VARTAB ;ANY DEFINED?
JRST DNO1 ;YES
OUTSTR [ASCIZ /
NO VARIABLES DEFINED/] ;NO
JRST NSMES
DNO1: SETZ G1, G1 ;ZERO INDEX
DNO2: OUTSTR CRLF ;NEXT LINE
MOVE T1, VARTAB(G1) ;GET NEXT NAME
JUMPE T1, DEND ;NULL IS END
PUSHJ PSB, WR6STR ;WRITE NAME
MOVE A1, REAL(G1);AND VALUES
MOVE A2, IMAG(G1)
PUSHJ PSB, WCPAIR
AOJA G1, DNO2 ;LOOP FOR NEXT
DEND: OUTSTR [ASCIZ /
NOW/]
JRST NSMES
; CLEAR ERROR COUNT **********
ECLR: HRLI G3, 0
OUTSTR [ASCIZ /
ERRORS CLEARED/]
HRRI G3, ^D29
JRST NSMES
; HELP - HELP TEXT **********
HELP: OUTSTR [ASCIZ /
SWITCHES ARE:
=============
C - CLEAR ERROR COUNT, COMMAND CONTINUED
D - DUMP ALL VARIABLES AND VALUES ASSIGNED TO DATE
E - EXIT
H - TYPE THIS TEXT/]
OUTSTR [ASCIZ /
L - LIST ERRORS AND IMPLICIT R
Q - QUERY IF ERRORS EXIST
R - RESTART COMMAND/]
OUTSTR [ASCIZ /
X - DELETE VARIABLES
<ALT>- TERMINATES SWITCH LIST
NOW/]
HRRI G3, ^D18
JRST NSMES
; ERROR LIST **********
ERRSW: HLRZ T1, G3
JUMPE T1, QNO
OUTSTR CRLF
HRRZ T5, G3
HLRZ T4, G3
MOVE T3, [-1]
JRST ERPRNT
; RESTART COMMAND **********
RE: OUTSTR CRLF
JRST NEWCOM
; DELETE VARIABLES **********
DELVAR: OUTSTR [ASCIZ /
CONFIRM: /]
MOVEI G3, 9
PUSHJ PSB, INSW
CAIE T0, "*" ;WANT ALL?
JRST DELSOM
; CLEAR ALL
MOVE T0, [XWD VARTAB,VARTAB+1]
SETZM VARTAB
BLT T0, S1-1 ;BLT 0 TO ALL
OUTSTR [ASCIZ /
ALL CLEARED/]
MOVEI G3, 26
JRST NSMES
;CLEAR ONLY SOME
DELSOM: MOVE T1, [POINT 6,T2] ;DECODE NAME
MOVE T3, [-6] ;CHAR CNT
SETZ T2, T2 ;ZERO RECEPTOR
DELS1: CAIG T0, "Z" ;FIRST CHAR A-Z
CAIGE T0, "A"
SKIPA
JRST DELLEG ;LEGAL
CAIG T0, "9"
CAIGE T0, "0"
SKIPA
JRST DELLEG
CAIE T0, ","
JRST CRTEST
SETZM NLETT
PUSHJ PSB, DELEND ;DEL VAR IN T2
JRST DELSOM
CRTEST: CAIE T0, 15 ;IGNORE CR
JRST LFTEST
PUSHJ PSB, INSW
JRST DELS1
LFTEST: CAIN T0, 12 ;END OF LINE
JRST DELFIN
HRLI G3, 1
JRST ERRH
DELLEG: SUBI T0, 40 ;HERE TO DECODE VARIABLE NAME
IDPB T0, T1 ;PUT CHAR AWAY
PUSHJ PSB, INSW
AOJLE T3, DELS1 ;RETURN WITH CHAR
HRLI G3, 2 ;ERROR
JRST ERRH
DELEND: MOVNI T1, 50
DELEN1: CAMN T2, VARTAB+50(T1)
JRST DELFND
SKIPE VARTAB+50(T1)
AOJL T1, DELEN1
HRLI G3, 3
JRST ERRH
DELFND: MOVE T0, [-1]
MOVEM T0, VARTAB+50(T1)
SKIPL NLETT
PUSHJ PSB, INSW
POPJ PSB,
DELFIN: JUMPE T2, SHUFFL
SETOM NLETT
PUSHJ PSB, DELEND ;PUT AWAY PRESENT ONE FIRST
SHUFFL: MOVNI T5, 50 ;AND SHUFFLE
MOVE T4, [-1]
SHUFF1: SKIPN VARTAB+50(T5)
JRST SHUFIN
CAMN T4, VARTAB+50(T5)
JRST SHUFMK
SHFRET: AOJL T5, SHUFF1
JRST SHUFIN
SHUFMK: MOVE T3, T5
SHFMK1: SKIPN VARTAB+51(T3)
JRST SHFMK2
MOVE T1, VARTAB+51(T3)
MOVEM T1, VARTAB+50(T3)
MOVE T1, REAL+51(T3)
MOVEM T1, REAL+50(T3)
MOVE T1, IMAG+51(T3)
MOVEM T1, IMAG+50(T3)
CAMGE T3, [-2]
AOJA T3, SHFMK1
SHFMK2: SETZM VARTAB+50(T3)
SETZM REAL+50(T3)
SETZM IMAG+50(T3)
JRST SHUFFL
SHUFIN: OUTSTR [ASCIZ /CLEARED/]
JRST NSMES
PAGE
SUBTTL ERROR HANDLER
ERRH: HRRZ T5, G3 ;POSITION OF ERROR
HLRZ T4, G3 ;ERROR TYPE
MOVE T3, [-1] ;CONTROL COUNT
ERRCHR: PUSHJ PSB, GETCHR ;FINISH LINE
CAIE T0, 12 ;<LF> = EOL
JRST ERRCHR ;TRY AGAIN
ERPRNT: CAIGE T5, 25 ;WHAT TO PRINT FIRST
PUSHJ PSB, ARROW ;ARROW TO BE PRINTED
PUSHJ PSB, MESS ;MESSAGE
AOSG T3 ;NEED TO DO ARROW
PUSHJ PSB, ARROW
OUTSTR CRLF
JRST NEWCOM ;NEXT COMMAND
; PRINT MESSAGE **********
MESS: JRST MS(T4) ;OUTPUT APPROPRIATE MESSAGE
MS: JRST E0
JRST E1
JRST E2
JRST E3
JRST E4
JRST E5
JRST E6
JRST E7
JRST E8
JRST E9
JRST E10
E0: OUTSTR [ASCIZ /NO ERRORS YET/]
SUBI T5, ^D13
POPJ PSB,
E1: OUTSTR [ASCIZ /ILL. CHAR. IN INPUT/]
SUBI T5, ^D19
POPJ PSB,
E2: OUTSTR [ASCIZ /TOO MANY CHARS/]
SUBI T5, ^D14
POPJ PSB,
E3: OUTSTR [ASCIZ /UNDEFINED VARIABLE/]
SUBI T5, ^D18
POPJ PSB,
E4: OUTSTR [ASCIZ /DELIMITER EXPECTED/]
SUBI T5, ^D18
POPJ PSB,
E5: OUTSTR [ASCIZ /NO. OUT OF RANGE/]
SUBI T5, ^D16
POPJ PSB,
E6: OUTSTR [ASCIZ /EXP OUT OF RANGE/]
SUBI T5, ^D16
POPJ PSB,
E7: OUTSTR [ASCIZ /TOO MANY VARIABLES/]
SUBI T5, ^D19
POPJ PSB,
E8: OUTSTR [ASCIZ *EXEC OV/UND FLOW*]
SUBI T5, ^D16
POPJ PSB,
E9: OUTSTR [ASCIZ /UNBAL PARENTH/]
SUBI T5, ^D13
POPJ PSB,
E10: OUTSTR [ASCIZ /UDF FCN/]
POPJ PSB,
; PRINT ARROW **********
ARROW: SKIPN T5 ;IF NO ARROW REQD.
POPJ PSB,
SUBI T5, 2 ;AMEND POSITION FOR ARROW
ADDI T3, 1
MOVNS T5, T5
ARR1: OUTCHR [" "]
AOJL T5, ARR1
OUTCHR ["^"]
POPJ PSB,
PAGE
SUBTTL SUBROUTINES
; ROUTINE TO GET A CHARACTER ---------------------------------------------------
GETCHR: INCHRW T0, ;GET THE CHAR
ADDI G3, 1 ;INC CHAR CNT
CAIE T0, 33 ;ESCAPR OR
CAIN T0, 175 ;ALTMODE - SWITCH?
PUSHJ PSB, SWITCH
POPJ PSB, ;NO - SO RETURN
; ROUTINE TO GET A SWITCH ------------------------------------------------------
INSW: INCHRW T0, ;GET THE CHAR
ADDI G3, 1
CAIN T0, " " ;IGNORE BLANKS
JRST INSW
POPJ PSB,
; ROUTINE TO EVALUATE A VARIABLE -----------------------------------------------
CONST: MOVE T5, [POINT 6,T4]
SETZ T4, T4 ;ZERO RECEPTOR
SUBI T0, 40 ;CONV TO SIXBIT AND
IDPB T0, T5 ;PUT AWAY EXISTING CHAR
MOVE T3, [-5] ;GET READY FOR NEXT 5
NEXTCH: PUSHJ PSB, GETCHR ;GET CHAR
CAIL T0, "A" ;IS IT A LETTER
CAILE T0, "Z"
SKIPA ;NO
JRST GOOD ;YES
CAIL T0, "0" ;IS IT A NUMBER
CAILE T0, "9"
JRST LASTCH ;NO
GOOD: AOSLE T3 ;INC CHAR CNT
JRST TOMANY ;TOO MANY
SUBI T0, 40 ;CONV TO 6BIT
IDPB T0, T5 ;PUT IT AWAY
JRST NEXTCH ;NEXT ONE
LASTCH: CAIN T0, "_" ;IS IT _
JRST SKRT ;YES SKIP
CAIN T0, "["
JRST FUNCT
SETZ T5, T5 ;NO GET VALUES
NVAR: MOVE T1, VARTAB(T5) ;GET NEXT VAR
JUMPE T1, NDEF ;IS IT NULL
CAME T1, T4 ;EQUAL?
AOJA T5, NVAR ;NO TRY NEXT ONE
RET: MOVE G1, IMAG(T5) ;GET IMAG
MOVE G2, REAL(T5) ; &REAL PARTS
POPJ PSB, ;RETURN
FUNCT: TRNE T4, 777777
JRST TOMANY
HRRI T4, 151
POP PSB, (PSB)
MOVE T0, T4
JRST INMITC
SKRT: MOVEM T4, G1 ;SKIP RETURN
AOS (PSB)
POPJ PSB,
TOMANY: HRLI G3, 2 ;TOO MANY CHARS
ADDI G3, 1
JRST ERRH ;ERROR HANDLER
NDEF: HRLI G3, 3 ;NOT DEFINED
JRST ERRH ;MORE ERRORS
; ROUTINE TO READ A COMPLEX PAIR, WITH THANKS TO R. COOK'S IOLIB V.3. ----------
RCPAIR: SETOM TIME ;INITIATE
MOVE T3, [MOVEM T4,G1]
SETZB G1, G2
RREAL: PUSHJ PSB, GETCHR ;GET FIRST CHAR
PUSHJ PSB, NEGTIV ;PROCESS SIGN
PUSHJ PSB, GETCHR ;IT WAS SIGNED
MOVSI T1, (10.0) ;NOT SIGNED
TDZA T4, T4 ;ZERO RECEPTOR
RRE10: PUSHJ PSB, GETCHR ;GET ACHAR
PUSHJ PSB, CDIGIT ;CONVERT ASCII TO F.P
JRST RRE20 ;NOT A DIGIT
FMPR T4, T1 ;*10
FADR T4, T0 ;ADD NEW NO.
PUSHJ PSB, OFCHK ;CHECK OVERFLOW
JRST RRE10 ;GO BACK FOR NEXT
RRE20: CAIE T0, "." ;CORRECT?
JRST RRE40 ;NO - MAY BE EXPONENT
RRE30: PUSHJ PSB, RDIGIT ;READ AND CONVERT
JRST RRE40 ;NOT A DIGIT
FDVR T0, T1 ;CORRECT FOR DEC PLACE
FADR T4, T0 ;AND ADD
PUSHJ PSB, OFCHK ;CHECK UNDERFLOW
FMPRI T1, (10.0) ;CORRECT MULT FOR DEC PLACE
JRST RRE30 ;NEXT
RRE40: FMPR T4, SIGN ;GET CORR. SIGN
CAIE T0, "E" ;EXPONENT?
JRST RRE60 ;NO
SKIPN T4 ;MANTISSA 1.0 FOR PURE E FORMAT
MOVEI T4, [1.0]
PUSHJ PSB, RDECEX ;YES GET DEC EXPONENT
MOVE T5, [FMPRI T4,(10.0)] ;ASSUME +VE EXP.
SKIPGE T2 ;IS IT REALLY -VE
HRLI T5, (FDVRI T4,) ;YES
MOVMS T2, T2
RRE50: SOJL T2, RRE60 ;APPLY EXP.
XCT T5
PUSHJ PSB, OFCHK ;CHECK IF OVFLW OCCURRED
JRST RRE50
RRE60: CAIN T0, ")" ;END OF NUMBER?
JRST RRE70 ;YES
CAIE T0, "," ;END OF FIRST HALF
JRST RRE80 ;NO - ERROR
RRE61: XCT T3 ;GET IN CORRECT AC
ADDI T3, 1 ;READY FOR NEXT HALF
AOSG TIME ;NO NEXT HALF?
PUSHJ PSB, RREAL ;READ NEXT HALF
RRE63: POPJ PSB, ;POP TWICE TO RETURN
RRE70: JUMPE T4, RRE63 ;) FOUND AFTER 1ST HALF
AOS TIME ;) FOUND DURING FIRST OR SECOND HALF
JRST RRE61
RRE80: HRLI G3, 4 ;ERROR CONDITION
ADDI G3, 1
JRST ERRH
; ROUTINES USED BY RCPAIR ------------------------------------------------------
RDIGIT: PUSHJ PSB, GETCHR ;GET CHAR
CDIGIT: CAIL T0, "0" ;CONVERT IT
CAILE T0, "9" ;IS IT LEGAL?
POPJ PSB, ;NO
SUBI T0, "0" ;CONVERT
FSC T0, 233
AOS (PSB) ;SKIP RETURN
POPJ PSB,
RDECEX: SETZ T2, T2 ;ZERO RECEPTOR
PUSHJ PSB, GETCHR ;GET CHAR
PUSHJ PSB, NEGDEC ;SIGN?
RDEC1: PUSHJ PSB, GETCHR ;YES
CAIL T0, "0" ;NO
CAILE T0, "9" ;IS IT LEGAL
JRST RDEND ;NO
IMULI T2, ^D10 ;MUL * 10
SUBI T0, 60 ;ADD TO NUMBER
ADD T2, T0 ; AFTER CONVERSION
JRST RDEC1 ;GO BACK FOR NEXT
RDEND: IMUL T2, SIGN ;FIX SIGN
CAIG T2, ^D38 ;CHECK EXPONENT SIZE
CAMGE T2, [^D-38]
JRST RDERR
POPJ PSB,
RDERR: HRLI G3, 6
JRST ERRH
POPJ PSB, ;RETURN
NEGDEC: SETOM WFROM ;INDICATES INTEGER
NEGTIV: MOVE T6, [-1] ;ASSUME -VE
AOS (PSB) ;ASSUME SKIP
CAIN T0, "-" ;IS IT -VE
JRST TST ;YES - OK
CAIN T0, "+"
JRST PL ;WHOOPS A +
AOS (PSB) ;ANYTHING ELSE
PL: MOVEI T6, 1 ;RESTORE +
TST: SKIPL WFROM ;NOW SHOULD WE FLOAT
JRST FLOTR ;YES
TSTRET: MOVEM T6, SIGN ;PUT AWAY
SOS (PSB) ;RESTORE CORRECT SKIP
SETZM WFROM ;RESTORE CORRECT ENTRY
POPJ PSB, ;AND RETURN
FLOTR: MOVE T1, T6
IDIVI T1, 400
SKIPE T1
TLC T1, 243000
TLC T2, 233000
FADL T1, T2
MOVE T6, T1
SETZ T2, T2
JRST TSTRET
; ROUTINE TO MAKE LEVEL COMPARISONS --------------------------------------------
LEV: PUSHJ PSB, LEVFND ;FIND CURRENT LEVEL
MOVEM T1, T5 ;PUT LEVEL IN T5
MOVEM T0, T3 ;SAVE T0
POP PS1, T0 ;FIND LEV TOP S1
MOVEM T0, REPLT0 ;STORE FOR POSSIBLE REPLACEMENT
PUSHJ PSB, LEVFND
MOVEM T1, T4 ;PUT LEV S1 IN T4
MOVE T0, T3 ;RESTORE T0
CAMG T5, T4
AOS (PSB) ;SKIP RETURN IF LE
MOVE T3, REPLT0 ;PUT BACK ON STACK
PUSH PS1, T3 ; IF TEST FAILS
POPJ PSB,
LEVFND: MOVEI T4, 11 ;SET UP TABLE SEARCH
FINONE: SOJL T4, NFND
HLRZ T1, LEVTAB(T4) ;GET NEXT CHAR
HRRZ T6, T0
CAME T6, T1
JRST FINONE ;NO
HRRZ T1, LEVTAB(T4) ;YES - GET ITS LEVEL
POPJ PSB, ;RETURN
NFND: MOVEI T1, 7 ;MUST BE CONST OR VAR
POPJ PSB,
;ROUTINE TO TEST FOV & FUND FLOWS ----------------------------------------------
OFCHK: JFOV FOVH ;OF OCCURRED
POPJ PSB, ;NO
FOVH: HRLI G3, 5 ;YES
ADDI G3, 1
JRST ERRH
; ROUTINE TO CHECK IF INPUT DECODING DESIRED -----------------------------------
SKCHCK: IDIVI F1, 2 ;STRIP OFF LOW DIGIT
SKIPE F2 ;IS IT ZERO
AOS (PSB) ;NO
POPJ PSB, ;YES
;
; WR6STR - WRITES A 6BIT STRING IN T1 ------------------------------------------
;
WR6STR: MOVNI T2, 6 ;LOOP COUNTER
MOVE T3, [POINT 6,T1] ;BYTE POINTER
WR6ST1: ILDB T0, T3 ;GET NEXT CHAR
ADDI T0, 40
PUSHJ PSB, WASCII ;AND OUTPUT
AOJL T2, WR6ST1
OUTSTR [ASCIZ / = /] ;FOLLOW BY =
POPJ PSB,
;
; WASCII - WRITES AN ASCII CHAR IN T0 ------------------------------------------
;
WASCII: OUTCHR T0 ;SIMPLY O/P CHAR
POPJ PSB,
;
; WFPNO - WRITE A FLOATING POINT NO IN T1 --------------------------------
; THANKS TO ROB COOK'S IOLIB V.3.
;
WFPNO: SETZB T4, T5 ;INIT EXPS
MOVE T6, [1.0E-7] ;SMALLEST PRINTABLE FRACTION
MOVM T3, T1 ;SAVE NO
JUMPGE T1, WFP1 ;SPACE IF POSVE
MOVEI T0, "-" ;OTHERWISE SIGN
SKIPA
WFP1: MOVEI T0, " "
PUSHJ PSB, WASCII
JUMPE T3, WRE30 ;SPECIAL TEEATMENT FOR 0.0
WRE20: CAMGE T3, [1.0] ;BIGGER THAN RANGE
JRST WRE25
FDVRI T3, (10.0) ;YES - REDUCE
AOJA T5, WRE20 ;AND LOOP
WRE25: CAML T3, [0.1] ;IS IT .LT. 0.1
JRST WRE30 ;NO
FMPRI T3, (10.0) ;YES INC NO.
SOJA T5, WRE25
WRE30: ADDI T3, 1 ;BEAT ROUNDING ERRORS
MOVM T1, T5 ;MOD OF EXPONENT
CAILE T1, 6 ;E FORMAT?
EXCH T4, T5 ;YES
JUMPG T5, WRE40 ;IF EXP .LT.0
MOVEI T0, "0"
PUSHJ PSB, WASCII ;PRECEDE BY 0
JRST WRE50
WRE40: PUSHJ PSB, WDIGIT ;WRITE A DIGIT
SOJG T5, WRE40 ;LOOP FOR ALL INTEGERS
WRE50: MOVEI T0, "." ;DELIMITER
PUSHJ PSB, WASCII
WRE60: JUMPGE T5, WRE70 ;ANY MORE LEADING ZEROES
MOVEI T0, "0" ;YES
PUSHJ PSB, WASCII
AOJA T5, WRE60 ;LOOP FOR MORE
WRE70: PUSHJ PSB, WDIGIT ;WRITE A DIGIT
JUMPN T3, WRE70 ;UNTIL NONE LEFT
SKIPN T4
POPJ PSB, ;FINISH IF NOT WANTED
MOVEI T0, "E" ;SHOW E
PUSHJ PSB, WASCII
MOVE T1, T4 ;SET UP AND
JRST WDECL ;WRITE EXPONENT
WDIGIT: FMPRI T3, (10.0) ;MAKE A DIGIT
FMPRI T6, (10.0) ;* TEST FRACTION
MOVE T1, T3 ;COPY NO
MULI T1, 400 ;SEPARATE EXPON.
ASH T2, -243(T1) ;KEEP TOP DIGIT
MOVEI T0, "0"(T2) ;SET FOR O/P
FSC T2, 233 ;CONVERT DIG TO REAL
FSBR T3, T2 ;REMOVE FROM NO.
PUSHJ PSB, WASCII ;WRITE NO.
CAMG T3, T6 ;BIGGER THAN SMALLEST ALLOWABLE
SETZ T3, T3 ; 8 DIGITS WRITTEN
POPJ PSB,
;
; WDECL - WRITES A DECIMAL INTEGER IN T1 ---------------------------------------
;
WDECL: SETZB T4, T5 ;TO WRITE A DEC EXPONENT
SKIPGE T1 ;NEG?
MOVEI T4, 1 ;YES
MOVM T1, T1 ;GET MAGNITUDE
WD1: IDIVI T1, 12 ;STRIP OFF LOW DIGIT
PUSH PS1, T2 ;STACK IT
JUMPE T1, WPR ;END?
AOJA T5, WD1
WPR: MOVEI T0, "+" ;OP SIGN
SKIPE T4
MOVEI T0, "-"
PUSHJ PSB, WASCII
WP1: POP PS1, T0 ;UNSTACK VALUE
ADDI T0, 60 ;AND PRINT
PUSHJ PSB, WASCII
SOJGE T5, WP1
POPJ PSB,
;
; WCPAIR WRITES A COMPLEX PAIR FROM A1,A2 --------------------------------------
;
WCPAIR: MOVEI T0, "(" ;JUST USE PREVIOUS ROUTINES
PUSHJ PSB, WASCII
MOVE T1, A1
PUSHJ PSB, WFPNO
MOVEI T0, ","
PUSHJ PSB, WASCII
MOVE T1, A2
PUSHJ PSB, WFPNO
MOVEI T0, ")"
PUSHJ PSB, WASCII
POPJ PSB,
; GET4 &GET2 TO UNSTACK VALUES FROM S1 ---------------------------
GET4: POP PS2, A4 ;GET LAST VALUES
POP PS2, A3 ;INTO ARITH REGS
GET2: POP PS2, A2
POP PS2, A1
POPJ PSB,
; STOR2 TO PUT 2 VALUES BACK ON S1 AND TEST FOR OVFLOW-----------------
STOR2: PUSH PS2, A1 ;REAL
PUSH PS2, A2 ;IMAG
PUSHJ PSB, EXOV
POPJ PSB,
; EXOV TO TEST FOR EXECUTION OVFLOWS -----------------------------------
EXOV: JFOV EXER ;OFLOW?
POPJ PSB, ;NO
EXER: MOVEI T5, 0 ;YES
MOVEI T4, 8
MOVEI T3, [-1]
JRST ERPRNT
PAGE
SUBTTL DATA LOCATIONS IN HISEG
LEVTAB: 52,,4 ;*
151,,6 ;SUBR.
57,,4 ;/
53,,3 ;+
55,,3 ;-
136,,5 ;^
137,,2 ;_
133,,2 ;[
135,,1 ;]
DESCR: ASCII /SCAT2/
FILNAM: ASCII /DATFL/
PPN: 111,,132
CRLF: ASCIZ /
/
LIT
RELOC
PAGE
SUBTTL DATA LOCATIONS IN LOSEG
VARTAB: BLOCK 50 ;PREDEFINED VARIABLES
REAL: BLOCK 50 ;REAL PARTS
IMAG: BLOCK 50 ;IMAG PARTS
S1: BLOCK 100 ;TEMP STORAGE STACKS
S2: BLOCK 100
SUBSTK: BLOCK 100 ;S/R LINKAGE
ASSFLG: BLOCK 1 ;ASSIGNMENT FLAG
SIGN: BLOCK 1 ;SIGN HANDLING
TIME: BLOCK 1 ;RECURSIVE S/R TIME CALLED
WFROM: BLOCK 1 ;-VE PROCESSING
SAV: BLOCK 5 ;SAVE ACS
SAVT0: BLOCK 1 ;SAVE T0
REPLT0: BLOCK 1 ;REPLACE T0
SAVL: BLOCK 1 ;SAVE L
NLETT: BLOCK 1
END START