2 SUBTTL PARAMETERS AND TABLE
\r
4 ;***COPYRIGHT 1969, 1970, 1971, 1972, DIGITAL EQUIPMENT CORP., MAYNARD, MASS.***
\r
10 IFNDEF PURESW,<PURESW==1>
\r
12 ;CONDITIONAL ASSEMBLY PARAMETERS
\r
13 ; THE VERSION OF BASIC SUPPLIED BY APPLIED LOGIC CORPORATION
\r
14 ; IS ASSEMBLED WITH THE PARAMETERS BELOW SET TO -1. APPLIED
\r
15 ; LOGIC CORPORATION HAS NOT NECESSARILY TESTED VERSIONS OF
\r
16 ; BASIC ASSEMBLED OTHERWISE AND DOES NOT GUARANTEE TO
\r
17 ; MAINTAIN ANY SUCH VERSIONS.
\r
19 FTRND=-1 ;-1 IF RANDOM FACILITY, ELSE 0
\r
20 FTMAT=-1 ;-1 IF MATRIX FACILITY, ELSE 0
\r
21 FTSTR=-1 ;-1 IF STRING FACILITY, ELSE 0
\r
23 IFE PURESW,< RELOC >
\r
24 IFN PURESW,< HISEG >
\r
29 N=0 ;RUNTIME ACCUMULATOR REGISTER
\r
30 T=1 ;POINTER TO NXCH
\r
32 A=3 ;SEARCH ARGUMENT
\r
33 B=4 ;POINTER AFTER SEARCH
\r
34 C=5 ;XWD CHARACTER-FLAGS,CHAR
\r
35 D=6 ;BUILD INSTS HERE
\r
39 R=12 ;POINTER TO ROLL BEING USED
\r
42 Q=15 ;PUSHDOWN LIST FOR FNX ARGS.
\r
49 Z XCHAN+60000(SIXBIT / CHA/)
\r
50 Z XDATA+40000(SIXBIT / DAT/)
\r
51 Z XDEF+40000(SIXBIT / DEF/)
\r
52 Z XDIM+0(SIXBIT / DIM/)
\r
53 Z XEND+0(SIXBIT / END/)
\r
54 Z XFNEND+60000(SIXBIT / FNE/)
\r
55 Z XFOR+20000(SIXBIT / FOR/)
\r
56 Z XGOSUB+60000(SIXBIT / GOS/)
\r
57 Z XGOTO+60000(SIXBIT / GOT/)
\r
58 Z XIF+20000(SIXBIT / IF /)
\r
59 Z XINPUT+60000(SIXBIT / INP/)
\r
60 Z XLET+20000(SIXBIT / LET/)
\r
62 Z XMAT+20000(SIXBIT / MAT/)
\r
64 Z XNEXT+60000(SIXBIT / NEX/)
\r
65 Z XON+20000(SIXBIT / ON /)
\r
66 Z XPRINT+60000(SIXBIT / PRI/)
\r
68 Z XRAN+60000(SIXBIT / RAN/)
\r
70 Z XREAD+60000(SIXBIT / REA/)
\r
71 Z NXTST1+0(SIXBIT / REM/)
\r
72 Z XREST+40000(SIXBIT / RES/)
\r
73 Z XRETRN+60000(SIXBIT / RET/)
\r
74 Z XSTOP+40000(SIXBIT / STO/)
\r
76 \f;TABLE OF BASIC COMMANDS
\r
79 EXP SIXBIT /A/ + 'A'ER + 'B'0000>
\r
95 \f;CHARACTER TYPE TABLE.
\r
96 ;FLAGS IN LEFT HALF OF CTTAB+<LETTER> FOR <LETTER> BELOW 100,
\r
97 ;FLAGS IN RIGHT HALF OF CTTAB+<LETTER-100> OTHERWISE.
\r
99 DEFINE WWW (FL,VAL)<
\r
106 WWW F.CR,1B2 ; <RETURN, OR LF,VT,FFEED>
\r
107 WWW F.DIG,1B3 ; <NUMERAL>
\r
110 WWW F.ESC,1B5 ; <ESCAPE OR ALTMODE>
\r
111 WWW F.LCAS,1B6 ; <LOWER CASE LETTER>
\r
112 WWW F.LETT,1B7 ; <LOWER OR UPPER CASE LETTER>
\r
116 WWW F.PLUS,1B11 ; +
\r
117 WWW F.QUOT,1B12 ; "
\r
118 WWW F.RPRN,1B13 ; )
\r
119 WWW F.SLSH,1B14 ; /
\r
120 WWW F.STAR,1B15 ; *
\r
121 WWW F.SPTB,1B16 ; <SPACE OR TAB>
\r
123 F.NU=0 ;ASCII CODES THAT ARE TREATED AS NULLS.
\r
124 F.OTH=0 ;OTHER CHARACTERS ANALYSED BY BASIC WITHOUT THE USE OF FLAGS.
\r
126 F.TERM=F.CR+F.APOS ;EITHER TERMINATES THE ANALYZABLE PORTION OF A BASIC STATEMENT.
\r
129 XWD F.NU, F.STR ;NULL , @
\r
130 XWD F.STR, F.LETT ; , A
\r
131 XWD F.STR, F.LETT ; , B
\r
132 XWD F.STR, F.LETT ; , C
\r
133 XWD F.STR, F.LETT ; , D
\r
134 XWD F.STR, F.LETT ; , E
\r
135 XWD F.STR, F.LETT ; , F
\r
136 XWD F.STR, F.LETT ; , G
\r
137 XWD F.STR, F.LETT ; , H
\r
138 XWD F.SPTB, F.LETT ;TAB , I
\r
139 XWD F.CR, F.LETT ;LF , J
\r
140 XWD F.CR, F.LETT ;VER.TAB, K
\r
141 XWD F.CR, F.LETT ;FFEED , L
\r
142 XWD F.CR, F.LETT ;CR , M
\r
143 XWD F.STR, F.LETT ; , N
\r
144 XWD F.STR, F.LETT ; , O
\r
145 XWD F.STR, F.LETT ; , P
\r
146 XWD F.STR, F.LETT ; , Q
\r
147 XWD F.STR, F.LETT ; , R
\r
148 XWD F.STR, F.LETT ; , S
\r
149 XWD F.STR, F.LETT ; , T
\r
150 XWD F.STR, F.LETT ; , U
\r
151 XWD F.STR, F.LETT ; , V
\r
152 XWD F.STR, F.LETT ; , W
\r
153 XWD F.STR, F.LETT ; , X
\r
154 XWD F.STR, F.LETT ; , Y
\r
155 XWD F.STR, F.LETT ; , Z
\r
156 XWD F.ESC, F.STR ;ESC , [
\r
157 XWD F.STR, F.STR ; , \
\r
158 XWD F.STR, F.STR ; , ]
\r
159 XWD F.STR, F.OTH ; , ^
\r
160 XWD F.STR, F.OTH ; , _
\r
161 \f XWD F.SPTB, F.STR ;SPACE , <ACCENT GRAVE>
\r
162 XWD F.STR, F.LETT+F.LCAS ; ! , <LOWER CASE> A
\r
163 XWD F.QUOT, F.LETT+F.LCAS ; " , <LOWER CASE> B
\r
164 XWD F.STR, F.LETT+F.LCAS ; # , <LOWER CASE> C
\r
165 XWD F.DOLL, F.LETT+F.LCAS ; $ , <LOWER CASE> D
\r
166 XWD F.STR, F.LETT+F.LCAS ; % , <LOWER CASE> E
\r
167 XWD F.OTH, F.LETT+F.LCAS ; & , <LOWER CASE> F
\r
168 XWD F.APOS, F.LETT+F.LCAS ; ' , <LOWER CASE> G
\r
169 XWD F.OTH, F.LETT+F.LCAS ; ( , <LOWER CASE> H
\r
170 XWD F.RPRN, F.LETT+F.LCAS ; ) , <LOWER CASE> I
\r
171 XWD F.STAR, F.LETT+F.LCAS ; * , <LOWER CASE> J
\r
172 XWD F.PLUS, F.LETT+F.LCAS ; + , <LOWER CASE> K
\r
173 XWD F.COMA, F.LETT+F.LCAS ; , , <LOWER CASE> L
\r
174 XWD F.MINS, F.LETT+F.LCAS ; - , <LOWER CASE> M
\r
175 XWD F.PER, F.LETT+F.LCAS ; . , <LOWER CASE> N
\r
176 XWD F.SLSH, F.LETT+F.LCAS ; / , <LOWER CASE> O
\r
177 XWD F.DIG, F.LETT+F.LCAS ; 0 , <LOWER CASE> P
\r
178 XWD F.DIG, F.LETT+F.LCAS ; 1 , <LOWER CASE> Q
\r
179 XWD F.DIG, F.LETT+F.LCAS ; 2 , <LOWER CASE> R
\r
180 XWD F.DIG, F.LETT+F.LCAS ; 3 , <LOWER CASE> S
\r
181 XWD F.DIG, F.LETT+F.LCAS ; 4 , <LOWER CASE> T
\r
182 XWD F.DIG, F.LETT+F.LCAS ; 5 , <LOWER CASE> U
\r
183 XWD F.DIG, F.LETT+F.LCAS ; 6 , <LOWER CASE> V
\r
184 XWD F.DIG, F.LETT+F.LCAS ; 7 , <LOWER CASE> W
\r
185 XWD F.DIG, F.LETT+F.LCAS ; 8 , <LOWER CASE> X
\r
186 XWD F.DIG, F.LETT+F.LCAS ; 9 , <LOWER CASE> Y
\r
187 XWD F.OTH, F.LETT+F.LCAS ; : , <LOWER CASE> Z
\r
188 XWD F.OTH, F.STR ; ; , <LEFT BRACE>
\r
189 XWD F.OTH, F.STR ; < , <VERTICAL BAR>
\r
190 XWD F.EQAL, F.STR ; = , <RIGHT BRACE>
\r
191 XWD F.OTH, F.STR ; > , <TILDE>
\r
192 XWD F.STR, F.STR ; ? , <RUBOUT>
\r
193 \fDEFINE FAIL (A,AC)<
\r
195 XWD 001000+AC'00,[ASCIZ /A/]
\r
199 %OPD=1 ;OPDEF UUO COUNTER
\r
202 IFG %OPD-37,<PRINTX <TOO MANY UUO'S>>
\r
203 OPDEF A [<%OPD>B8]>
\r
241 UUOHAN: PUSH P,UUOH ;RETURN ADDRS ON PUSH-DOWN LIST
\r
242 LDB X1,[POINT 9,40,8]
\r
282 LDB X1,[POINT 4,40,12] ;STRING UUOS USE THE AC FIELD
\r
283 CAILE X1,MASUUO ;AS AN EXTENSION OF THE OPCODE.
\r
293 OPDEF STRIN [STRUUO 1,] ;33040
\r
294 OPDEF STRSTO [STRUUO 2,] ;33100
\r
295 OPDEF STRIF [STRUUO 3,] ;33140
\r
296 OPDEF STOCHA [STRUUO 4,] ;33200
\r
297 OPDEF VECFET [STRUUO 5,] ;33240
\r
298 OPDEF VECPUT [STRUUO 6,] ;33300
\r
299 >;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY
\r
300 \f;TABLE OF INTRINSIC FUNCTIONS
\r
303 Z ABSB+0(SIXBIT / ABS/)
\r
304 Z ATANB+0(SIXBIT / ATN/)
\r
305 Z COSB+0(SIXBIT / COS/)
\r
306 Z COTB+0(SIXBIT / COT/)
\r
307 Z DETB+40000(SIXBIT / DET/)
\r
308 Z EXPB+0(SIXBIT / EXP/)
\r
309 Z INTB+0(SIXBIT / INT/)
\r
310 Z LOGB+0(SIXBIT / LOG/)
\r
311 Z NUMB+40000(SIXBIT / NUM/)
\r
313 Z RANB+40000(SIXBIT / RND/)
\r
315 Z SGNB+0(SIXBIT / SGN/)
\r
316 Z SINB+0(SIXBIT / SIN/)
\r
317 Z SQRTB+0(SIXBIT / SQR/)
\r
318 Z TANB+0(SIXBIT / TAN/)
\r
321 \f;TABLE OF RELATIONS FOR IFSXLA
\r
326 RELFLO: ZZZ. 3435B11,CAML
\r
354 BASI1: PUSHJ P,TTYIN ;SET UP BUFFERS AND INIT TTY
\r
358 ASKNEW: PUSHJ P,INLMES
\r
362 MOVEI X1,OVFLCM ;IGNORE OVFLOW DURING COMMANDS.
\r
364 MOVEI X1,10 ;SETUP ARITH OVFLOW TRAP
\r
365 CALL X1,[SIXBIT /APRENB/]
\r
367 MOVEM X1,TOPSTG ;EDIT TIME. ONLY TXTROL IS STODGY.
\r
369 MOVE T,CELIN ;CLOBBER ALL COMPILE ROOLS WITH "CELIN"
\r
370 MOVEI X1,LINROL ;PROTECT TXTROL +LINROL FROM CLOBBER:
\r
373 ;MAIN LOOP FOR EDITOR/MONITOR
\r
375 MAINLP: MOVE P,PLIST
\r
376 PUSHJ P,LOCKOF ;TURN OFF REENTR LOCK
\r
377 PUSHJ P,INLINE ;READ A LINE
\r
378 PUSHJ P,GETNUM ;LOOK FOR SEQUENCE NO
\r
379 JRST COMMAN ;NONE. GO INTERPRET COMMAND
\r
380 SKIPN CURNAM ;MAKE SURE THERE IS A CURRENT FILE NAME
\r
383 ;HERE, WE HAVE SEQUENCED LINE INPUT. NUMBER IS IN N,
\r
384 ;POINTER TO FIRST CHAR AFTER NUMBER IS IN T
\r
394 COMMAN: MOVEI R,CMDROL
\r
395 TLNE C,F.TERM ;TEST FOR NULL COMMAND
\r
397 PUSHJ P,SCNLT1 ;SCAN COMMAND
\r
399 JRST COMM1 ;SECOND CHAR NOT A LETTER
\r
401 JRST COMM1 ;THIRD CHAR NOT A LETTER
\r
403 ;NOW THE FIRST THREE LETTERS OF THE COMMAND ARE PACKED IN LH OF A.
\r
405 PUSHJ P,SEARCH ;LOOK FOR COMMAND
\r
406 JRST COMM1 ;NOT FOUND
\r
414 COM1: TRZN X1,40000
\r
420 ;DELETE (DEL) ROUTINE
\r
431 DELL1: MOVE A,FLLIN ;FIND FIRST LINE TO DELETE
\r
432 DELL2: CAML A,CELIN
\r
433 POPJ P, ;TEHRE IS NONE
\r
434 HLRZ N,(A) ;GET LINE NO
\r
435 CAMLE N,LASTLN ;DONE?
\r
454 GETT1: PUSHJ P,INLINE+1
\r
464 ;LENGTH OF PROGRAM IN CORE.
\r
475 ASCIZ / CHARACTERS/
\r
479 \f;ROUTINE TO LIST FILE
\r
482 SETZI F, ;ASSUME NO HEADINER DESIRED.
\r
485 SETOI F, ;HEADER IS DESIRED, OR CMD ERROR
\r
487 JUMPE F,LIST1 ;SKIP HEADING-
\r
488 PUSHJ P,INLMES ;NO, PRINT IT.
\r
492 PUSHJ P,LIST01 ;TYPE THE HEADING
\r
493 PUSHJ P,INLMES ;AND A FEW BLANK LINES
\r
500 LIST01: PUSH P,T ;SAVE POINTER TO INPUT LINE
\r
501 PUSH P,C ;SAVE CURRENT CHAR.
\r
503 CAIN T,(SIXBIT /DSK/) ;PRINT DEVICE ONLY IF UNCOMMON.
\r
507 PUSHJ P,PRNSIX ;PRINT THE DEVICE NAME
\r
508 LIST02: MOVE T,CURNAM
\r
510 HLRZ T,CUREXT ;DONT PRINT EXT. UNLESS UNCOMMON
\r
511 CAIN T,(SIXBIT /BAS/)
\r
513 TLO T,16 ;INSERT SIXBIT "." BEFORE EXT
\r
515 LIST03: PUSHJ P,TABOUT ;EXECUTE A FORMAT ","
\r
516 CALL X2,[SIXBIT /TIMER/]
\r
519 MOVEI A,":" ;THE SEPARATION CHAR BETWEEN FIELDS.
\r
521 PUSHJ P,TABOUT ;ANOTHER FORMAT ","
\r
522 CALL X2,[SIXBIT /DATE/]
\r
536 LIST1: MOVE A,FLLIN
\r
537 LIST2: CAML A,CELIN
\r
545 MOVEI D,15 ;QUOTE CHAR
\r
553 NEWER: SETZM OLDFLA ;FLAG WOULD BE -1 FOR "OLD" REQUEST.
\r
557 OLDER: SETOM OLDFLA
\r
560 NEWOLD: PUSHJ P,INLMES
\r
561 ASCIZ /FILE NAME--/
\r
574 NEWOL3: LOOKUP FILDIR
\r
576 NEWOL2: MOVE C,[XWD F.CR,15]
\r
579 PUSHJ P,NAMOVE ;ACCEPT NEW CURRENT FILNAME
\r
583 JRST GETT2 ;OLD FILE. FINISH BY GETTING IT.
\r
585 ;ROUTINE TO CHANGE CURRENT NAME
\r
588 TLNN C,F.TERM ;IS THERE A NAME TO RENAME TO?
\r
590 PUSHJ P,INLMES ;PROMPT USER FOR A NAME
\r
591 ASCIZ /FILE NAME--/
\r
593 PUSHJ P,INLINE ;THERE BETTER BE A NAME NOW.
\r
594 RENA1: PUSHJ P,FILNAM ;REQUEST FOR NEW FILE
\r
595 JUMP CURDEV ;SAVE DEVICE IN CURNAM
\r
598 PUSHJ P,NAMOVE ;SET CURINFO FROM FILDIR
\r
600 ;ROUTINE TO SAVE NEW COPY OR AN OLD FILE
\r
601 REPER: ASCIZ /LACE/
\r
604 \f;ROUTINE TO RENUMBER THE BASIC PROGRAM THAT IS IN CORE.
\r
606 ; RESEQUENCE NN,MM,LL
\r
607 ;WHERE NN IS THE FIRST NUMBER AND LL IS THE STEP VALUE.
\r
608 ;IF OMITTED, LL, OR BOTH NUMBERS=10
\r
610 ;ALL LINE NUMBERS LESS THAN MM WILL NOT BE RESEQUENCED. MM MUST NOT
\r
611 ;BE GREATER THAN NN
\r
613 ;A NUMBER IS A LINE NUMBER IF:
\r
614 ;IT IS THE FIRST ATOM ON A LINE.
\r
615 ; IT FOLLOWS AN ATOM BEGINNING WITH THE LETTERS:
\r
616 ; "GOS" OR "GOT" OR "THE"
\r
617 ;ALSO, AFTER THE ATOM "GOTO" HAS BEEN IDENTIFIED, THE NUMBER
\r
619 ;FOLLOWING A COMMA IS A LINE NUMBER.
\r
620 ;REENTRY IS NOT ALLOWED DURING "RESEQUENCE".
\r
622 RESER: ASCIZ /EQUENCE/
\r
624 MOVE LASTLN ;GET THE SECOND NUMBER(::=LOWEST)
\r
626 MOVEI N,^D10 ;IF FIRST ARG=0, ASSUME FIRST LINE=10
\r
629 TLNN C,F.COMA ;IS THERE A THIRD ARG (THE INCREMENT)?
\r
630 JRST RES1 ;NO. LET INCREMENT =^D10
\r
634 RES1: MOVEM N,LASTLN
\r
635 HRLZ A,LOWEST ;SEARCH FOR FIRST LINE TO CHANGE
\r
639 CAMN B,FLLIN ;RESEQ ALL LINES?
\r
641 HLRZ N,-1(B) ;NO. MAKE SURE LINE ORDER WILL NOT CHANGE
\r
645 ADD X2,CELIN ;THIS IS THE NUMBER OF LINES TO RESEQ
\r
651 PUSHJ P,LOCKON ;DONT ALLOW REENTRY.
\r
652 MOVE E,CELIN ;COMPUTE NUMBER OF LINES
\r
654 JUMPE E,UXIT ;NOTHING TO RENUMBER
\r
660 PUSH P,LP ;SAVE LP FOR SECOND LOOP.
\r
664 ;THE LOOP THAT COPIES EACH LINE FOLLOWS:
\r
665 SEQ2: MOVE D,[POINT 7,LINB0] ;BUILD EACH LINE IN LINB0. THEN RESINSERT IT.
\r
670 HRLI T,440700 ;POINTER TO OLD LINE IS IN G
\r
671 ;F USED AS A FLAG REGISTER FOR " ' ETC.
\r
673 REST.F=1 ;COPY THE REST (APOST SEEN)
\r
674 TOQU.F=2 ;COPY TO QUOTE SIGN
\r
675 COMM.F=4 ;LINE NUMBER FOLLOWS ANY COMMA
\r
676 NUM.F=10 ;NEXT NUMBER IS LINE NUMBER
\r
678 \f;THE CHARACTER/ATOM LOOP:
\r
679 SEQ3: PUSHJ P,NXCHS ;GET NEXT CHAR, EVEN IF SPACE OR TAB
\r
682 TLNE C,F.QUOT ;TEST FOR QUOTE CHAR
\r
683 TLCA F,TOQU.F ;REVERSE QUOTE SWITCH AND COPY THIS CHAR
\r
687 TLOA F,REST.F ;APOST SEEN, COPY REST
\r
690 MOVE G,T ;SAVE POINTER
\r
691 TLNN F,NUM.F ;EXPECTING A LINE NUMBER?
\r
692 JRST SEQ4 ;NO. LOOK FOR KEYW ATOMS
\r
696 SEQ4: TLNE F,COMM.F
\r
699 TLO F,NUM.F ;THIS COMMA IMPLIES NUMBER TO FOLLOW
\r
701 SEQ5: PUSHJ P,ALPHSX ;PUT NEXT ALL-LETTER ATOM IN A
\r
702 MOVEI B,SEQTND-SEQTBL ;SET INDEX FOR TABLE OF KEYWORDS PRECEDIING LINE NUMBERS
\r
703 MOVE T,G ;RESET CHAR POINTER TO START OF ATOM.
\r
705 TLOA F,NUM.F+COMM.F ;WE FOUND A KEYBOARD
\r
708 SEQCPY: IDPB C,SEQPNT
\r
711 SEQTBL: SIXBIT /GOSUB/
\r
713 SEQTND: SIXBIT /THEN/
\r
715 SEQNUM: PUSH P,G ;SAVE POINTER IN CASE OF "GLOBAL" LINE NUMBER
\r
719 JRST SEQT1 ;DONT RESEQ THIS NUMBER
\r
727 ADD B,FRSTLN ;THIS IS THE NEW LINE NUMBER
\r
729 PUSHJ P,MAKNUM ;DEPOSITE THE NUMBER IN LINB0
\r
730 POP P,X1 ;CLEAR PLIST A LITTLE
\r
747 SEQCR: IDPB C,SEQPNT
\r
749 PUSHJ P,ERASE ;ERASE OLD LINE COPY
\r
750 MOVE T1,SEQPNT ;POINT TO END OF LINE FOR NEWLIN
\r
751 PUSHJ P,NEWLIN ;INSERT NEW ONE WITH OLD LINE NUMBER
\r
752 AOBJN LP,SEQ2 ;DO NEXT LINE
\r
759 JRST N,UXIT ;FINISHED. ALLOW REENTRY.
\r
761 SEQOV: PUSHJ P,INLMES
\r
762 ASCIZ /COMMAND ERROR (LINE NUMBERS MAY NOT EXCEED 99999)
\r
765 \f;ROUTINE TO SAVE PROGRAM
\r
768 SETZM OLDFLA ;SAVE "NEW" FILE ONLY
\r
769 SAVFIL: PUSHJ P,FILNAM
\r
780 SAVE1: LOOKUP FILDIR
\r
788 \f;ROUTINE TO CLEAR TXTROL.
\r
790 SCRER: ASCIZ /ATCH/
\r
792 SCRER1: MOVE X1,FLTXT ;WIPE OUT LINROL AND TXTROL
\r
798 ;ROUTINE TO RETURN TO THE SYSTEM.
\r
803 \fSUBTTL COMMAND SUBROUTINES
\r
805 ;ROUTINE TO PICK UP FILE NAME AND SET UP FOR DSK ACTION.
\r
806 ;THE FLAG COPFLG IS EXPLAINED AT THE COPY ROUTINE COPER.
\r
809 FILNAM: POP P,B ;COPER ENTERS HERE, WITH COPFLG = -1.
\r
811 FILN7: PUSHJ P,ATOMSX
\r
817 FILN1: TLNN C,F.PER ;PERIOD SEEN?
\r
824 FILN1A: PUSHJ P,NXCH
\r
826 FILN2: JUMPN A,FILN3
\r
838 FILN3: MOVEM A,(X2)
\r
843 ;ROUTINE TO CONVERT NEXT ATOM TO SIXBIT
\r
845 ALPHSX: SKIPA D,[Z (F.LETT)]
\r
846 ATOMSX: HRLZI D,F.DIG+F.LETT
\r
847 TLZ B,777777 ;SET LH OF A+1 TO 0
\r
849 MOVE X1,[POINT 6,A]
\r
852 PUSHJ P,SCNLTN ;PACK THIS LETTER INTO A.
\r
853 JFCL ;SCNLTN HAS SKIP RETURN.
\r
857 FILNMO: MOVEI A,(SIXBIT /DSK/)
\r
858 HRLI A,(SIXBIT /BAS/)
\r
859 FILNM1: HRLZM A,@(B)
\r
864 NAMOVE: MOVE X1,FILDIR
\r
870 ;ROUTINES TO SET LINE LIMITS
\r
871 LIMITS: TLNE C,F.TERM
\r
889 \f;A NONPRINTING ROUTINE SIMILAR TO PRTNUM:
\r
891 MAKNUM: IDIVI X1,^D10
\r
896 MAKN1: MOVEI X2,60(X2)
\r
899 ;ROUTINE TO ERASE LINE. LINE NO IN N.
\r
901 ERASE: HRLZ A,N ;LOOK FOR LINE
\r
904 POPJ P, ;NONE. GO TO INSERTION
\r
906 MOVE D,(B) ;PICK UP LOC OF LINE
\r
907 HRLI D,440700 ;MAKE BYTE POINTER
\r
908 MOVEI T1,0 ;TO USE IN DEPOSITING
\r
909 ERAS1: ILDB C,D ;GET CHAR
\r
910 DPB T1,D ;CLOBBER IT
\r
911 CAIE C,15 ;CARRIAGE RET?
\r
912 JRST ERAS1 ;NO. GO FOR MORE
\r
914 SETOM PAKFLA ;MARK FACT THAT THERE IS A HOLE
\r
916 MOVEI E,1 ;REMOVE ENTRY FROM LINE TABLE
\r
919 ;HERE WE HAVE A LINE OF INPUT AND THERE IS NO EXISTING LINE
\r
921 INSERT: MOVE T1,[POINT 7,LINB0]
\r
922 MOVE T,G ;RESTORE PNTR TO 1ST CHR
\r
923 INSE2: ILDB C,T ;GET NEXT CHAR
\r
924 CAIN C,15 ;CHECK FOR CAR RET
\r
929 INSE4: JUMPL T1,CPOPJ ;CR SEEN. DONE IF JUST DELETION
\r
930 IDPB C,T1 ;STORE THE CR
\r
931 MOVEI C,0 ;CLEAR REST OF WORK
\r
936 ;AT THIS POINT, N CONTAINS A LINE NUMBER AND LINB0 CONTAINS
\r
937 ;A NON-EMPTY INSERTED LINE. T1 CONTAINS ADDRESS OF LAST
\r
940 NEWLIN: MOVEI T1,(T1) ;COMPUTE LINE LENGTH
\r
943 ADD T1,CETXT ;COMPUTE NEW CEILING OF TEXT ROLL
\r
944 CAMGE T1,FLLIN ;ROOM FOR LINE PLUS LINROL ENTRY?
\r
946 SUB T1,CETXT ;ASK FOR MORE CORE
\r
952 NEWL1: MOVE D,CETXT ;LOC OF NEW LINE
\r
953 MOVE T,D ;CONSTRUCT BLT PNTR
\r
955 BLT T,-1(T1) ;MOVE THE LINE
\r
956 MOVEM T1,CETXT ;STORE NEW CEILING
\r
959 ;HERE, LINE IS IN PLACE, ITS LOC IN D, LINE NUMBER IN N.
\r
960 ;MUST STILL PUT LINE NUMBER IN LINROL.
\r
962 NEWNBR: PUSH P,D ;*****JUST IN CASE*****
\r
967 HALT . ;*****IMPOSSIBLE CONDITION*****
\r
970 PUSHJ P,OPENUP ;MAKE ROOM FOR IT
\r
971 POP P,D ;*****OTHER HALF OF JUST IN CASE*****
\r
972 HRRI A,(D) ;CONTRUCT LINROL ENTRY
\r
973 MOVEM A,(B) ;STORE ENTRY
\r
976 COMM1: PUSHJ P,INLMES
\r
979 COMM1A: SKIPE CURNAM
\r
982 BADDEL: PUSHJ P,INLMES
\r
983 ASCIZ /DELETE COMMAND MUST SPECIFY WHICH LINES TO DELETE
\r
986 NOSAVE: PUSHJ P,TTYIN
\r
988 ASCIZ /NO ROOM IN DIRECTORY/
\r
991 NOGETF: PUSHJ P,TTYIN
\r
993 ASCIZ /FILE NOT SAVED/
\r
996 TTYIN: MOVEI T,TTYBUF ;SET UP TTY BUFFS
\r
1006 BADGET: MOVEI T,BADMSG
\r
1007 MOVE X1,[POINT 7,BADGNN]
\r
1009 MOVE X1,BADGNN ;LAST GOOD LINE NUMBER
\r
1010 TLNN X1,-1 ;HAS IT BEEN CHANGED ALREADY?
\r
1011 PUSHJ P,MAKNUM ;NO, MAKE THE NUMBER
\r
1012 CALL T,[SIXBIT /DDTOUT/]
\r
1014 CALL T,[SIXBIT /DDTOUT/]
\r
1017 NOGETD: PUSHJ P,TTYIN
\r
1019 ASCIZ /NO SUCH DEVICE/
\r
1022 NOTNEW: PUSHJ P,TTYIN
\r
1024 ASCIZ /DUPLICATE FILE NAME. REPLACE OR RENAME/
\r
1027 RESERR: PUSHJ P,INLMES
\r
1028 ASCIZ /COMMAND ERROR (YOU MAY NOT OVERWRITE LINES OR CHANGE THEIR ORDER)
\r
1033 CAIA N,QSA ;IS IT RUNNH
\r
1035 MOVEI A,1 ;NO, PRINT HEADING
\r
1036 TLNN C,F.TERM ;IS THERE A LINE NUMBER ARGUMENT?
\r
1038 JUMPE A,RUNNH ;SHALL WE PRINT THE HEADING?
\r
1042 PUSHJ P,LIST01 ;PRINT HEADING SANS <RETURN>
\r
1046 RUNNH: PUSHJ P,LOCKON ;PROTECT REST OF COMPILATION
\r
1047 PUSHJ P,PRESS ;GUARANTEE SOURCE DOESN'T MOVE!!!
\r
1048 MOVEI X1,CODROL ;COMPILE TIME.
\r
1049 MOVEM X1,TOPSTG ;TXT,LIN,CODROLS ARE STODGY. OTHERS MOVE
\r
1051 PUSHJ P,SLIDRL ;SLIDE LINROL DOWN NEXT TO TXTROL.
\r
1054 SLIDRL: MOVE X2,CEIL(R)
\r
1055 HRRZ X1,CEIL-1(R) ;SLIDE ROLL DOWN NEXT TO LOWER ROLL
\r
1057 HRL X1,FLOOR(R) ;SET UP BLT TO MOVE ROLL
\r
1059 HRRZM X1,FLOOR(R) ;SET NEW ROLL FLOOR
\r
1064 RUNER1: MOVEM X2,FLCOD
\r
1065 MOVEM X2,CECOD ;CODROL IS ALSO PACKED IN PLACE
\r
1066 MOVEI X1,CODROL ;PREPARE TO CLOBBER ALL ROLLS ABOVE CODROL
\r
1067 MOVE T,JOBREL ;USE THIS VALUE.
\r
1068 PUSHJ P,CLOB ;DO THE CLOBBERING.
\r
1069 MOVEI F,0 ;CLEAR COMPILATION FLAGS
\r
1070 MOVEI T,0 ;SET UP AC FOR RUNTIM.
\r
1071 CALL T,[SIXBIT /RUNTIM/] ;GETY TIME OF START.
\r
1072 MOVEM T,MTIME ;SAVE TIME AT START OF RUNER
\r
1076 MOVEI F,REFROL ;CREATE A ROLL OF ZEROS
\r
1079 ;NOW MARK THIS ROLL TO SHOW WHAT PARTS OF THIS PROG ARE INSIDE OF FUNCTIONS.
\r
1080 LUKDEF: MOVEI A,LUKDEF+1 ;SCAN FOR NEXT "DEF" STA
\r
1081 PUSHJ P,NXLINE ;PREPARE TO READ THE NEXT LINE
\r
1083 MOVEI X1,[ASCIZ/DEFFN/]
\r
1084 PUSHJ P,QST ;IS IT A "DEF" STA?
\r
1085 JRST N,LUKD3 ;NO. GO ON TO NEXT LINE
\r
1087 HRRZ B,C ;YES. SAVE FN NAME.
\r
1090 LUKD1: PUSHJ P,NXCH ;NOW LOOK FOR EQUAL SIGN
\r
1092 JRST N,LUKD3 ;NO EQUAL. ITS A MULTILINE DEF.
\r
1094 JRST N,LUKD1 ;TRY NEXT CHAR.
\r
1095 JRST N,LUKD3-1 ;ITS A ONE LINE DEF. IGNORE IT.
\r
1097 LUKD2: MOVEI A,LUKD2+2 ;MARK EVERY LINE OF TIS MULTILINE FNT.
\r
1098 ROT B,-7 ;PUT FUNCTION NAME IN FIRST CHAR POISTION
\r
1100 MOVEM B,(G) ;NOW THIS LINE CONTAINS THE NAME OF ITS FN.
\r
1102 MOVEI X1,[ASCIZ /FNEND/]
\r
1103 PUSHJ P,QST ;END OF THE FN?
\r
1105 MOVEI A,LUKDEF+1 ;YES. SCAN FOR NEXT DEF.
\r
1107 LUKD3: AOBJN L,(A) ;GET NEXT LINE, IF THERE IS ONE
\r
1118 ;FINISHED MARKING FUN LINES. NOW SET UP A CLEAR LADROL...
\r
1119 RUNER2: MOVEI F,LADROL
\r
1123 ;ROUTINE TO MAKE A ROLL OF ZEROS =IN LNTH TO LINROL
\r
1125 MOVE E,CELIN ;COMPUTE LENGTH OF ROLL
\r
1127 JUMPE E,NOEND ;NOTHING TO DO
\r
1129 MOVN L,E ;SAVE FOR LINE CNTR.
\r
1131 PUSHJ P,BUMPRL ;ADD TO (EMPTY) ROLL
\r
1132 MOVE T,FLOOR(F) ;CLEAR IT TO 0S
\r
1137 CAILE T1,(T) ;SUPPRESS BLT IF ONLY 1 LINE
\r
1140 \f;SO FAR, WE HAVE SET UP LADROL FOR ADDRESSES & CHAINS FOR LABLES
\r
1141 ;ALSO, L IS A WORD TO AOBJN & COUNT THROUGH LINES.
\r
1142 ;BEGIN COMPILATION OPERATIONS FOR EACH LINE
\r
1144 EACHLN: MOVE P,PLIST ;FIX P LIST IN CASE LAST INST FAILED
\r
1145 PUSHJ P,LOCKOF ;CHECK REENTER REQUEST
\r
1148 MOVEM X1,TMPPNT ;NO UNPROTECTED TEMPORARIES USED YET.
\r
1157 EACHL2: PUSHJ P,NXLINE ;SET UP POINTER TO THIS LINE.
\r
1158 MOVSI A,(SIXBIT /REM/) ;PREPARE FOR COMMENT
\r
1159 TLNE C,F.TERM ;NULL STATEMENT?
\r
1160 JRST EACHL1 ;YES. ELIDED "REM" (FIRST CHAR WAS A APOSTROPHE)
\r
1161 PUSHJ P,SCNLT1 ;SCAN FIRST LTR
\r
1163 TLNE C,F.EQAL+F.DIG+F.DOLL ;ELIDED LETTER?
\r
1164 JRST ELILET ;YES. POSSIBLE ASSUMED "LET"
\r
1165 PUSHJ P,SCNLT2 ;SCAN SECOND LETTER.
\r
1166 JRST ILLINS ;SECOND CHAR WAS NOT A LETTER.
\r
1168 CAIE X1,(SIXBIT /IF/)
\r
1169 CAIN X1,(SIXBIT /ON/)
\r
1171 CAIE X1,(SIXBIT /FN/) ;ELIDED LET FNX= ?
\r
1175 TLNE C,F.EQAL ;IS FOURTH CHAR AN '=' SIGN?
\r
1176 JRST ELILET ;YES, ELIDED STATEMENT
\r
1177 JRST EACHL1 ;NO, BETTER BE FNEND.
\r
1179 EACHL3: PUSHJ P,SCNLT3 ;ASSEMBLE THIRD LETTER OF STATEMENT IN A
\r
1180 JRST ILLINS ;THIRD CHAR WAS NOT A LETTER
\r
1183 ELILET: MOVSI A,(SIXBIT /LET/) ;ASSUME A "LET" STATMENT.
\r
1184 MOVS T,D ;GO BACK TO THE FIRST LETTER.
\r
1188 ;HERE, FIRST 3 LTRS OF VERB (SIXBIT) ARE IN A. USE TBL LOOKUP AND DISPATCH.
\r
1190 EACHL1: MOVEI R,STAROL
\r
1191 PUSHJ P,SEARCH ;LOOK IN STATEMENT TYPE TABLE
\r
1192 JRST ILLINS ;NO SUCH, GO BITCH
\r
1193 HRRZ A,(B) ;FOUND.
\r
1195 MOVE Q,CECOD ;PUT REL ADDRS IN LADROL
\r
1201 TRZE A,20000 ;EXECUTABLE?
\r
1205 TRZN X1,40000 ;MORE TO COMMAND?
\r
1206 SOJA X1,EACHL5 ;NO. JUST DISPATCH
\r
1207 PUSHJ P,QST ;CHECK REST OF COMMAND
\r
1210 EACHL5: TLNE C,1000
\r
1211 FAIL <ILLEGAL CHARACTER>
\r
1213 ;HERE ON END OF STATEMENT XLATION
\r
1215 NXTSTA: TLNN C,F.TERM
\r
1219 ;ENTER HERE FROM ERROR ROUTINE
\r
1221 NXTST1: AOBJN LP,EACHLN
\r
1222 NOEND: PUSHJ P,INLMES
\r
1224 NO END INSTRUCTION
\r
1227 UXIT: SETZM RUNFLA
\r
1236 \fSUBTTL PROGRAM "LOADER"
\r
1237 ;HERE AFTER END STATEMENT
\r
1239 LINKAG: MOVEI R,CONROL ;SLIDE RUNTIME ROLLS DOWN INTO PLACE.
\r
1242 AOJA R,.-2 ;SLIDE NEXT ROLL
\r
1243 MOVEM X2,VARFRE ;FIRST FREE LOC IS CEIL OF TMPROL.
\r
1245 MOVE E,CETMP ;CHECK ARRAY REQUIREMENTS
\r
1249 LK1: HLRZ X1,(T) ;KNOW SIZE?
\r
1250 JUMPN X1,LK2 ;YES, JUMP
\r
1251 MOVSI X2,^D11 ;(11,1) IS STANDARD DIM.
\r
1255 CAMGE T,FLSVR ;DEFAULT SIZE OF STRING VECTORS IS (11,1)
\r
1256 AOJE Q,.+2 ;IMPLICIT 2-DIM ARRAY?
\r
1261 HRLM X1,(T) ;STORE SIZE
\r
1262 LK2: ADD E,X1 ;ADD LENGTH TO IT
\r
1263 ADDI T,2 ;ON TO NEXT ENTRY
\r
1264 CAMG T,FLSVR ;IS THIS ONE A STRING VECTOR?
\r
1266 HLRZ X2,-1(T) ;LOOK AT FIRST DIMENSION
\r
1267 SOJLE X2,LK2A ;IS IT 1(AND THUS A VECTOR)?
\r
1268 HRRZ X2,-1(T) ;NO. LOOK AT SECOND DIMENSION
\r
1269 SOJLE X2,LK2A ;IS IT 1(AND THUS A VECTOR)?
\r
1270 SETZM RUNFLA ;NO. FATAL ERROR.
\r
1272 ASCIZ /STRING VECTOR IS 2-DIM ARRAY
\r
1274 LK2A: CAMN T,FLSVR ;BEGINNING OF SVRROL SCAN?
\r
1275 MOVEM E,SVRBOT ;YES, REMEMBER BOTTOM OF VECTOR POINTERS
\r
1279 SETOM VPAKFL ;DONT TRY TO PRESS VARAIBLE SPACE NOW!
\r
1280 SUB E,CESVR ;WE NEED THIS MANY LOCS
\r
1282 ADD E,CETMP ;CALCULATE TOP OF ARRAY SPACE.
\r
1283 MOVEM E,SVRTOP ;SAVE IT.
\r
1284 MOVEM E,VARFRE ;THIS IS ALSO FIRST FREE WORD.
\r
1288 LINK0A: CAML T,CEFCL
\r
1289 JRST LINK0C ;NO MORE FCN CALLS
\r
1290 HLLZ A,(T) ;LOOK UP FUNCTION
\r
1292 JRST LINK0B ;UNDEFINED
\r
1293 MOVE A,(B) ;DEFINED. GET ADDRESS.
\r
1296 \fLINK0B: SETZM RUNFLA
\r
1298 ASCIZ /UNDEFINED FUNCTION -- FN/
\r
1299 LDB C,[POINT 7,A,6]
\r
1306 LINK0C: MOVE B,FLFOR ;UNSAT FORS?
\r
1309 MOVEI T,[ASCIZ /FOR WITHOUT NEXT/]
\r
1310 MOVE L,(B) ;GET POINTER TO LINE NUMBER
\r
1311 PUSHJ P,FAILR ;PRINT ERROR MSG
\r
1312 ADDI B,5 ;MORE UNSAT FORS?
\r
1314 LINK0D: SKIPG DATAFF
\r
1319 LINK0E: SKIPN RUNFLA ;GO INTO EXECUTION?
\r
1324 ;CODE ROLL IS IN PLACE. C CONTAINS ITS FLOOR
\r
1326 MOVE T,FLFCL ;LINK FCN CALLS
\r
1332 MOVE T,FLARA ;LINK ARRAY REFS
\r
1338 MOVE T,FLARA ;STORE ARRAY ADDRESSES IN APAROL
\r
1341 LINK1C: HLRZ X1,(T) ;GET ARRAY LENGTH
\r
1342 HRRM G,(T) ;STORE ABS ADDRS
\r
1343 ADD G,X1 ;COMPUTE ADDRS OF NEXT ARRAY
\r
1344 ADDI T,2 ;GO TO NEXT ENTRY
\r
1345 LINK1D: CAMGE T,T1
\r
1348 LINK1: MOVE T,FLCAD ;LINK CONST REFS
\r
1354 LINK2: MOVE T,FLPTM ;LINK TEMPORARY REFS (PERM AND TEMP)
\r
1360 LINK3: MOVE T,FLLAD ;LINK GOTO DESTINATIONS
\r
1366 LINK4: MOVE T,FLSCA ;LINK SCALARS
\r
1372 LINK6: MOVE T,FLGSB ;LINK GOSUB REFS
\r
1378 LINK7: CAML T,T1 ;PUT SUBRTN ADDRSES IN GSBROL
\r
1387 LINK8: MOVE T,FLNXT ;LINK REVERSE REFS IN FORS
\r
1393 MOVE T,FLSAD ;LINK POINTERS TO LITROL
\r
1399 LINKZ: MOVE X1,FLSCA ;ZERO OUT SCALARS AND STRING VARS
\r
1402 MOVE X1,CETMP ;ZERO OUT ARRAY ELEMENTS AND STRING VECTORS.
\r
1424 ;SUBROUTINE TO LINK ROLL ENTRIES
\r
1426 ;CALL WITH A=ORG OF VALUE ROLL, B=INCREMENT (0 IF EXPLICIT REL LOC)
\r
1427 ;T=FLOOR OF SRC ROLL, T1=CEIL OF SRC ROLL
\r
1433 LNKP1: CAML T,T1 ;FINISHED ROLL?
\r
1435 HRRZ Q,(T) ;FIRST LOC IN CHAIN
\r
1436 JUMPN B,.+3 ;EXPLICIT ADDRS?
\r
1437 HLRZ X2,(T) ;YES. COMPUTE IT
\r
1439 JUMPE Q,LNKP3 ;SPECIAL CASE--CHAIN VOID
\r
1441 LNKP2: HRR X1,Q ;ONE LINK IN CHAIN
\r
1446 LNKP3: JUMPN B,.+2 ;EXPLICT ADDRS?
\r
1447 AOJA T,LNKP1 ;YES, JUST BUMP ROLL PNTR
\r
1448 ADD T,B ;NO, ADD EXPLICIT INCREMENT
\r
1449 ADD X2,B ; (ALSO TO DEST ROLL)
\r
1452 BLTZER: HRL X1,X1 ;ZERO OUT CORE
\r
1461 ; CHANGE <VECTOR> TO <STRING>
\r
1463 ;CHANGE <STRING> TO <VECTOR>
\r
1465 ;COMPILES A FETCH AND PUT WHICH INTERFACE WITH THE "PUTSTR" ROUTINE
\r
1468 XCHAN: ASCIZ /NGE/ ;CHANGE?
\r
1484 XCHAN2: SKIPE N,IFFLAG
\r
1488 XCHAN1: PUSHJ P,FORMLB
\r
1489 XCHAN3: PUSHJ P,FLET3
\r
1497 ;<DATA STA>::= DATA <DEC NBR!STRING> [,<DEC NBR!STRING>...]
\r
1499 ;NOTE: A DATA STRING ::= " <ANY CHARS EXCEPT CR,LF> "
\r
1500 ; OR ::= <A LETTER><ANY CHARS EXCEPT COMMA OR APOST,CR,LF>
\r
1502 ;NO CODE IS GENERATED FOR A DATA STATEMENT
\r
1503 ;RATHER, THE DATA STATEMENT IN THE SOURCE
\r
1504 ;TEXT ARE REREAD AT RUN TIME.
\r
1507 SKIPL DATAFF ;ALREADY SEEN DATA?
\r
1508 MOVEM L,DATAFF ;NO. REMEMBER WHERE FIRST ONE IS
\r
1510 FAIL <DATA NOT IN CORRECT FORM>
\r
1513 ;SUBROUTINE TO CHECK DATA LINE
\r
1514 ;ALSO CALLED AT RUN TIME TO CHECK INPUT LINE
\r
1515 ;(NOTE.. <RETURN> NOT CHECKED AFTER INPUT LINE)
\r
1518 DATCHK: TLNN C,F.LETT+F.QUOT ;LETTER OR QUOT SIGN FIRST
\r
1519 JRST DATCH2 ;NO, EVALUATE NUMBER
\r
1520 PUSH P,[DATCH3] ;YES, ASSUME STRING AND SKIP OVER
\r
1522 DATCH2: PUSHJ P,EVANUM
\r
1524 CAIE C,"&" ;IF "&", ASSUME MATINPUT TERM
\r
1525 TLNE C,F.TERM ;MORE?
\r
1526 JRST CPOPJ1 ;NO. RETURN
\r
1527 TLNN C,F.COMA ;DID FIELD END CORRECTLY?
\r
1529 PUSHJ P,NXCH ;YES. SKIP COMMA
\r
1533 ;<DEF STA> ::= DEF FN<LETTER>(<ARGUMENT>) = <EXPRESSION>
\r
1535 ;GENERATED CODE IS:
\r
1536 ; JRST <A> ;JUMP AROUND DEF
\r
1537 ; XWD 0,0 ;CONTROL WORD
\r
1538 ; MOVEM N,(B) ;SAVE ARGUMENT IN TEMPORARY
\r
1540 ; (EVALUATE EXPRESSION)
\r
1541 ; JRST RETURN ;GO TO RETURN SUBROUTINE
\r
1542 ;<A>: ... ;INLINE CODING CONTINUES...
\r
1544 ;SEE GOSUB STATEMENT FOR USE OF CONTROL WORD.
\r
1546 ;DURING EXPRESSION EVALUATION, LOCATION
\r
1547 ;FUNARG CONTAINS ASCII REPRESENTATION OF ARGUMENT NAME.
\r
1548 ;ROUTINES CALLED BY FORMLN CHECK FOR USE OF ARGUMENT AND RETURN POINTER
\r
1549 ;TO FIRST WORD ON TEMPORARY ROLL.
\r
1551 ;PRIOR TO GEN OF FIRST EXPRESSION EVALUATION, THE "REAL" TEMPORARY
\r
1552 ;ROLL IS SAVED ON "STMROL" AND AN EMPTY "TEMROL" IS CREATED.
\r
1553 ;AFTERWARDS, THE NEW "TEMROL" ENTRIES ARE ADDED TO THE PERMANENT
\r
1554 ;TEMPORARY ROLL "PTMROL" AND "TEMROL" IS RESTORED.
\r
1555 ;THUS EACH DEFINED FUNCTION HAS ITS OWN SET OF TEMPORARIES
\r
1556 ;AND CANNOT CONFLICT WITH TEMPORARIES USED BY THE EXPRESSION
\r
1557 ;BEING EVALUATED AT THE POINT OF THE CALL.
\r
1559 ;NOTE. SPECIAL CASE: CHECK FOR FUNCTION DEF AS LAST LINE OF PROGRAM
\r
1560 ;SUPPRESSES GEN OF "JRST" INSTR. COMPILATION WILL FAIL
\r
1561 ;("NO END STATEMENT"); HOWEVER THE WORD AFTER LADROL WOULD BE
\r
1562 ;CLOBBERED IF "JRST" WERE GENNED.
\r
1564 XDEF: ASCIZ /FN/ ;HANDLE THE FN PART AUTOMATICALLY
\r
1565 SKIPE FUNAME ;ARE WE IN MIDST OF MULTI-LINE DEF?
\r
1567 MOVSI D,(JFCL) ;MAKE SURE NOT FIRST WRD OF CODE
\r
1571 TLNN C,F.LETT ;MAKE SURE LETTER FOLLOWS
\r
1573 PUSHJ P,SCNLT1 ;SCAN FCN NAME.
\r
1574 PUSH P,A ;SAVE FCN NAME WITH COUNT OF ZERO ARGUMENTS
\r
1575 MOVEM A,FUNAME ; FN'NAME IN BODY OF FUNCTION
\r
1576 \f;ADD FUNCTION NAME TO FCNROL
\r
1578 MOVEI R,FCNROL ;LOOK FOR FNC NAME IN FCNROL
\r
1581 FAIL <FUNCTION DEFINED TWICE>
\r
1582 MOVEI E,1 ;ADD TO FCNROL
\r
1584 ADD A,CECOD ;CONSTRUCT PNTR TO CONTROL WORD
\r
1585 SUB A,FLCOD ;STORE IN FCNROL ENTRY.
\r
1589 MOVE B,L ;GET JRST DESTINATION
\r
1590 AOBJP B,.+1 ;DONT GEN JRST IF LAST LINE OF SOURCE.
\r
1592 PUSHJ P,BUILDI ;GEN JRST INSTR.
\r
1593 MOVEM B,FUNSTA ;REMEMBER WHERE THIS JRST IS
\r
1594 MOVEI D,0 ;BUILD ZERO CONTROL WORD
\r
1597 ;SCAN FOR ARGUMENT NAME.
\r
1599 CAIE C,"(" ;ANY ARGUMENTS?
\r
1602 XDEF2: PUSHJ P,NXCHK ;SKIP "("
\r
1603 PUSHJ P,SCNLT1 ;ASSEMBLE ARGUMENT NAME
\r
1606 DPB C,[POINT 7,A,13]
\r
1609 MOVEI R,ARGROL ;NOW ADD THIS NAME TO THE ARGUMENT LIST
\r
1610 MOVE B,FLARG ;NOW CHECK ARGROL, FOR TWO IDENTICAL ARGS
\r
1611 XDEF2C: CAML B,CEARG
\r
1617 XDEF2D: MOVEI E,1 ;ADD NEW ARG TO ROLL
\r
1620 AOS (P) ;COUNT THE ARGUMENT
\r
1621 TLNE C,F.COMA ;ANY MORE ARGS?
\r
1624 TLNN C,F.RPRN ;FOLLOWING PARENTHESIS?
\r
1626 PUSHJ P,NXCHK ;YES. SKIP IT.
\r
1627 XDEF4: PUSHJ P,ARGCHK ;CHECK FOR RIGHT NUMBER OF ARGUMENTS
\r
1628 ;GEN CODE TO EVALUATE EXPRESSION.
\r
1630 MOVE X1,FLTMP ;SAVE TEMP ROLL AS STMROL
\r
1632 MOVEM X1,CETMP ;AND EMPTY TMPROL
\r
1633 MOVE X1,TMPLOW ;SAVE TEMP POINTER
\r
1637 TLNN C,F.EQAL ;MULTI LINE FN?
\r
1639 PUSHJ P,NXCHK ;NO. SKIP EQUAL SIGN
\r
1640 SETZM N,FUNAME ;SIGNAL THAT THIS IS NOT A MULTI-LINE FN
\r
1642 PUSHJ P,FORMLN ;GET THE EXPRESSION
\r
1645 ;NOW BUILD AN INSTRUCTION THAT WILL TELL RETURN HOW MANY ARGS TO POP
\r
1646 ;OFF THE PUSH LIST
\r
1648 POP P,B ;ARGCHK PUT THE ADDRESS OF A CONSTANT IN HERE
\r
1649 XDEFE: MOVSI D,(MOVE T,)
\r
1651 MOVE X2,CETMP ;RESTORE TMPROL, SAVE TEMPORARIES FOR FNC
\r
1658 HRRE X1,FUNLOW ;RESTORE TMPLOW
\r
1660 HRRZ X1,FUNSTA ;-1(X1) IS LOC OF JRST AROUND FUNCTION
\r
1662 HRRZ X2,CECOD ;JRST TO THE NEXT INST TO BE CODED
\r
1665 MOVE D,[JRST N,FRETRN]
\r
1666 JRST N,XRET1 ;USE RETURN CODE TO BUILD INST
\r
1668 XDEFM: POP P,X1 ;MULTI-LINE DEF. SAVE THE ARGCOUNT PARAMETER FOR FNEND
\r
1670 MOVE X1,CEFOR ;SAVE NUMBER OF ACTIVE FORS
\r
1671 SUB X1,FLFOR ;FOR A CHECK OF FORS HALF IN DEF
\r
1675 ;<DIM STA> ::= DIM <LETTER>[$](<NUMBER>[,<NUMBER>])[,<LETTER>[$](<NUMBER>[,<NUMBER>])...]
\r
1677 ;FOR EACH ARRAY, HAVE ONE-WORD ENTRY IN VARROL
\r
1678 ;WHICH POINTS TO THREE-WORD ENTRY IN ARAROL
\r
1680 ; (<LENGTH OF ARRAY>)<PNTR>
\r
1681 ; (<LEFT DIM>+1)<RIGHT DIM>+1
\r
1682 ;THE THIRD WORD IS < 0 IF THE MATRIX IS SET EQUAL TO ITS OWN TRN,
\r
1683 ;>0 IF THIS IS THE FAKE MATRIX USED FOR TMP STORAGE DURING MATA=
\r
1684 ;TRN(A), OTHERWISE IT IS 0.
\r
1686 ;DURING COMPILATION, <PNTR> IS CHAIN OF REFERENCES.
\r
1687 ;DURING EXECUTION, <PNTR> IS ADDRS OF FIRST WORD.
\r
1689 XDIM: SETZI F, ;ALLOW STRING VECTORS.
\r
1690 PUSHJ P,ARRAY ;REGISTER ARRAY NAME
\r
1691 CAIE A,5 ;STRING VECTOR? ELSE..
\r
1692 JUMPN A,GRONK ;NON-0 RESULT FLAG-SYNTAX ERROR.
\r
1693 CAIE C,"(" ;CHECK OPENING PAREN
\r
1695 ADD B,FLOOR(F) ;COMPUTE LOC OF ROLL ENTRY
\r
1696 SKIPLE 1(B) ;DIMENSION FLAG SHOULD BE 0 OR -1 OR -2
\r
1697 FAIL <VARIABLE DIMENSIONED TWICE>
\r
1698 PUSHJ P,NXCHK ;SKIP PARENTHESIS
\r
1699 PUSHJ P,GETNU ;FIRST DEMENSION
\r
1700 JRST GRONK ;NOT A NUMBER
\r
1701 HRRZ D,N ;SAVE FIRST DIM
\r
1702 AOBJN D,.+1 ;D::= XWD <FIRST DIM+1>,1
\r
1703 MOVEM D,1(B) ;STORE IN ARAROL (IN CASE 1 DIM)
\r
1704 MOVEI N,1 ;IN CASE ONE DIMENSION
\r
1705 TLNN C,F.COMA ;TWO DIMS?
\r
1707 PUSHJ P,NXCHK ;YES. SKIP COMMA.
\r
1708 JUMPN A,GRONK ;STRING VECTOR HAS TWO DIMS?
\r
1709 PUSHJ P,GETNU ;GET SECOND DIM
\r
1710 JRST GRONK ;NOT A NUMBER
\r
1712 HRL D,N ;NOW D HAS XWD <COLS+1>,<ROWS+1>
\r
1713 MOVSM D,1(B) ;STORE IN ROLL SWAPPED
\r
1714 XDIM1: IMULI N,(D) ;COMPUTE LENGTH OF ARRAY
\r
1715 HRLM N,0(B) ;STORE IN ROLL
\r
1717 TLNN C,F.RPRN ;CHECK CLOSING PAREN
\r
1719 PUSHJ P,NXCHK ;LOOK FOR COMMA
\r
1721 JRST NXTSTA ;NO. DONE WITH THIS STATEMENT.
\r
1722 PUSHJ P,NXCHK ;SKIP THE COMMA.
\r
1726 ;<END STA> ::= END
\r
1728 XEND: MOVE X1,FLLIN ;CHECK THAT IT IS LAST STA
\r
1731 FAIL <END IS NOT LAST>
\r
1733 MOVE D,[JRST UXIT] ;COMPILE TERMINAL EXIT
\r
1735 JRST LINKAG ;GO FINISH UP AND EXECUTE
\r
1738 ;CALCULATE INITIAL, STEP, AND FINAL VALUES
\r
1740 ;SET INDUCTION VARIABLE TO INITIAL VALUE
\r
1741 ;AND JUMP TO END IF IND VAR > FINAL
\r
1742 ;INCREMENTING IS HANDLED AT CORRESPONDING NEXT.
\r
1744 ;FIVE WORD ENTRY PLACED ON FORROL FOR USE
\r
1745 ;BY CORRESPONDING NEXT STATEMENT:
\r
1747 ; CURRENT VALUE OF L (FOR "FOR WITHOUT NEXT" MESSAGE)
\r
1748 ;<REL. ADRS IN CODROL OF JUST TO END OF-NEXT>
\r
1749 ; <POINTER TO INDUCTION VARIABLE>
\r
1750 ; <POINTER TO INCREMENT>
\r
1751 ; <CURRENT VALUE OF TMPLOW>
\r
1754 XFOR: TLNN C,F.LETT ;MAKE SURE VARIABLE IS FIRST.
\r
1756 MOVE A,L ;SAVE L FOR POSSIBLE ERROR MSG
\r
1759 PUSHJ P,REGLTR ;REGISTER ON SCAROL
\r
1760 CAIN A,1 ;BETTER BE SCALAR
\r
1761 TLNN C,F.EQAL ;BETTER HAVE EQUAL
\r
1763 PUSHJ P,NXCHK ;SKIP EQUAL SIGN.
\r
1764 PUSH P,B ;SAVE THE VARIABLE POINTER
\r
1765 PUSHJ P,FORMLN ;GEN THE INITIAL VALUE
\r
1767 MOVSI D,(MOVEM N,) ;GEN STORE INITIAL IN VARIABLE
\r
1770 PUSHJ P,QSF ;LOOK FOR "TO"
\r
1772 PUSHJ P,FORMLN ;GEN THE UPPER BOUND.
\r
1773 PUSHJ P,GPOSGE ;PERMANENT
\r
1774 PUSHJ P,SIPGEN ;TEMPORARY.
\r
1775 PUSH P,B ;REMEMBER WHERE IT IS
\r
1776 TLNN C,F.TERM ;IS THERE A STEP CLAUSE?
\r
1777 JRST XFOR2 ;LOOK FOR EXPLICIT "STEP"
\r
1778 MOVE T,[POINT 7,[BYTE (35)"STEP1"(7)15]]
\r
1779 PUSHJ P,NXCHK ;GET "S" IN CASE OF CR ;IMPLICIT "STEP1"
\r
1780 XFOR2: PUSHJ P,QSF ;LOOK FOR "STEP"
\r
1783 PUSHJ P,FORMLN ;XLATE AND GEN INCREMENT
\r
1784 PUSHJ P,SIPGEN ;SAVE STEP
\r
1785 EXCH B,0(P) ;EXCH WITH TOP OF ROL
\r
1786 PUSH P,B ;SAVE LOC OF UPPER BOUND
\r
1787 MOVE B,-2(P) ;GET INDUCTION VAR IN REG
\r
1796 XFOR3: MOVE X1,-1(P)
\r
1797 POP P,B ;BUILD COMPARE INSTR (IT
\r
1798 MOVSI D,(CAMLE N,) ;DOESN'T MATTER WHAT IT
\r
1799 SKIPGE N,X1 ;IS IF DONFOR IS THERE).
\r
1802 MOVSI D,(JRST) ;DUMMY JRST INSTRUCTION
\r
1806 SUB A,FLCOD ;SAVE LOC FOR NEXT'S JRST
\r
1807 SKIPE N,RUNFLA ;WHAT JRST ACUTALLY
\r
1808 MOVEI A,-2(A) ;NO. DONT ALLOW SPACE FOR IT.
\r
1813 PUSHJ P,RPUSH ;SAVE INDUCTION VARIABLE
\r
1814 EXCH A,(P) ;GET INCREMENT
\r
1816 POP P,B ;GET POINTER TO INDUCTION VARIABLE.
\r
1817 MOVSI D,(MOVEM N,) ;BUILD THE STORE THAT WILL BE USED
\r
1818 PUSHJ P,BUILDA ;BY NEXT.
\r
1821 MOVE A,TMPLOW ;SAVE THIS LEVEL OF PROTECTION TO BE RESTORED
\r
1823 MOVE A,TMPPNT ;PROTECT TEMPS USED BY THIS "FOR"
\r
1824 MOVEM A,TMPLOW ;IN THE RANGE OF THE FOR.
\r
1826 \f;FNEND STATEMENT
\r
1828 ;<FNEND STA> ::= FNEND
\r
1830 XFNEND: ASCIZ /ND/
\r
1831 SKIPN A,FUNAME ;MUST FOLLOW A MULTI-LINE FN DEF
\r
1832 FAIL <FNEND BEFORE DEF>
\r
1833 SETZM FUNAME ;SIGNAL END OF FN
\r
1834 TLO A,(177B13) ;ASSEMBLE THE SCALAR NAME OF THE RESULT
\r
1835 PUSHJ P,SCAREG ;REGISTER IT AS A SCALAR
\r
1836 PUSHJ P,EIRGNP ;GET THE RESULT IN REG
\r
1837 HLRZ B,FUNSTA ;RECOVER THE ADDRESS OF THE ARGUMENT COUNT
\r
1839 HLRZ X1,FUNLOW ;THIS IS # OF WDS IN FORROL AT START OF DEF
\r
1841 CAME X1,CEFOR ;ARE ALL NEXTS INSIDE OF DEF COMPLETE?
\r
1842 FAIL <FNEND BEFORE NEXT>
\r
1845 ;GOSUB STATEMENT XLATE
\r
1847 XGOSUB: ASCIZ /UB/
\r
1848 PUSHJ P,GETNUM ;READ STATEMENT NUMBER
\r
1851 MOVEI R,LINROL ;LOOK UP LINE NO
\r
1853 FAIL <UNDEFINED LINE NUMBER >,1
\r
1854 SUB B,FLLIN ;SUCCESS. SAVE REL LOC IN LINROL
\r
1863 XGOS1: SUB B,FLGSB
\r
1874 XGOFIN: PUSH P,[Z NXTSTA] ;BUILD GOTO AND END STA
\r
1875 XGOFR: PUSHJ P,GETNUM ;BUILD GOTO AND RETURN
\r
1876 FAIL <ILLEGAL LINE REFERENCE >
\r
1877 HRLZ A,N ;LOOK FOR DESTINATION
\r
1880 FAIL <UNDEFINED LINE NUMBER >,1
\r
1881 SUB B,FLLIN ;NOW CHECK FOR JUMP INTO/OUTOF FUNCTION
\r
1885 CAME X1,FUNAME ;BOTH MUST BE ZERO OR SAME FUNCTION
\r
1886 FAIL <ILLEGAL LINE REFERENCE >,1
\r
1889 PUSHJ P,BUILDA ;BUILD INSTR
\r
1893 ;<IF STA>::=IF <NUM FORMULA> <RELATION> <NUM FORMULA> THEN <LINE NUMBER>
\r
1895 ; ::= IF <STRING FORMULA><RELATION><STRING FORMULA> THEN <LINE NUMBER>
\r
1898 ;RELATION IS LOOKED UP IN TABLE (RELROL)
\r
1899 ;WHICH RETURNS INSTRUCTION TO BE EXECUTED
\r
1900 ;IF ONE OF THE EXPRESSIONS BEING COMPARED IS
\r
1901 ;IN THE REG, THAT ONE WILL BE COMPARED AGAINST
\r
1902 ;THE OTHER IN MEMORY. IF NECESSARY, THE
\r
1903 ;INSTRUCTION IS CHANGED TO ITS CONTRAPOSITIVE
\r
1904 ;BY FUDGING BITS IN THE OP CODE
\r
1908 XIF: PUSHJ P,FORMLB ;LEFT SIDE, MY BE A STRING
\r
1909 PUSHJ P,GPOSGE ;SAVE TYPE.
\r
1910 PUSHJ P,PUSHPR ;MAKE SURE IT IS POSITIVE
\r
1911 PUSHJ P,SCNLT1 ;SAVE IT
\r
1913 CAIE X1,(C) ;NEXT CHAR ">"?
\r
1914 TLNE C,F.EQAL ;OR "="?
\r
1915 PUSHJ P,SCN2 ;PUT TWO CHAR RELATION IN A(SIXBIT)
\r
1917 MOVEI R,RELROL ;RELATION TABLE
\r
1919 FAIL <ILLEGAL RELATION>
\r
1920 HRLZ D,(B) ;SAVE RELATION INSTR
\r
1922 PUSHJ P,FORMLB ;RIGHT SIDE, MAY ALSO BE A STRING
\r
1924 FAIL <MIXED STRINGS AND NUMBERS>
\r
1926 TLNN B,ROLMSK ;IS RIGHT SIDE IN REG?
\r
1927 JRST IFSX4 ;YES, LEAVE IT
\r
1928 PUSHJ P,EXCHG ;NO. SWAP WITH LEFT SIDE.
\r
1929 MOVE D,(P) ;FUDGE INSTRUCTION FOR CONTRAPOSITIVE RELATION
\r
1930 TLNE D,1000 ;(EQUAL, NOT EQUAL DON'T CHANGE.)
\r
1931 TLC D,6000 ;(OTHERS DO).
\r
1936 SKIPL IFFLAG ;NUMERIC COMPARE?
\r
1937 JRST IFSX6 ;NO, STRING.
\r
1939 PUSHJ P,EIRGNP ;MOVE TO REG
\r
1940 PUSHJ P,POPPR ;GET OTHER SIDE BACK
\r
1941 POP P,D ;GET STASHED OP CODE
\r
1942 PUSHJ P,BUILDA ;BUILD COMPARE INSTRUCTION
\r
1943 IFSX5: PUSHJ P,THENGO ;LOOK FOR "THEN" OR "GOTO"
\r
1944 JRST N,XGOFIN ;USE GOTO CODE TO GEN JRST INSTR
\r
1947 IFSX6: PUSHJ P,FLET3
\r
1948 PUSHJ P,POPPR ;GET OTHER ONE BACK
\r
1949 MOVSI D,(STRIF) ;STRING COMPARE UUO
\r
1950 PUSHJ P,BUILDA ;COMPARE UUO WITH OTHER STRING ADDRESS
\r
1952 PUSHJ P,BUILDI ;BUILD THE RELATION
\r
1953 JRST N,IFSX5 ;FINISH UP (THE OTHER STR POINTER WILL BE IN N)
\r
1954 >;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY
\r
1955 \f;INPUT STATEMENT
\r
1957 ;<INPUT STA> ::= INPUT (<SCALAR> ! <ARRAY REF>)[,(<SCALAR>!<ARRAY REF>)...]
\r
1960 XINPUT: ASCIZ /UT/
\r
1961 MOVE D,[PUSHJ P,DOINPT]
\r
1962 XINP0: PUSHJ P,BUILDI ;CONTRUCT SETUP INSTR
\r
1963 XINP1: TLNN C,F.LETT ;CHECK THAT LETTER IS NEXT.
\r
1965 SETZI F, ;STRINGS MAY BE INPUT
\r
1966 PUSHJ P,REGLTR ;GET VARIABLE
\r
1968 CAIG A,4 ;STRING VARIABLE?
\r
1971 CAIG A,6 ;VARIABLE?
\r
1975 JRST ILFORM ;NO, ATTEMPT TO BOMB A LITERAL
\r
1977 XINP1A: CAILE A,1 ;ONLY ARRAY AND SCALAR ALLOWED
\r
1982 XINP2: PUSH P,B ;SAVE VARIABLE POINTER
\r
1983 PUSHJ P,XARG ;XLATE ARGS
\r
1986 HRRZ X1,(P) ;GET ADDRESS OF VARIABLE 2-WD BLOCK
\r
1988 SKIPN 1(X1) ;MARK 2-DIM
\r
1991 XINP2A: EXCH B,(P) ;SAVE NO OF ARGS, GET VARIABLE
\r
1992 PUSHJ P,BUILDA ;BUILD DATA INSTR
\r
1993 POP P,B ;GET NO OF ARGS
\r
1996 XINP3: TLNN C,F.COMA ;MORE?
\r
1998 PUSHJ P,NXCHK ;YES. SKIP COMA
\r
2001 XINP6: PUSHJ P,FLET2 ;STRING. FINISH REGISTERING
\r
2003 PUSHJ P,BUILDA ;BUILD, WITH ADDRESS
\r
2011 SETOM LETSW ;LOOK FOR A LHS.
\r
2012 XLET0B: PUSHJ P,FORMLB
\r
2013 SKIPGE LETSW ;FAIL IF THIS FORMULA IS NOT A VARIABLE
\r
2018 PUSH P,[EXP 1] ;FLAG ON PLIST. IF THE LHS IS A SCALER,
\r
2019 PUSH P,B ;PUT THE FLAG AND AC B ON PLIST HERE.
\r
2020 XLET0: PUSHJ P,NXCHK ;SKIP EQUAL SIGN.
\r
2021 SOS LETSW ;COUNT THIS LHS, AND
\r
2022 JRST XLET0B ;LOOK FOR ANOTHER.
\r
2023 XLET0A: MOVMS LETSW ;FINISHED SCANNING
\r
2026 SKIPL E,IFFLAG ;STRING LET STA?
\r
2029 PUSHJ P,EIRGEN ;NO, GET RESULT IN REG
\r
2030 MOVEM B,TEMP1 ;SAVE THE NEGATIVE RESULT CHECK
\r
2031 XLET1: MOVE D,[MOVEM N, (MOVNM N,)]
\r
2032 SKIPG -1(P) ;FLAGS ON PLIST ARE --
\r
2033 MOVE D,[ARSTO1 N, (ARSTN1 N,)] ; 0 FOR LIST
\r
2034 SKIPL -1(P) ; 1 FOR SCALAR
\r
2035 JRST XLET2 ; -1 FOR TABLE.
\r
2036 MOVE D,[ARSTO2 N, (ARSTN2 N,)]
\r
2037 MOVE X1,(P) ;DEFAULT ARRAY SIZE (10,10)
\r
2041 XLET2: SKIPGE TEMP1 ;CHECK FOR NEGATIVE RESULT
\r
2042 MOVS D,D ;NEGATIVE. GET CORRECT INSTR.
\r
2043 POP P,B ;RESTORE RESULT PNTR
\r
2044 PUSHJ P,BUILDA ;BUILD STORE INSTR
\r
2045 POP P,B ;CHECK TRASH FROM PUSHLIST.
\r
2046 JUMPG B,XLET2B ;ARRAY REF?
\r
2047 PUSHJ P,GENARG ;YES. GEN ARGS FIRST.
\r
2048 XLET2B: SOSLE LETSW
\r
2049 JRST XLET1 ;THERE IS ANOTHER LHS.
\r
2052 XLET3: PUSHJ P,PUSHPR
\r
2054 XLET3A: CAME E,LETSW
\r
2055 FAIL <MIXED STRINGS AND NUMBERS>
\r
2059 MOVSI D,(STRSTO) ;BUILD THE STRING MOVE INSTRUCTION.
\r
2063 JRST XLET4 ;THERE IS ANOTHER LHS.
\r
2068 ;MAT STATEMENTS DIVIDE INTO A NUMBER OF DIFFERENT
\r
2069 ;STATEMENTS (MAT READ, ...) THESE POSSIBILITIES ARE TESTED
\r
2070 ;ONE AT A TIME BY CALLS TO QSA.
\r
2072 ;<MAT READ STA> ::= MAT READ <LETTER>[(<EXP>,<EXP>)] [,<LETTER>[(<EXP>,<EXP>...]]
\r
2074 XMAT: HLLI F, ;ALLOW STRINGS FOR READ,PRINT,PRINT
\r
2075 PUSHJ P,QSA ;MAT READ?
\r
2077 JRST XMAT2 ;NO. GO TRY MAT PRINT
\r
2078 XMAT1: PUSHJ P,ARRAY ;GET ARRAY NAME
\r
2079 CAIE A,5 ;STRING VECTOR?
\r
2082 SKIPL DATAFF ;DATA SEEN?
\r
2083 HLLOS DATAFF ;NO. SET NO DATA FLAG
\r
2084 PUSHJ P,XMACOM ;GO CHECK DIMENSIONS AND BUILD UUO.
\r
2085 TLNN C,F.COMA ;IS THERE ANOTHER ARRAY TO READ?
\r
2087 PUSHJ P,NXCHK ;YES. SKIP COMMA
\r
2088 TLNE C,F.TERM ;END OF ARRAY LIST?
\r
2089 JRST N,NXTSTA ;YES.
\r
2092 ;<MAT PRINT STA>::= MAT PRINT <LETTER>[(<EXP>,<EXP>)] [[;!,] <LETTER>[(<EXP>,<EXP>)...]
\r
2094 XMAT2: PUSHJ P,QSA ;MAT PRINT?
\r
2096 JRST N,XMAT3 ;NO. MUST HAVE VARIABLE NAME.
\r
2097 XMAT2A: PUSHJ P,ARRAY ;REGISTER NAME
\r
2098 CAIE A,5 ;STRING VECTOR?
\r
2103 JRST GRONK ;FAIL IF ILLEGAL
\r
2104 PUSHJ P,XMACOM ;GO CHECK DIMENSIONS AND BUILD UUO
\r
2105 TLNE C,F.TERM ;IS FORMAT CHAR FOLLOWED BY END OF STA?
\r
2109 ;<MAT SCALE STA> ::= MAT <LETTER>=(<EXPRESSION>)*<LETTER>
\r
2111 XMAT3: PUSH P,[Z NXTSTA] ;ALL REMAINING MAT STATEMENTS MAY HAVE
\r
2112 ;ONE OPERAND, BUT NOT A LIST OF THEM.
\r
2116 PUSHJ P,VECTOR ;REGISTER VECTOR NAME
\r
2117 CAIE A,5 ;STRING VECTOR?
\r
2118 JUMPN A,GRONK ;OR NUMBER VECTOR?
\r
2119 MOVSI D,(MATINP) ;YES. BUILD MAT INPUT
\r
2123 XMAT3A: HRLI F,-1 ;REMAINING MATOPS CANT HAVE STRINGS.
\r
2124 PUSHJ P,ARRAY ;REGISTER THE VARIABLE
\r
2125 JUMPN A,GRONK ;CHECK FOR ILLEGAL ARRAY NAME.
\r
2126 TLNN C,F.EQAL ; CHECK FOR EQUAL SIGN.
\r
2128 PUSHJ P,NXCHK ;SKIP EQUAL.
\r
2129 CAIE C,"(" ;SCALAR MULTIPLE?
\r
2131 PUSHJ P,NXCHK ;SKIP PARENTHESIS
\r
2133 PUSHJ P,FORMLN ;YES. GEN MULTIPLE
\r
2135 PUSHJ P,QSF ;SKIP MULTIPLY SING
\r
2137 PUSH P,[MATSCA] ;GET OP CODE.
\r
2139 \f;<MAT SETUP STA> ::= MAT ZER!CON!IDN <LETTER>[(<EXPRESSION>,<EXPRESSION>)]
\r
2141 XMAT4: PUSHJ P,QSA ;MAT ZER?
\r
2144 MOVSI D,(MATZER) ;YES.
\r
2147 XMAT5: PUSHJ P,QSA ;MAT CON?
\r
2150 MOVSI D,(MATCON) ;YES.
\r
2153 XMAT6: PUSHJ P,QSA ;MAT IDN?
\r
2156 MOVSI D,(MATIDN) ;YES.
\r
2158 ;COMMON GEN FOR MAT ZER,CON,IDN,REA
\r
2160 XMACOM: CAIE C,"(" ;EXPLICIT DIMENSIONS?
\r
2162 PUSH P,B ;SAVE B,D.
\r
2164 PUSHJ P,XARG ;TRANSLATE ARGUMENTS
\r
2165 PUSH P,B ;SAVE COUNT OF ARGUMENTS
\r
2166 MOVE B,-2(P) ;GET BACK THE REGISTERY OF THE ARRAY.
\r
2167 MOVSI D,(SDIM) ;BUILD SDIM INSTR.
\r
2169 POP P,B ;GET THE ARGUMENT COUNT.
\r
2170 JUMPN B,XMACO1 ;ONE ARG OR TWO?
\r
2171 MOVE D,[JUMP T1,ONCESW] ;ONE. FAKE DIMENSIONS OF (0,N)
\r
2175 XMACO1: PUSHJ P,GENARG ;GEN ARGS
\r
2176 JRST XMAT9C ;RESTORE AC,S AND BUILD
\r
2178 ;<MAT FCN STA> ::= MAT<LETTER> = INV!TRN (<LETTER>)
\r
2180 XMAT7: PUSHJ P,QSA ;MAT INV?
\r
2183 MOVSI D,(MATINV) ;YES. GET OP CODE.
\r
2186 XMAT8: PUSHJ P,QSA ;MAT TRN?
\r
2189 MOVSI D,(MATTRN) ;YES. GET OP CODE
\r
2190 XMITCM: PUSH P,B ;FINISH MAT INV,TRN.
\r
2197 \f;<MAT OPERATOR STA>::=MAT <LETTER>=<LETTER>+!-!*<LETTER>
\r
2199 XMAT9: PUSH P,B ;SAVE RESULT LOCATION
\r
2202 MOVEI D,0 ;LETTER FOLLOWED BY OPERATOR
\r
2203 TLNN C,F.PLUS+F.MINS+F.STAR
\r
2204 JRST N,XMAT10 ;NO OPERATOR. MUST BE MAT COPY
\r
2205 TLNN C,F.MINS+F.STAR
\r
2207 TLNN C,F.PLUS+F.STAR
\r
2209 TLNN C,F.PLUS+F.MINS
\r
2211 PUSH P,D ;SAVE OPERATION
\r
2212 PUSHJ P,NXCHK ;SKIP OPERATOR
\r
2213 MOVSI D,(MOVEI T,) ;GEN T:= ADRS OF FIRST ARRAY
\r
2215 PUSHJ P,BUILDA ;ENTER HERE FROM SCALAR MULTIPLE
\r
2217 XMAT9A: PUSHJ P,ARRAY ;SECOND ARRAY
\r
2218 JUMPN A,GRONK ;NOT ARRAY NAME
\r
2220 ;ENTER HERE FROM MAT INV, TRN
\r
2222 XMAT9B: MOVSI D,(MOVEI T1,)
\r
2226 XMAT9D: PUSHJ P,BUILDA
\r
2227 POPJ P, ;RETURN TO NXTSTA (OR TO PROCESS NEXT ITEM IN PRINT,READ, OR INPUT LIST.)
\r
2229 XMAT10: PUSH P,B ;FOR MAT COPY, FAKE MAT B=(1)*A
\r
2230 MOVE D,[MOVSI N,(1.0)];PUT CONSTANT 1.0 IN REG FOR SCALE
\r
2231 PUSHJ P,BUILDI ;BUILD INSTR TO GET SCAL FACTOR
\r
2232 POP P,B ;GET SOURCE MAT BACK
\r
2235 >;ASSEMBLE ABOVE IF INCLUDING MATRIX FACILITY
\r
2236 \f;;NEXT STATEMENT
\r
2238 ;<NEXT STA> ::= NEXT <SCALAR>
\r
2240 ;EXPECT TO FIND 5-WORD ENTRY ON TOP OF FORROL
\r
2241 ;DISCRIBING INDUCTION VARIABLE AND LOOP ADDRESS
\r
2243 ;WORD IS PUSHED ON NXTROL OF FOLLOWING FORM:
\r
2244 ; (<REL ADRS OF TOP OF LOOP>) <REL ADRS OF JRST TO IT>
\r
2245 ;THIS WORD USED TO FIX UP REFERENCE AT END OF
\r
2249 CAIE A,1 ;BETTER BE SCALAR
\r
2251 MOVE X1,CEFOR ;UNSAT FOR?
\r
2253 FAIL <NEXT WITHOUT FOR>
\r
2254 CAME B,-3(X1) ;CHECK INDUCTION VARIABLE
\r
2255 FAIL <NEXT WITHOUT FOR>
\r
2258 MOVEM B,TMPLOW ;RESTORE PREVIOUS LEVEL OF TEMPORARY PROTECTION.
\r
2259 MOVEM B,TMPPNT ;BECAUSE THIS IS THE END OF THE "FOR" RANGE .
\r
2260 PUSHJ P,POPFOR ;GEN INCREMENT TO REG
\r
2262 PUSHJ P,POPFOR ;FADR TO INDUCTION VAR
\r
2265 PUSHJ P,POPFOR ;GET LOC OF RETURN
\r
2267 MOVEI X1,1(B) ;ADD TO ADDRESS CHAIN OF NEXT WORD
\r
2270 AOBJP X2,XNEX2 ;DONT LINK IF LAST STATEMENT!
\r
2277 XNEX2: MOVSI A,(B) ;ADD WORD TO NXTROL FOR LINKAGE
\r
2282 MOVSI D,(JRST) ;BUILD JRST INSTR
\r
2284 PUSHJ P,POPFOR ;POP OFF THE SAVED VALUE OF L
\r
2286 \f;SUBR TO POP TOP OF FORROL. USED ONLY BY XNEXT.
\r
2289 POPFOR: SOS X1,CEFOR ;POP TOP OF FORROL
\r
2296 ;<ON STA> ::= ON <EXPRESSION> GOTO!THEN <STA NUMBER> [,<STA NUMBER>...]
\r
2298 ;CREATES A CALL TO A RUNTIME ROUTINE THAT CHECKS THE RANGE OF THE ARGUMENT
\r
2299 ;AND RETURNS TO THE APPROPRIATE JRST:
\r
2301 ; Z (ADDRESS OF NEXT STATEMENT)
\r
2306 XON: PUSHJ P,FORMLN ;EVALUTE INDEX
\r
2307 PUSHJ P,EIRGNP ;GET IN REG
\r
2308 MOVE D,[JSP Q,XCTON]
\r
2309 PUSHJ P,BUILDI ;BUILD THE RUNTIME CALL
\r
2310 SETZI D, ;BUILD ADDRESS OF NEXT STATEMENT
\r
2312 AOBJP B,.+3 ;DONT BUILD IF LAST STATEMENT
\r
2315 PUSHJ P,THENGO ;TEST FOR "THEN" OR "GOTO"
\r
2317 XON1: PUSHJ P,XGOFR ;BUILD A JRST TO THE NEXT NAMED STATMENT
\r
2318 TLNN C,F.COMA ;MORE?
\r
2320 PUSHJ P,NXCHK ;YES. SKIP COMMA
\r
2321 JRST N,XON1 ;PROCESS NEXT LINE NUMBER
\r
2322 \f;PRINT STATEMENTS CAUSES DATA TO BE OUTPUT TO THE DISK OR TTY.
\r
2324 XPRINT: ASCIZ /NT/
\r
2327 XPRI1: SETOM IFFLAG
\r
2331 ASCIZ /TAB/ ;TAB FIELD?
\r
2332 CAIA ;NO, ASSUME EXPRESSION OR DELIMENTER.
\r
2333 JRST XPRTAB ;YES, DO THE TAB
\r
2340 MOVSI D,(PRNM) ;SET UP OP CODE
\r
2341 PUSHJ P,CHKFMT ;SET FORMAT CODE
\r
2342 PUSHJ P,BUILDA ;GEN PRINT UUO
\r
2344 XPRI2: MOVE D,[PRNTB ONCESW]
\r
2349 XPRTAB: PUSHJ P,FORMLN ;EVALUATE TAB SUBEXPRESSION
\r
2350 PUSHJ P,EIRGNP ;MOVE IT INTO REG
\r
2351 MOVSI D,(PRNTB) ;CALL THE TAB INTERPRETER
\r
2352 XPRTA1: PUSHJ P,CHKFMT
\r
2353 PUSHJ P,BUILDI ;YES, BUILD THE INST.
\r
2363 XPRFIN: TLNE C,F.TERM ;CR AT END OF LINE?
\r
2367 ;HERE FOR PRINT WITH NO ARGUMENTS. GEN CARRIAGE RETURN.
\r
2369 XPCRLF: MOVE D,[PUSHJ P,PCRLF]
\r
2373 ;CHECK FORMAT CHAR (PRINT AND MAT PRINT)
\r
2375 CHKFMT: TLNE C,F.TERM
\r
2376 TLO D,40 ;CR ... AC = 1
\r
2377 CAIN C,";" ;SC ... AC = 2
\r
2378 TLO D,100 ;CMA ... AC = 3
\r
2379 TLNE C,F.COMA ;<PA> ... AC = 4
\r
2381 TLNN D,140 ;WAS THERE A FMT CHAR?
\r
2382 TLO D,100 ;NO. ASSUME ";"
\r
2384 TLNE C,F.COMA ;SKIP FMT CHAR IF THERE WAS ONE.
\r
2385 JRST NXCHK ;YES. SKIP
\r
2388 PRNDEL: MOVSI D,(PRSTR)
\r
2392 \f;RANDOM IZE STATEMENT
\r
2401 MOVE D,[PUSHJ P,RANDER]
\r
2402 PUSHJ P,BUILDI ;BUILD CALL TO RUTIME RANDOMIZER
\r
2404 >;ASSEMBLE ABOVE IF INCLUDING RANDOM FACILITY
\r
2411 SKIPL DATAFF ;DATA SEEN YET?
\r
2412 HLLOS DATAFF ;NO. SET NO DATA FLAG
\r
2413 MOVE D,[PUSHJ P,DOREAD]
\r
2414 JRST XINP0 ;GO FINISH WITH INPUT CODE
\r
2416 \f;RESTORE STATEMENTS.
\r
2419 XREST: ASCIZ /TORE/
\r
2420 MOVE D,[PUSHJ P,RESTON]
\r
2421 TLNN C,F.STAR+F.DOLL
\r
2423 TLNE C,F.DOLL ;RESTORE ONLY STIRNGS?
\r
2425 PUSHJ P,NXCHK ;SKIP $ OR *
\r
2426 XRES1: PUSHJ P,BUILDI
\r
2430 ;RETURN STATEMENT XLATE
\r
2433 XRETRN: ASCIZ /URN/
\r
2434 MOVE D,[JRST RETURN]
\r
2435 XRET1: PUSHJ P,BUILDI ;XDEFS ENTERS HERE TO COMPLETE A FN DEF.
\r
2443 MOVE D,[JRST UXIT]
\r
2446 \f;GEN CODE TO EVALUATE FORMULA
\r
2447 ;POINTER TO (POSSIBLY NEGATIVE) RESULT RETURNED IN B
\r
2449 ;THIS LOOP HANDLES SUMS OF TERMS, CALLS TERM TO HANDLE PRODUCTS
\r
2451 ;THE ENTRY POINT FORMLN REGARDS ONLY NUMERIC FORMULAS AS LEGAL.
\r
2452 ;THE ENTRY POINT FORMLS REGARDS ONLY STRING FORMULAS AS LEGAL.
\r
2453 ;THE ENTRY POINT FORMLB WILL ACCEPT EITHER A STRING OR A NUMERIC FORMULA.
\r
2454 ;THE ENTRY POINT FORMLU EXPECTS THE LEGALITY TO BE DEFINED EXTERNALLY.
\r
2461 PUSHJ P,TERM ;GET FIRST TERM
\r
2463 ;ENTER HERE FOR MORE SUMMANDS
\r
2465 FORM1: TLNN C,F.PLUS+F.MINS
\r
2467 MOVMS N,LETSW ;THIS CANT BE LH(LET)
\r
2469 PUSHJ P,PUSHPR ;PART RESLT TO SEXROL
\r
2470 PUSHJ P,TERM ;GET SECOND TERM
\r
2471 TLNE B,ROLMSK ;IS SECOND TERM IN REG?
\r
2472 PUSHJ P,EXCHG ;NO. LETS DO FIRST TERM FIRST
\r
2473 PUSHJ P,EIRGEN ;FIRST SUMMAND TO REG
\r
2474 PUSH P,B ;SAVE SIGN INFORMATION
\r
2475 PUSHJ P,POPPR ;GET SECOND SUMMAND
\r
2476 SKIPGE (P) ;IS CONTENT OR REG NEGATIVE?
\r
2477 TLC B,MINFLG ;YES, NEGATE SECOND SUMMAND
\r
2478 MOVSI D,(FADR N,) ;FETCH INSTRUCTION
\r
2479 PUSHJ P,BUILDS ;BUILD ADD OR SUB INSTR
\r
2480 POP P,B ;REG PNTR WITH SIGN
\r
2481 AND B,[XWD MINFLG,0]
\r
2483 \f;LOOP TO GEN CODE FOR MULTIPLY AND DIVIDE
\r
2484 ;CALLS FACTOR TO HANDLE EXPRESSIONS INVOLVING ONLY INFIX OPS AND "^"
\r
2487 TERM: PUSHJ P,FACTOR
\r
2489 ;ENTER HERE FOR MORE FACTORS
\r
2491 TERM1: TLNN C,F.STAR+F.SLSH ;MUL OR DIV FOLLOWS?
\r
2492 POPJ P, ;NO, DONE WITH TERM.
\r
2493 MOVMS LETSW ;THIS CANT BE LH(LET)
\r
2495 HRRZS 0(P) ;SET MUL FLAG.
\r
2496 TLNN C,F.STAR ;IS IT MULTIPLY?
\r
2497 HRROS 0(P) ;NO. SET DIV FLAG
\r
2498 PUSHJ P,NXCHK ;SKIP OVER CONNECTIVE
\r
2499 PUSHJ P,PUSHPR ;STASH PARTIAL RESULT ON SEXROL
\r
2500 PUSHJ P,FACTOR ;GET NEXT FACTOR
\r
2501 SKIPGE (P) ;IS SECOND FACTOR A DIVISOR?
\r
2502 PUSHJ P,SITGEN ;YES. IT CANNOT STAY IN REG.
\r
2503 TLNE B,ROLMSK ;IS SECOND FACTOR IN REG?
\r
2504 PUSHJ P,EXCHG ;NO. LETS GET FIRST FACTOR
\r
2505 MOVE X1,CESEX ;PEEK AT DIVISOR OR SECOND FACTOR.
\r
2507 TLZE X2,MINFLG ;IS IT MINUS?
\r
2508 TLC B,MINFLG ;YES. CHANGE SIGNS OF BOTH.
\r
2509 MOVEM X2,-1(X1) ;NOW DIVISOR OR SECOND FACTOR IS PLUS.
\r
2510 PUSHJ P,EIRGEN ;GEN FIRST FACTOR OR DIVIDEND
\r
2511 PUSH P,B ;SAVE SIGN INFORMATION
\r
2512 PUSHJ P,POPPR ;GET SECOND OPERAND
\r
2513 MOVSI D,(FMPR N,) ;GET CORRECT INSTRUCTION
\r
2516 PUSHJ P,BUILDA ;BUILD MUL OR DIV INSTR
\r
2517 POP P,B ;REG PNTR WITH SIGN
\r
2518 JRST N,TERM1 ;GO LOOK FOR MORE FACTORS
\r
2519 \f;GEN CODE FOR ATOMIC FORMULAS, EXPONENTIATION, AND INFIX SIGNS
\r
2520 ;SIGN IS STASHED IN LH OF PUSH-DOWN LIST WORD WITH RETURN ADDRS
\r
2521 ;EXPLICIT SIGN IS NOT USED UNTIL AFTER EXPONENTIATION
\r
2525 FACTOR: PUSH P,C ;STASH SIGN IN PUSH LIST.
\r
2527 TLC C,F.PLUS+F.MINS ;YES. PRETEND IT WAS PLUS CALLING ATOM.
\r
2529 PUSHJ P,ATOM ;GEN FIRST ATOM
\r
2531 FACT2A: CAIE C,"^" ;EXPONENT FOLLOWS?
\r
2532 JRST SNOEXI ;NO. GO NOTE SIGN AND RETURN.
\r
2533 MOVMS LETSW ;THIS CANT BE LH(LET)
\r
2534 PUSHJ P,NXCHK ;YES. SKIP EXPONENTIATION SIGN
\r
2535 PUSHJ P,PUSHPR ;STASH BASE ON SEXROL
\r
2536 PUSHJ P,ATOM ;GEN THE EXPONENT
\r
2537 PUSHJ P,EXCHG ;EXCHANGE BASE AND EXPONENT
\r
2538 PUSHJ P,EIRGNP ;GET POSITIVE BASE IN REG
\r
2539 PUSHJ P,POPPR ;GET EXPONENT IN AC1
\r
2542 MOVE D,[PUSHJ P,EXP3.0]
\r
2543 PUSHJ P,BUILDI ;BUILD CALL TO EXPONENTIATION ROUTINE
\r
2544 MOVEI B,0 ;ANSWER LANDS IN REG
\r
2547 ;SIGN NOTE AND EXIT
\r
2548 ;COMPLEMENT SIGN IF "-" AND APPROPRIATE FLAGS ON PD LIST.
\r
2549 ;THEN RETURN FROM SUBROUTINE.
\r
2552 TLNE X1,F.MINS ;IS SAVED SIGN MINUS?
\r
2553 TLC B,MINFLG ;YES. COMPLEMENT
\r
2555 \f;GEN CODE FOR SIGNED ATOM.
\r
2557 ATOM: PUSH P,C ;SAVE SIGN INFO.
\r
2558 TLNE C,F.PLUS+F.MINS
\r
2559 PUSHJ P,NXCHK ;YES. SKIP SIGN
\r
2560 TLNE C,F.LETT ;LETTER?
\r
2561 JRST FLETTR ;YES. VARIABLE OR FCN CALL.
\r
2562 TLNE C,F.DIG+F.PER ;NUMERAL OR DECIMAL POINT?
\r
2563 JRST FNUMBR ;YES. LITERAL OCCURRENCE OF NUMBER
\r
2564 CAIE C,F.SLSH+F.QUOT ;STR CONSTANT.
\r
2565 JRST ILFORM ;NO. ILLEGAL FORMULA
\r
2567 PUSHJ P,NXCHK ;SUBEXPR IN PARENS. SKIP PAREN
\r
2568 PUSHJ P,FORMLN ;GEN THE SUBEXPRESSION
\r
2569 TLNN C,F.RPRN ;BETTER HAVE MATCHING PAREN
\r
2570 JRST ILFORM ;NO. GRONK.
\r
2571 PUSHJ P,NXCHK ;SKIP PARENTHESIS
\r
2572 JRST N,SNOEXI ;GO TEST SIGN AND RETURN
\r
2574 FNUMBR: PUSHJ P,EVANUM ;EVALUATE NUMBER (IN N)
\r
2575 FAIL <ILLEGAL CONSTANT>
\r
2576 MOVE X1,0(P) ;GET SIGN FLAG
\r
2577 CAIE C,"^" ;EXPONENT FOLLOWS?
\r
2578 TLNN X1,F.MINS ;OR IS IT PLUS ANYWAY?
\r
2579 JRST FNUM1 ;YES. DONT FUDGE SIGN
\r
2580 MOVN N,N ;NEGATE NUMBER
\r
2581 SETZM 0(P) ;AND CLEAR SIGN INFO.
\r
2583 FNUM1: MOVE B,FLCON ;SEARCH CONSTANT ROLL
\r
2584 FNUM2: CAML B,CECON ;(UNSORTED--CANT USE SEARCH)
\r
2585 JRST FNUM3 ;NOT FOUND
\r
2586 CAME N,(B) ;THIS ONE?
\r
2587 AOJA B,FNUM2 ;NO. GO TO NEXT.
\r
2588 SUB B,FLCON ;FOUND. CALC REL ADDRESS IN CONROL
\r
2591 FNUM3: MOVEI R,CONROL ;PUSH ON CONROL
\r
2594 MOVEI R,CADROL ;PUT ADDRS ON CONST ADDRS ROLL
\r
2597 SUB B,FLCAD ;GET REL ADDRS
\r
2599 FNUM4: HRLI B,CADROL ;MAKE POINTER
\r
2600 JRST N,SNOEXI ;GO LOOK AT SIGN AND RETURN
\r
2602 NNUM: PUSH P,[EXP 1] ;REGISTER THE CONSTANT IN "N"
\r
2604 \f;XLATE AND GEN ATOMIC FORMULA BEGINNING WITH LETTER
\r
2606 FLETTR: PUSHJ P,REGLTR
\r
2610 JRST XARFET ;ARRAY REF
\r
2611 JRST SNOEXI ;SCALAR. JUST RETURN
\r
2612 JRST XINFCN ;INTRINSIC FCN
\r
2613 JRST XDFFCN ;DEFINED FCN
\r
2620 FLET2: PUSH P,[EXP 1] ;PUSH AN IMPLICIT PLUS SIGN ON PLIST
\r
2621 JRST FLET1 ;FINISH REGISTERING VARIABLE.
\r
2623 FLET3: SKIPGE IFFLAG
\r
2630 PUSHJ P,REGFRE ;FREE REG
\r
2634 SKIPL LETSW ;IS IT LH OF ARRAY-LET?
\r
2636 TLNN C,220000 ;IS IT DEFINITELY LH OF ARRAY-LET?
\r
2640 SUB P,[XWD 6,6] ;ADJUST THE PUSHLIST TO ESC FORMLS
\r
2641 PUSH P,B ;SAVE THE ARGUMENT FLAG
\r
2642 PUSH P,X1 ;SAVE THE ARRAY POIUNTER
\r
2648 SKIPL IFFLAG ;STR VECTOR?
\r
2649 MOVSI D,(SVRADR) ;YES. FETCH STRING POINTER ADDRESS.
\r
2653 FAIL <STRING VECTOR HAS 2 DIMS>
\r
2655 MOVE X1,-1(P) ;MARK DOUBLE ARRAY
\r
2664 MOVEI B,0 ;REG POINTER
\r
2665 SKIPL IFFLAG ;STRING VECTORS?
\r
2666 PUSHJ P,SITGEN ;YES,SAVE ADDRESS POINTER
\r
2668 \f;GEN FUNCTION CALLS
\r
2670 XDFFCN: PUSH P,D ;SAVE FCN NAME
\r
2671 PUSHJ P,REGFRE ;SAVE ANY SUBEXPRESSION
\r
2672 PUSHJ P,PUSHPR ;SAVE FUNCTION LOCATION
\r
2673 CAIE C,"(" ;ANY ARGS?
\r
2675 SETZM PSHPNT ;INITIALIZE COUNT OF PUSH INSTS GENNED
\r
2676 XDFF1: PUSHJ P,NXCHK
\r
2677 PUSHJ P,FORMLN ;GEN THE ARGUMENT IN REG
\r
2679 MOVSI D,(PUSH P,) ;BUILD ARGUMENT PUSH
\r
2681 AOS PSHPNT ;COUNT THE PUSH
\r
2682 AOS (P) ;ALSO SAVE THE COUNT FOR CHECK OF ARGS
\r
2683 TLNE C,F.COMA ;MORE ARGS?
\r
2686 TLNN C,F.RPRN ;CHECK FOR MATCHING PAREN
\r
2688 SETZM PSHPNT ;RESET THE PUSH COUNT AGAIN
\r
2689 PUSHJ P,NXCHK ;SKIP PAREN
\r
2691 XDFF2: PUSHJ P,ARGCHK ;CHECK FOR RIGHT NUMBER OF ARGUMENTS
\r
2692 POP P,X1 ;GET RID OF POINTER TO ARG# CONSTANT
\r
2693 PUSHJ P,POPPR ;GET BACK FUNCTION LOC
\r
2695 PUSHJ P,BUILDA ;GEN THE CALL
\r
2696 MOVEI B,0 ;ANSWER IS IN REG
\r
2699 ;ROUTINE TO CHECK NUMBER OF ARGUMENTS AND CREATE A CONSTANT TO POP THEM
\r
2700 ;OFF THE PUSH LIST. CALLED WITH XWD FCNAME,# OF ARGS
\r
2701 ;AT LOCATION -1(P) RETURNS WITH A POINTER TO CONSTANT
\r
2702 ;AT THAT LOCATION.
\r
2704 ARGCHK: HRRZ N,-1(P)
\r
2705 HRL N,N ;N NOW CONTAINS THE CONSTANT TO SUBTRACT FROM P
\r
2706 PUSHJ P,NNUM ;REGISTER THIS CONSTANT
\r
2707 MOVE N,-1(P) ;GET FCN NAME
\r
2708 MOVEM B,-1(P) ;SAVE ADDREESS OF CONSTANT
\r
2709 HRR N,B ;ASSEMBLER FADROL ENTRY...
\r
2710 HLLZ A,N ;SETUP SEARCH ARGUMENT
\r
2711 MOVEI R,FADROL ; XWD FCNAME,CONSTANT ADDRESS
\r
2713 JRST ARGCH1 ;FIRST TIME FCN SEEN. PUT ENTRY IN ROLL
\r
2714 CAME N,0(B) ;FCN SEEN BEFORE. SAVE NUMBER OF ARGS.
\r
2715 FAIL <INCORRECT NUMBER OF ARGUMENTS>
\r
2718 ARGCH1: MOVEI E,1 ;ADD FCN REF TO FADROL
\r
2723 ;INTRINSIC FUNCTION GENERATOR.
\r
2724 XINFCN: PUSH P,B ;SAVE FCN LOC
\r
2725 PUSHJ P,REGFRE ;PROTECT ANY PARTIAL RESULTS
\r
2729 FAIL <INCORRECT NUMBER OF ARGUMENTS>
\r
2731 XINF1: PUSHJ P,NXCHK
\r
2741 XINF3: PUSH P,[EXP 1]
\r
2743 \f;ROUTINE TO XLATE ARGUMENTS
\r
2744 ;RETURNS WITH ARGS ON SEXROL. B IS O IF ONE ARG, -1 IF TWO.
\r
2746 XARG: PUSHJ P,NXCHK ;SAVE PARENTHESIS.
\r
2747 PUSH P,LETSW ;SAVE LETSW WHILE TRANSL ARGS
\r
2748 MOVMS LETSW ;THE COMMA FOLLOWING AN ARG IS NOT LH(LET)!
\r
2754 TLNN C,F.COMA ;COMMA FOLLOWS?
\r
2755 JRST N,XARG1 ;NO. ONE ARG.
\r
2756 PUSHJ P,NXCHK ;YES GEN AND SAVE SECOND ARG
\r
2761 MOVNI B,1 ;DBL ARG FLAG
\r
2762 XARG1: POP P,LETSW ;RESTORE LETSW
\r
2763 TLNN C,F.RPRN ;MUST HAVE PARENTHESIS
\r
2765 JRST N,NXCHK ;IT DOES. SKIP RPAREN AND RETURN.
\r
2767 ;ROUTINE TO GEN ARGUMENTS
\r
2769 GENARG: JUMPE B,GENAFN ;ONE OR TWO ARGS?
\r
2770 PUSHJ P,POPPR ;TWO
\r
2774 GENAFN: PUSHJ P,POPPR
\r
2775 GENAF1: MOVSI D,(JUMP 2,)
\r
2777 \f;ROUTINE TO ANALYZE NEXT ELEMENT
\r
2778 ;CALL: PUSHJ P,REGLTR
\r
2779 ;RETURNS ROLL PNTR IN B, CODE IN A
\r
2780 ;CODE IS: 0-ARRAY, 1-SCALAR, 2-INTRINSIC FCN, 3-DEFINED FCN, 4-FAIL
\r
2781 ; 5-STRING VECTOR, 6-STRING VARIABLE, 7-STRING LITERAL.
\r
2783 REGLTR: PUSHJ P,SCNLT1 ;LTR TO A, LEFT JUST 7 BIT
\r
2784 HRRI F,SCAROL ;ASSUME SCALAR
\r
2785 TLNE C,F.LETT ;ANOTHER LETTER?
\r
2786 JRST REGFCN ;YES. GO LOOK FOR FCN REF
\r
2787 TLNN C,F.DIG ;DIGIT FOLLOWS?
\r
2788 JRST REGARY ;NO, GO CHECK FOR ARRAY
\r
2789 DPB C,[POINT 7,A,13];ADD DIGIT TO NAME
\r
2790 PUSHJ P,NXCHK ;GO ON TO NEXT CHAR
\r
2792 TLNE C,F.DOLL ;STRING VARIABLE?
\r
2793 JRST REGSTR ;YES. REGISTER IT.
\r
2796 ;RETURN HERE IF REGARY SAYS NOT ARRAY
\r
2797 ;RETURN HERE IF REGFCN SAYS FOLLOWED BY KEYWORD.
\r
2799 REGL1: TLNE A,17 ;IS THIS A SCALAR?
\r
2800 JRST REGL1A ;NO. DON'T LOOK FOR FCN ARGUMENT
\r
2801 MOVE B,FLARG ;IS THIS A FN ARG?
\r
2802 CAML B,CEARG ;SEARCH UNORDERED ARGROL
\r
2803 JRST REGL1A ;NOT A FN ARG
\r
2805 AOJA B,.-3 ;TRY NEXT ROLL ENTRY.
\r
2808 REGL1A: MOVEI R,VARROL ;NO. SCALAR
\r
2809 PUSHJ P,SEARCH ;IN VARIABLE ROLL?
\r
2812 HRRZ D,(B) ;YES. GET PNTR TO SCAROL
\r
2815 REGL2: MOVEI E,1 ;ADD TO SCALAR ROLL OR VSPROL
\r
2817 ADD A,CEIL(F) ;COMPUTE PNTR TO ROLL
\r
2819 HRRZ D,A ;SAVE ROLL POINTER
\r
2821 MOVEI R,(F) ;PUT NULL ENTRY ON ROLL
\r
2825 ; B ::= REL LOC OF ROLL ENTRY
\r
2827 REGL3: MOVE B,D ;B ::= REL LOC OF ROLL ENTRY
\r
2828 TLO B,(F) ;MAKE ROLL POINTER AND SKIP
\r
2831 ;COME HERE ON REF TO FCN ROL
\r
2833 ;CALCULATE ADDRESS OF THIS FUNCTION ARGUMENT.
\r
2834 FARGRF: SUB B,CEARG ;NOW ADDRESS IS -NN FOR FIRST ARG, -1 FOR NNTH ARG, ETC.
\r
2837 REGSCA: MOVEI A,1 ;CODE SAYS SCALAR
\r
2840 SCAREG: MOVEI F,SCAROL ;REGISTER THE CONTENTS OF A AS SCALAR
\r
2842 REGARY: CAIE C,"("
\r
2843 TLNE C,F.DOLL ;ARRAY OR POSSIBLE SRVECTOR REF?
\r
2848 REGA0: HRRI F,ARAROL ;NUMERICAL ARRAY GOES ON ARAROL
\r
2850 REGA1: TLO A,1 ;MAKE ARRAY NAME DIFFERENT FROM SCALAR
\r
2851 MOVEI R,VARROL ;LOOK FOR VARIABLE NAME
\r
2853 JRST N,REGA2 ;NOT ALREADY USED
\r
2854 HRRZ D,(B) ;GET POINTER TO ARAROL
\r
2857 REGA2: MOVEI E,1 ;ADD NEW ARRAY NAME TO VARIABLE ROLL
\r
2859 ADD A,CEIL(F) ;COMPUTE ARRAY OR STRING VECTOR ROLL POINTER
\r
2861 IORI A,400000 ;SET ARRAY FLAG
\r
2863 HRRZ D,A ;SAVE ARAROL POINTER
\r
2864 MOVEI R,(F) ;THREE ZEROS ON ARAROL (NULL ENTRY)
\r
2869 REGA3: MOVE B,D ;RECONSTRUCT PNTR
\r
2870 ANDI B,377777 ;B := REL ADDRS IN ARRAY ROLL
\r
2871 HRLI B,(F) ;B := POINTER TO ENTRY ON ROLL
\r
2872 MOVEI A,0 ;ARRAY CODE
\r
2876 ;SUBROUTINE TO REGISTER ARRAY NAME.
\r
2877 ;(USED BY DIM,MAT)
\r
2879 ARRAY: HRRI F,ARAROL ;ASSUME ITS NOT A STRING
\r
2882 PUSHJ P,SCNLT1 ;NAME TO A
\r
2883 TLNE C,F.DOLL ;STRING VECTOR?
\r
2884 JRST N,ARRAY2 ;YES, HANDLE DIFFERENTLY
\r
2886 ARRAY1: MOVE X1,B ;FINISH REGISTERING
\r
2892 ARRAY2: PUSHJ P,NXCHK
\r
2897 ARRAY3: PUSHJ P,REGSVR ;REGISTER STRING VECTOR
\r
2898 JRST ARRAY1 ;SET DEFAULT, IF NECESSARY
\r
2900 VECTOR: PUSHJ P,ARRAY ;REGISTER VECTOR
\r
2901 CAIE A,5 ;WAS A STRING REGISTERED?
\r
2902 JUMPN A,CPOPJ ;WAS AN ARRAY REGISTERED?
\r
2904 JUMPG X2,.+4 ;EXPLICIT DIMENSION?
\r
2905 MOVNI X2,777776 ;NO. CALL IT A VECTOR OF UNKNONW DIM.
\r
2909 TLNE X2,777776 ;IS THIS A ROW VECTOR?
\r
2910 TRNN X2,777776 ;OR A COLUMN VECTOR?
\r
2912 FAIL <USE VECTOR, NOT ARRAY,>
\r
2915 REGSTR: JUMPL F,GRONK
\r
2916 TLO A,10 ;MAKE STRING NAME DIFFERENT FROM OTHER NAMES.
\r
2917 HRRI F,VSPROL ;POINT WILL GO ON VARIABLE SPACE ROLL
\r
2918 TLNE C,F.DOLL ;SKIP DOLLAR SIGN?
\r
2919 PUSHJ P,NXCHK ;SKIP DOLLAR SIGN
\r
2920 CAIN C,"(" ;IS IT A STRING VECTOR?
\r
2922 PUSHJ P,REGL1 ;FIX VARIABLE TYPE CODE.
\r
2925 REGSL1: MOVEI R,11
\r
2929 MOVEI R,SADROL ;MOVE LITROL ADDRESS ON STR-LIT-ADR ROLL
\r
2932 SUB B,FLSAD ;GET REL ADRESS
\r
2933 HRLI B,SADROL ;SET UP POINTER.
\r
2939 QSKIP: PUSHJ P,NXCH ;SKIP TO NEXT QUOTE CHAR.
\r
2940 TLNE C,F.CR ;TERMINAL QUOTE MISSING?
\r
2942 TLNN C,F.QUOT ;END OF STRING?
\r
2943 JRST QSKIP ;NO, GO ON.
\r
2944 PUSHJ P,NXCH ;YES. GET NEXT CHAR AND RETURN.
\r
2948 REGSVR: HRRI F,SVRROL ;REGISTER STRING VECTOR
\r
2949 TLO A,11 ;MAKE NAME DIFFERENT FROM THE OTHERS
\r
2950 TLNE C,F.DOLL ;DOLLAR SIGN?
\r
2951 PUSHJ P,NXCHK ;YES, SKIP IT
\r
2953 PUSHJ P,REGA1 ;REGISTER AS AN ARRAY
\r
2955 REGS1: CAIE A,4 ;DID REGISTRATION FAIL?
\r
2956 ADDI A,5 ;NO. FIX TYPE CODE.
\r
2960 ;NOTE: IF THE SAME VARIABLE NAME IS USED AS A SCALAR, ARRAY,
\r
2961 ; STRING VECTOR, AND STRING, IT WILL BE DISTINGUISHED IN "VARROL"
\r
2962 ; BY THE FOLLOWING 4-BIT ENDINGS:
\r
2963 ; SCALAR 0; ARRAY 1; STRING 10; STRING VECTOR 11.
\r
2964 \f;TABLE OF MIDSTATEMENT KEYWORDS:
\r
2966 KWTBL: ASCII /GOTO/
\r
2972 ;REGISTER FUNCTION NAME
\r
2973 ;FIRST LETTER HAS BEEN SCANNED
\r
2975 ;IT IS POSSIBLE THAT WE HAVE SCANNED A ONE-LETTER VARIABLE NAME
\r
2976 ;FOLLOWED BY ONE OF THE KEYWORDS "TO" , "THEN", OR "STEP".
\r
2977 ;FIRST WE LOOK AHEAD TO SEE IF THIS IS SO;
\r
2978 ;IF IT IS WE GO BACK TO SCALAR CODE.
\r
2980 REGFCN: PUSH P,C ;SAVE T,C AROUND LOOK-AHEAD.
\r
2982 MOVEI X1,KWTBL ;TBL OF KEYWORDS
\r
2984 REGF1: PUSHJ P,QST ;TEST THIS KEYWORD.
\r
2990 REGF2: MOVEI X1,1(X1) ;NOT CURRENT KEYWORD
\r
2991 MOVE T,(P) ;RESTORE POINTERS DESTROYED BY QST
\r
2993 SKIPE (X1) ;MORE TO TEST?
\r
2995 POP P,T ;NO, NOT KEYWORD.
\r
2997 ;HAVE DETERMINED THAT WE MUST BE SCANNING A FUNCTION NAME
\r
2998 ;IF SYNTAX IS LEGAL.
\r
3000 ;WE SCAN THE SECOND LETTER AND CHECK FOR
\r
3001 ;INTRINSIC OR DEFINED FUNCTION.
\r
3005 JRST REGFAL ;NOT A LETTER
\r
3006 CAMN A,[SIXBIT /FN/] ;DEFINED FUNCTION?
\r
3007 JRST REGDFN ;YES. GO REGISTER DEFINED NAME.
\r
3014 MOVMS LETSW ;CAN'T BE LH(LET)
\r
3016 MOVEI A,2 ;INTRINSIC FCN CODE.
\r
3017 POPJ P, ;RETURN "XINFNC" DOES ITS OWN ")" CHECK.
\r
3018 \f;HERE TO REGISTER DEFINED FUNCTION NAME
\r
3019 ;THE "FN" HAS ALREADY BEEN SCANNED
\r
3021 ;SCAN IDENTIFYING LETTER AND PUTTING ENTRY IN
\r
3022 ;FUNCTION CALL ROLL
\r
3024 REGDFN: PUSHJ P,SCNLT1 ;PUT FUNCTION NAME IN A
\r
3025 CAMN A,FUNAME ;IS THIS THE NAME OF THE CURRENT MULTI-LINE FN?
\r
3026 JRST REGFNA ;YES. REGISTER IT AS A SCALAR.
\r
3027 MOVE D,A ;NO, REAL FUNCTION CALL. SAVE NAME FOR ARGCHK
\r
3028 MOVEI R,FCLROL ;FUNCTION CALL ROLL
\r
3029 PUSHJ P,SEARCH ;USED THIS ONE YET?
\r
3031 JRST REGFC1 ;ALREADY SEEN A REF
\r
3035 PUSHJ P,REGFC1 ;SET B UP FOR KLUDGE TEST
\r
3036 MOVE X1,FLSEX ;FIX UP SAVED FCN REFS
\r
3037 REGFC0: CAML X1,CESEX ;KLUDGE!!!
\r
3039 HLRZ X2,(X1) ;GET THE ROLL NUMBER
\r
3040 CAIN X2,FCLROL ;FCLROL?
\r
3041 CAMLE B,(X1) ;YES. IS SEXREF NOW WRONG?
\r
3043 AOS (X1) ;YES. CORRECT IT
\r
3046 REGFC1: SUB B,FLFCL
\r
3048 MOVEI A,3 ;DEFINED FCN CODE
\r
3049 POPJ P, ;DON'T CHECK FOR () YET
\r
3051 CHKPRN: CAIE C,"("
\r
3052 REGFAL: MOVEI A,4 ;FAIL IF NO PAREN
\r
3055 REGFNA: TLO A,(177B13) ;CREATE SPECIAL NAME FOR CURRENT FUNCTION
\r
3056 JRST N,SCAREG ;REGISTER IT AS A SCALAR
\r
3057 \f SUBTTL SUBROUTINES USED BY GEN ROUTINES
\r
3059 ;PUSHPR - PUSH PARTIAL RESULT ON SEXROL
\r
3061 PUSHPR: MOVEI R,SEXROL
\r
3062 MOVE A,B ;SAVE POINTER IN A
\r
3064 SUB B,FLSEX ;MAKE POINTER
\r
3065 TLNN A,ROLMSK ;IS IT A POINTER TO REG?
\r
3066 HRROM B,REGPNT ;YES, SET POINTER FOR SITGEN TO USE
\r
3069 ;POPPR - POP PARTIAL RESULT FROM SEXROL
\r
3071 POPPR: MOVEI R,SEXROL
\r
3073 SUBI B,1 ;COMPUTE ADDRS OF TOP OF SEXROL
\r
3074 PUSH P,(B) ;SAVE THE CONTENT
\r
3077 POP P,B ;POPPED POINTER TO B
\r
3078 POPPFN: TLNN B,ROLMSK ;POINTER TO REG?
\r
3079 SETZM REGPNT ;YES. CLEAR MEMORY
\r
3081 ;EXCHG - EXCHANGE CURRENT PNTR WITH TOP OF SEXROL
\r
3083 EXCHG: MOVE X1,CESEX
\r
3084 MOVEI X2,-1(X1) ;FIX PNTR IF REG SAVED
\r
3089 JRST POPPFN ;GO FIX PNTR IF REG POPPED
\r
3091 ;REGFRE - GUARANTEE THAT NO PART RESULT IS IN REG
\r
3093 REGFRE: SKIPN REGPNT ;SUBEXP IN THE REG?
\r
3095 MOVE X1,FLSEX ;YES. COMPUTE WHERE
\r
3097 EXCH B,(X1) ;GET THE POINTER, SAVE CURR PNTR
\r
3098 PUSHJ P,SITGEN ;STORE IN TEMP
\r
3099 MOVE X1,FLSEX ;RECOMPUTE LOC IN SEXROL
\r
3102 SETZM REGPNT ;CLOBBER REGPNT SINCE REG IS EMPTY
\r
3104 \f;GPOSGE - GUARANTEE POSITIVE GEN
\r
3106 GPOSGE: JUMPGE B,CPOPJ ;RETURN IF ALREADY POSITIVE
\r
3109 ;EIRGEN - EXP IN REG GEN
\r
3111 EIRGEN: TLNN B,ROLMSK ;ALREADY IN REG?
\r
3112 POPJ P, ;DO NOTHING
\r
3113 ERGNFN: PUSHJ P,REGFRE ;FREE UP REG
\r
3114 MOVSI D,(MOVE N,) ;GET MOVE INSTR
\r
3115 PUSHJ P,BUILDS ;BUILD MOVE INSTR
\r
3116 MOVEI B,0 ;POSITIVE REG POINTER
\r
3119 ;EIRGNP - EXP IN REG GEN POSITIVE
\r
3121 EIRGNP: JUMPGE B,EIRGEN ;POSITIVE?
\r
3122 TLNE B,ROLMSK ;NO. IN REG?
\r
3123 JRST ERGNFN ;NO. GO MOVE
\r
3124 MOVSI D,(MOVN N,) ;YES,NEGATIVE N
\r
3126 MOVEI B,0 ;POSITIVE REG PNTR
\r
3129 ;SIPGEN - STORE IN PERMANENT TEM GEN
\r
3131 SIPGEN: MOVEI R,PTMROL
\r
3134 ;SITGEN - STORE IN TEMP GEN
\r
3136 SITGEN: MOVEI R,TMPROL
\r
3137 SITGN1: TLNE B,ROLMSK ;IS EXPR IN REG?
\r
3138 POPJ P, ;NO. DONT DO ANYTHING
\r
3139 MOVEI A,0 ;PREPARE ZERO TO PUSH ON ROLL
\r
3140 MOVSI D,(MOVEM N,) ;GET CORRECT INSTR
\r
3142 MOVSI D,(MOVNM N,)
\r
3143 CAIE R,TMPROL ;STORE ON TMPROL?
\r
3144 JRST N,SITG2 ;NO. USE PTMROL
\r
3145 AOS B,TMPPNT ;WHICH TEMP TO USE?
\r
3148 CAML X1,CETMP ;NEED MORE TMP SPACE?
\r
3149 PUSHJ P,RPUSH ;YES. PUSH Z ZERO ONTO TMPROL
\r
3150 MOVE B,TMPPNT ;CONSTRUCT TMP ROLL POINTER
\r
3152 PUSH P,B ;SAVE ADRESS POINTER
\r
3153 PUSHJ P,BUILDA ;BUILD STORE INSTR
\r
3154 POP P,B ;RECONSTRUCT POINTER
\r
3157 SITG2: PUSHJ P,RPUSH ;PUSH A ZERO ONTO PTMROL
\r
3159 JRST SITG1 ;FINISH CONSTRUCTING ADRESS POINTER
\r
3160 ;GPOSNX - GUARANTEE POSITIVE AND UNINDEXED GEN
\r
3162 GPOSNX: TLNE B,400000+PSHROL ;NEGATIVE OR INDEXED BY (P)?
\r
3163 PUSHJ P,EIRGNP ;YES. FORCE INTO REG
\r
3165 \fBUILDP: TLO D,P ;INSTRUCTION IS INDEXED BY PLIST POINTER
\r
3166 SUB B,PSHPNT ;ADJUST THE ADDRESS FOR ANY PUSH INSTS GENNED BY
\r
3167 HRR D,B ; A CURRENT FN CALL
\r
3169 ;ROUTINE TO ADD CODE TO CODROL.
\r
3170 ;A WORD IS ASSUMED IN D
\r
3171 ;RETURN REL ADDRS IN B
\r
3173 BUILDI: SKIPN RUNFLA ;ARE WE GOING TO RUN?
\r
3174 POPJ P, ;NO. DONT GEN CODE
\r
3183 ;BUILD SIGNED INSTRUCTION WITH ADDRESS
\r
3184 ;CHECK SIGN IN B AND CHANGE UP CODE BITS
\r
3186 BUILDS: JUMPGE B,BUILDA ;POSITIVE?
\r
3187 TLC D,10000 ;NO. CHANGE MOVE TO MOVN, ETC.
\r
3190 ;BUILDA - BUILD INSTRUCTION WITH LINKED ADDRESS
\r
3191 ;INSTRUCTION SKELETON IS IN D, ADDRESS POINTER IS IN B
\r
3193 BUILDA: SKIPN RUNFLA ;ARE WE GOING TO RUN?
\r
3194 POPJ P, ;NO. DONT BUILD
\r
3195 TLZE B,PSHROL ;SPECIAL TEST FOR ROLL WITH ABSOLUTE ADDRESS
\r
3196 JRST BUILDP ;YES. PSHROL. DO BUILDI INDEXED BY (Q)
\r
3197 JUMPE B,BUILDI ;ITEM IS IN REG . USE ADDRESS ZERO
\r
3199 PUSH P,B ;SAVE THE POINTER
\r
3200 PUSHJ P,BUILDI ;ADD INSTR WITH 0 ADDRS TO CODE
\r
3201 MOVE X1,CECOD ;LOC+1 OF THE INSTR
\r
3202 POP P,X2 ;COMPUTE ADDRS LOCATION
\r
3203 LDB R,[POINT 17,X2,17]
\r
3205 MOVE Q,(X2) ;GET NEXT ADDRS IN CHAIN
\r
3206 HRRM Q,-1(X1) ;STORE IT IN THE INSTR
\r
3209 HRRM X1,(X2) ;STORE CURR ADDRS IN ROLL PNTD TO
\r
3211 \f SUBTTL UTILITY SUBROUTINES
\r
3212 ;SUBROUTINES FOR GENERAL ROLL MANIPULATION
\r
3214 CLOSUP: MOVN X1,E ;COMPUTE NEW END OF ROLL
\r
3215 ADDB X1,CEIL(R) ;AND STORE IT
\r
3216 MOVE X2,B ;CONSTRUCT BLT WORD
\r
3220 BLT X2,-1(X1) ;MOVE DOWN TOP OF ROLL
\r
3223 CLOB: MOVEI T1,COMTOP ;ROUTINE TO CLOBBER ALL MOVEABLE ROLLS.
\r
3226 CAILE T1,1(X1) ;DO NOT CLOBBER ROLLS <=(X1)
\r
3232 OPEN2: MOVE X2,E ;IS THERE ROOM ABOVE THIS STODGY ROLL?
\r
3233 ADD X2,CEIL(R) ;THE NEW CEILING
\r
3234 CAMLE X2,FLOOR+1(R)
\r
3235 JRST N,OPENU0 ;NO ROOM, PACK OTHER ROLLS UP
\r
3236 ADDM E,CEIL(R) ;THERE IS ROOM, INCREMENT CEILING
\r
3239 OPENU0: SUB B,FLOOR(R)
\r
3243 OPENUP: CAMG R,TOPSTG ;OPEN UP THE TOP STODGY ROLL?
\r
3244 JRST N,OPEN2 ;YES. OPEN UPWARDS, NOT DOWN
\r
3246 MOVE Q,TOPSTG ;DO NOT MOVE STODGY ROLLS
\r
3248 CAMGE X2,CEIL+0(Q)
\r
3249 JRST N,OPENU0 ;NEED MORE ROOM
\r
3250 HRL X2,FLOOR+1(Q) ;CONTRUCT BLT WORD
\r
3251 SUB B,E ;FIRST WORD OF GAP
\r
3252 BLT X2,-1(B) ;MOVE ROLLS DOWN
\r
3254 MOVEI X1,1(Q) ;ADJUST POINTERS FOR ROLLS JUST BLT'D
\r
3256 OPEN1: ADDM X2,FLOOR(X1)
\r
3263 ;RPUSH - PUSH A ON TOP OF DESIGNATED ROLL
\r
3266 PUSHJ P,BUMPRL ;MAKE ROOM
\r
3267 MOVEM A,(B) ;STORE WORD
\r
3270 ;ROUTINE TO ADD TO END OF ROLL
\r
3271 ;E CONTAINS SIZE, R CONTAINS ROLL NUMBER
\r
3273 BUMPRL: MOVE B,CEIL(R)
\r
3276 SKIPA X1,FLOOR+1(R)
\r
3282 BUMP1: MOVE B,CEIL(R)
\r
3287 ADDI E,^D10 ;***EXTRA 10 LOCS
\r
3289 MOVNI X1,^D10 ;TAKE BACK THE 10 LOCS
\r
3294 ;BINARY SEARCH OF SORTED ROLL
\r
3295 ;CALL WITH KEY IN A
\r
3296 ;RETURN IN B ADDRS OF FIRST
\r
3297 ;ENTRY NOT LESS THAN KEY
\r
3298 ;SKIP RETURN IF LEFT SIDES EQUAL
\r
3300 SEARCH: MOVE B,FLOOR(R)
\r
3302 SEAR1: MOVEI B,1(X2)
\r
3309 SEAR2: MOVEI X2,@X1
\r
3323 \f;ROUTINE TO QSA FOR "THEN" OR "GOTO" (USED IN "IF", "ON" STATEMENTS)
\r
3324 THENGO: PUSHJ P,QSA
\r
3330 FAIL <ILLEGAL FORMAT>
\r
3333 ;COMMON SUBROUTINE RETURNS
\r
3340 ILFORM: FAIL <ILLEGAL FORMULA>
\r
3341 ILVAR: FAIL <ILLEGAL VARIABLE>
\r
3342 GRONK: FAIL <ILLEGAL FORMAT>
\r
3343 ILLINS: FAIL <ILLEGAL INSTRUCTION>
\r
3346 ;COMPILATION ERROR
\r
3349 FAILER: SKIPN RUNFLA ;IS THIS THE FIRST ERROR IN COMPILATION?
\r
3351 PUSHJ P,INLMES ;YES. SETUP <CRLF> TO FOLLOW HEADING.
\r
3354 FAIL0: PUSHJ P,FAIL1
\r
3359 LDB X1,[POINT 4,40,12] ;IS AC FIELD NONZERO?
\r
3361 MOVE T,N ;ATTACH NUMBER IN 'N' TO MSG
\r
3363 FAIL2: PUSHJ P,INLMES
\r
3375 ;ROUTINES TO ALLOW AND DELAY REENTRY.
\r
3376 ;LOCKON TEMPORARILY PREVENTS REENTRY
\r
3377 ;LOCKOF ALLOWS REENTRY AND REENTERS IF THERE IS A STANDING REQUEST
\r
3378 ;REENTR MAKES A REENTRY OR MAKES A REQUEST AND CONTINUES
\r
3380 LOCKON: SKIPGE RENFLA
\r
3381 SETZM RENFLA ;TURN ON REENETER PROTECT
\r
3383 LOCKOF: SKIPLE RENFLA
\r
3384 JRST BASIC ;ACT ON OLD REENTER REQUEST
\r
3385 SETOM RENFLA ;ALLOW REENTER
\r
3387 REENTR: SKIPGE RENFLA
\r
3391 \f;ROUTINE TO READ CHARACTER, SKIPPING BLANKS
\r
3392 ;CALL: MOVE T,<POINTER TO CHAR BEFORE FIRST>
\r
3394 ; ... RETURN, C:= (<FLAGS>)CHARACTER
\r
3396 NXCHS: ILDB C,T ;DOESNT SKIP TAB OR BLANK
\r
3400 CAIA ;SKIP INTO NXCH
\r
3401 NXCH: ILDB C,T ;FETCH NEXT CHARACTER
\r
3404 HRL C,CTTAB-100(5)
\r
3405 TLNE C,F.SPTB ;SPACE OR TAB?
\r
3406 JRST N,NXCH ;YES. IGNORE
\r
3408 ;GET NEXT CHAR, BUT CHECK FOR ILLEGAL CHARS (CHARS THAT COULD ONLY BE IN A STRING)
\r
3409 NXCHK: PUSHJ P,NXCH
\r
3411 FAIL <ILLEGAL CHARACTER>
\r
3414 ;SCAN INITIAL LETTER, LETTER IS PLACED LEFT
\r
3415 ;JUSTIFIED IN A, 7-BIT ASCII.
\r
3421 ;SCAN SECOND LETTER, NON-SKIP RETURN IF NOT LETTER.
\r
3422 ;MAKE 7-BIT LETTER LEFT JUST IN A
\r
3423 ;INTO 6-BIT. THAN PUT 6-BIT CURRENT LETTER IN A.
\r
3425 SCNLT2: TLNN C,F.LETT
\r
3427 SCN2: TLNN A,400000 ;ENTER HERE TO PROCESS NON-LETTER CHARS
\r
3431 MOVE X1,[POINT 6,A,5]
\r
3434 ;ENTER HERE TO SCAN SECOND CHAR EVEN IF BOTH ARE NOT LETTERS.
\r
3437 ;SCAN THIRD LETTER, NON-SKIP IF NOT LETTER.
\r
3438 ;PUT 6-BIT LETTER TO 3RD 6-BIT FIELD IN A.
\r
3440 SCNLT3: TLNN C,F.LETT
\r
3442 MOVE X1,[POINT 6,A,11]
\r
3444 ;NOW PUT 6-BIT LETTER INTO A, ADJUSTING LOWER CASE, INCREMENTING POINTER.
\r
3446 SCNLTN: TLNN C,F.LCAS
\r
3451 \f;QUOTE SCAN AND TEST
\r
3452 ;CALL WITH PATTERN ADDRS IN X1
\r
3453 ;SKIP IF EQUAL. C,T UPDATED TO LAST CHAR SCANNED.
\r
3454 QST: HRLI X1,440700 ;MAKE BYTE PNTR TO PATTERN
\r
3455 QST1: ILDB X2,X1 ;GET PATTERN CHAR
\r
3456 JUMPE X2,CPOPJ1 ;DONE ON NULL
\r
3458 JUMPE X2,.+4 ;DO CHARACTERS MATCH?
\r
3459 TLNE C,F.LCAS ;NO. LOWER CASE LETTER?
\r
3460 CAME X2,[ EXP -40] ;YES. SAME LETTER OF ALPHABET?
\r
3461 JRST QST2 ;NO. MATCH FAILS
\r
3464 QST2: ILDB X2,X1 ;ON FAIL
\r
3465 JUMPN X2,.-1 ;SKIP TO NULL
\r
3469 ;QUOTE SCAN OR FAIL
\r
3470 ;CALL WITH INLINE PATTERN
\r
3471 ;GO TO GRONK IF NO MATCH
\r
3478 ;QUOTE SCAN WITH ANSWER
\r
3479 ;CALL WITH INLINE PATTERN
\r
3480 ;SKIP ON SUCCESS ;ON FAIL, RETURN WITH C,T RESTORED
\r
3482 QSA: POP P,X1 ;GET PATTERN ADDRESS
\r
3483 PUSH P,C ;SAVE C,T
\r
3485 PUSHJ P,QST ;SAVE STRING
\r
3488 POP P,T ;NO MATCH. BACK UP
\r
3496 ;ROUTINE TO READ NEXT INTEGER FROM SCANNED LINE
\r
3497 ;CALL: MOVE T,POINTER TO FIRST CHAR
\r
3500 ; ... SUCCESS RETURN, INTEGER IN N
\r
3502 GETNU: TDZA X1,X1 ;GET A NUMBER OF ANY LENGTH
\r
3503 GETNUM: MOVEI X1,5 ;GET A NUMBER OF AT MOST 5 DIGS
\r
3504 TLNN C,F.DIG ;NUMERAL?
\r
3505 POPJ P, ;NO. FAIL RETURN
\r
3506 MOVEI N,-60(C) ;YES. ACCUMULATE FIRST DIGIT
\r
3507 GETN1: MOVE G,T ;SAVE PNTR FOR USE BY INSERT
\r
3508 PUSHJ P,NXCH ;GET NEXT CHAR
\r
3509 SOJE X1,CPOPJ1 ;EXIT IF FIVE DIGITS ALREADY
\r
3510 TLNN C,F.DIG ;NUMERAL?
\r
3511 JRST CPOPJ1 ;NO. RETURN.
\r
3512 IMULI N,^D10 ;YES. ACCUMULATE NUMBER
\r
3514 JRST GETN1 ;GO FOR MORE
\r
3515 ;ROUTINE TO READ A LINE INTO LINB0
\r
3516 ;CALL: PUSHJ P,INLINE
\r
3518 INLINE: SETOM TYI+2
\r
3519 MOVE T,[POINT 7,LINB0]
\r
3523 INLI1: ILDB C,TYI+1 ;GET CHAR
\r
3527 CAIN C,"_" ;DELETE?
\r
3532 CAIE C,21 ;IGNORE XON,XOFF
\r
3535 CAIG C,14 ;LINE TERMINATOR?
\r
3538 JRST INLI2 ;YES. GO FINISH UP
\r
3539 CAIGE T1,^D94 ;ROOM FOR CHAR+1 MORE?
\r
3540 IDPB C,T ;STORE CHAR
\r
3541 INLI1A: SOSLE TYI+2 ;MORE INPUT?
\r
3542 AOJA T1,INLI1 ;YES. BUMP COUNT AND GO GET MORE
\r
3550 ASCIZ /SYSTEM ERROR/
\r
3552 INLI2: MOVEI C,15 ;DONE. PUT CR IN BFR
\r
3554 MOVE T,[POINT 7,LINB0]
\r
3557 INLI3: JUMPE T1,INLI1A ;BACKARROW HANDLER, IGNORE IF AT LEFT
\r
3563 INLI4: MOVEI T,INLI5
\r
3564 CALL T,[SIXBIT /DDTOUT/]
\r
3566 INLI5: ASCIZ / DELETED
\r
3569 ;ROUTINE TO START READING NEXT LINE OF PROGRAM
\r
3570 NXLINE: MOVE T,FLLIN
\r
3573 MOVS D,T ;SAVE LINE START
\r
3575 MOVE G,FLREF ;SETUP REFROL REFERENCE.
\r
3578 ;PRINTING SUBROUTINES
\r
3580 ;PRINT TO QUOTE CHAR
\r
3581 ;CALL: MOVE T,<ADDRS OF MSG>
\r
3582 ; MOVE D,<QUOTE CHAR>
\r
3584 ;CALL: MOVE T,<ADDRS OF MSG>
\r
3585 ; MOVE D,<QUOTE CHAR>
\r
3587 ;ALTERNATE CALL: PRINT1, IF BYTE PNTR IN T.
\r
3590 PRINT: HRLI T,440700
\r
3594 PUSHJ P,OUCH ;OUTPUT THE CHAR
\r
3603 \f;ROUTINE TO PRINT SIXBIT CHARACTERS IN ACCUM "T".
\r
3607 PRNSIX: MOVE T1,[POINT 6,T]
\r
3609 JUMPE C,PRNS1 ;SKIP A BLANK
\r
3612 PRNS1: TLNE T1,770000 ;ALL SIX PRINTED?
\r
3615 PRNS2: JUMPE X1,PRDE2
\r
3620 \f;SPECIAL DECIMAL PRINT ROUTINE. PRINTS X1,X2 AS DECIMAL NUMBERS
\r
3621 ;SEPARATED BY THE CHARACTER IN ACCUM "A".
\r
3622 ;IF X1 OR X2 ARE ZERO, THEY PRINT AS "00".
\r
3627 PRDE2A: PUSHJ P,OUCH
\r
3630 PRDE1: MOVEI C,"0" ;A ONE DIGIT NUMBER?
\r
3632 PUSHJ P,OUCH ;YES. PUT OUT LEADING ZERO.
\r
3634 PTIME: SKIPE N,174
\r
3637 RTIME: PUSHJ P,INLMES
\r
3641 CALL X2,[SIXBIT /RUNTIM/] ;GET TIME NOW.
\r
3642 SUB X2,MTIME ;GET ELAPSED TIME.
\r
3643 IDIVI X2,^D10 ;REMOVE THOUSANDS.
\r
3644 IDIVI X2,^D100 ;SECS TO X1, THENTS AND HUNDREDS TO X2.
\r
3645 MOVE T,X2 ;OUTPUT THE
\r
3647 PUSHJ P,PRTNUM ;SECONDS.
\r
3648 MOVEI C,"." ;OUTPUT ., THE TENTHS,
\r
3649 PUSHJ P,PRDE2A ;AND THE HUNDREDTHS.
\r
3657 ;NUMBER PRINTER (PRINTS INTERGER IN T)
\r
3660 PRTNUX: TDZA X1,X1
\r
3665 PRTNUM: IDIVI T,^D10
\r
3670 PRTN1: MOVEI C,60(T1)
\r
3672 PSIGN: MOVEI C," " ;PRINT "SIGN" (BLANK OR MINUS)
\r
3680 INLMES: EXCH T,(P) ;GET MSG ADR AND SAVE T.
\r
3681 MOVEI D,0 ;END ON NULL
\r
3684 JRST CPOPJ1 ;RTN AFTER MSG.
\r
3685 \f SUBTTL CORE COMPRESSION AND EXPANSION
\r
3686 ;PANIC - ROUTINE TO COMPRESS CORE
\r
3688 PANIC: PUSHJ P,PRESS ;COMPRESS MEMORY
\r
3689 MOVE Q,TOPSTG ;IS THERE ROOM BETWEEN STODGY AND
\r
3690 MOVE X1,FLOOR+1(Q) ;MOVEABLE ONES?
\r
3692 CAML X1,E ;ENOUGH ROOM?
\r
3695 MOVE X1,JOBREL ;EXPAND BY 1K
\r
3697 CALL X1,[SIXBIT /CORE/]
\r
3700 PANIC1: PUSHJ P,INLMES
\r
3701 ASCIZ /OUT OF ROOM/
\r
3704 PRESS: PUSH P,G ;SAVE AC
\r
3705 SKIPN PAKFLA ;ARE LINES PACKED?
\r
3709 MOVE X1,FLTXT ;LOOK FOR EMPTY SPACE
\r
3710 PRESS2: CAML X1,CETXT ;THROUGH LOOKING?
\r
3712 SKIPE (X1) ;A FREE WORD?
\r
3713 AOJA X1,PRESS2 ;NO
\r
3715 MOVEI X2,1(X1) ;YES
\r
3716 PRESS3: CAML X2,CETXT
\r
3717 JRST PRESS4 ;FREE TO END
\r
3721 SUB X1,X2 ;X1 :=-LNG OF MOVE
\r
3723 PRES3A: CAML Q,CELIN ;MOVE DOWN THE REFERENCES
\r
3724 JRST PRES3B ;IN THE LINE ROLL
\r
3730 PRES3B: MOVE G,CETXT ;MOVE DOWN THE TEXT ROLL
\r
3741 ;ROUTINE TO MOVE ROLLS UP
\r
3745 PRESS5: MOVEI G,ROLTOP ;HIGHEST MOVABLE ROLL
\r
3746 MOVE X1,JOBREL ;X1 IS PREVIOUS FLOOR
\r
3747 ;NOTE: TOP WORD OF USR CORE IS LOST
\r
3749 PRESS6: MOVE X2,CEIL(G) ;GET OLD CEIL AND FLOOR
\r
3751 SUBI X2,1 ;SET UP X2 FOR POP LOOP
\r
3753 MOVEM X1,CEIL(G) ;NEW CEILING
\r
3755 PRESS7: CAILE Q,(X2) ;DONE?
\r
3757 POP X2,-1(X1) ;MOVE ONE WORD
\r
3760 PRESS8: MOVEM X1,FLOOR(G) ;NEW FLOOR
\r
3761 SOS G ;GO TO NEXT LOWER ROLL
\r
3762 CAMLE G,TOPSTG ;IS THIS ROLL MOVEABLE?
\r
3763 JRST PRESS6 ;YES. GO PRESS IT.
\r
3764 PRESS9: POP P,G ;RESTORE G
\r
3767 \f;THIS ROUTINE OBTAINS SPACE IN THE "FREE CORE AREA" FOR REAL STRINGS,
\r
3768 ;APPEND BLOCKS, THE TEMPORARY STRINGS WHICH ARE THE RESULTS OF
\r
3769 ;STRING FUNCTIONS, AND BUFFERS FOR DATA FILES. IT HAS SIX ENTRY POINTS:
\r
3770 ;VCHCKC AND VCHCKW FOR REAL STRINGS, VCHTSC AND VCHTSW FOR TEMPORARY
\r
3771 ;STRINGS, VCHAPP FOR APPEND BLOCKS, AND VCHBUF FOR DATA FILES.
\r
3772 ;STRINGS HAVE TWO ENTRY POINTS SO THAT THEY MAY REQUEST SPACE IN UNITS
\r
3773 ;OF EITHER CHARACTERS OR WORDS. THE REQUEST IS IN AC T. NO OTHER
\r
3774 ;AC'S ARE DESTROYED. THE LOCATION OF THE LOWER BOUND OF THE OBTAINED
\r
3775 ;SPACE IS RETURNED IN AC T.
\r
3778 VCHCKC: MOVEI E,25
\r
3781 VCHCK1: MOVE X1,VARFRE
\r
3789 VCHCK2: MOVE X1,JOBREL
\r
3791 CALL X1,[SIXBIT /CORE/]
\r
3797 VCHCK4: HRRZI X2,-1
\r
3800 VCHCK5: CAML Q,SVRTOP
\r
3808 VCHCK6: AOJA Q,VCHCK5
\r
3812 VCHCK7: JUMPE X1,VCHCKE
\r
3817 VCHCK8: HRL G,(X1)
\r
3836 \fSUBTTL DECIMAL NUMBER EVALUATE/PRINT
\r
3837 ;ROUTINE TO EVALUATE NUMBER
\r
3838 ;T: PNTR TO FIRST CHAR, C: FIRST CHAR
\r
3839 ;NON-SKIP IS FAIL RETURN
\r
3840 ;RETURN NUMBER IN N
\r
3842 ;N: ACCUM NBMR, B: SCA FAC, D: DIG CNT, USE FLGS IN LEFT OF F
\r
3844 EVANUM: SETZB N,B ;CLEAR ACS
\r
3846 MOVEI F,0(F) ;CLEAR LH OF F
\r
3848 TLNE C,F.PLUS ;SKIP +
\r
3850 TLNN C,F.MINS ;CHECK FOR -
\r
3852 TLO F,F.MIN ;SET MINUS FLG
\r
3853 EVAN1: PUSHJ P,NXCH
\r
3854 EVAN2: TLNN C,F.DIG ;DIGIT?
\r
3856 TLO F,F.NUM ;DIGIT SEEN FLAG
\r
3857 JUMPE N,EVAN2A ;DONT COUNT LEADING ZEROS
\r
3858 SOJG D,EVAN2A ;COUNT DIGIT, GO ACCUM IF OK
\r
3859 ; REST OF DIGITS ARE INSIGNIFIGANT.
\r
3860 AOJA B,EVAN2B ;LEAD OR TRAIL 0, FUDGE SCA FAC
\r
3862 EVAN2A: IMULI N,^D10 ;ACCUMULATE DIGIT
\r
3864 EVAN2B: TLNE F,F.DOT ;DECIMAL SEEN?
\r
3865 SUBI B,1 ;YES. COUNT DOWN SCALE FACT
\r
3866 JRST EVAN1 ;GO TO NEXT CHAR
\r
3868 EVAN3: TLNN C,F.PER ;NOT DIGIT. DEC PNT?
\r
3870 TLOE F,F.DOT ;YES, SET FLG & CHK ONLY ONE
\r
3871 POPJ P, ;2 DEC PNTS
\r
3873 EVAN4: TLNN F,F.NUM ;DID WE SEE A DIGIT?
\r
3874 POPJ P, ;NO. WHAT A LOUSY NUMBER
\r
3877 CAIE X1,(C) ;EXPLICIT SCALE FACTOR?
\r
3879 PUSHJ P,NXCH ;DO LOOK AHEAD
\r
3880 TLNE C,F.PLUS ;SCALE FACTOR SIGN
\r
3885 EVAN5: PUSHJ P,NXCH
\r
3886 EVAN6: TLNN C,F.DIG ;CHK FOR DIGIT
\r
3888 MOVEI A,-60(C) ;SAVE FIRST EXPON DIGIT
\r
3890 TLNN C,F.DIG ;IS THERE A SECOND DIGIT
\r
3892 IMULI A,^D10 ;YES. ACCUMULATE IT
\r
3894 PUSHJ P,NXCH ;DO LOOK AHEAD
\r
3896 EVAN7: TLNE F,F.MXP ;NEG EXPON?
\r
3897 MOVN A,A ;YES. NEGATE IT
\r
3898 ADD B,A ;ADD TO SCALE FACTOR
\r
3899 EVAN8: JUMPE N,CPOPJ1 ;IGNORE SCALE IF NUMBER IS ZERO
\r
3900 EVAN8A: MOVE X1,N ;)
\r
3901 IDIVI X1,^D10 ;)REMOVE ANY TRAILING ZEROS
\r
3902 JUMPN X2,EVAN8B ;) IN MANTISSA.. (REASON:
\r
3903 MOVE N,X1 ;) SO THAT, E.G., .1,
\r
3904 AOJA B,EVAN8A ;) .10, .100,... ARE THE SAME)
\r
3908 TLO N,233000 ;FLOAT N
\r
3910 JOV .+1 ;CLEAR OVER/UNDERLFOW FLAG
\r
3911 EVAN8C: CAIGE B,^D15 ;SCALE UP IF .GE. 10^15
\r
3913 SUBI B,^D14 ;SUBTRACT 14 FROM SCALE FACTOR
\r
3914 FMPR N,D1E14 ;MULTIPLY BY 10^14
\r
3915 JRST EVAN8C ;GO LOOK AT SCALE AGAIN
\r
3916 EVAN8D: CAML B,[EXP -^D4] ;SCALE DONW IF .LT. 10^-4
\r
3918 ADDI B,^D18 ;ADD 18 TO SCALE
\r
3919 FMPR N,D1EM18 ;MULTIPLY BY 10^-18
\r
3920 JRST N,EVAN8D ;GO LOOK AT SCALE AGAIN
\r
3921 EVAN8E: FMPR N,DECTAB(B) ;SCALE N
\r
3922 TLNE F,F.MIN ;MINUS
\r
3923 MOVN N,N ;YES. NEGATE IT.
\r
3925 JRST CPOPJ1 ;SUCCESS RETURN, NUMBER IN N
\r
3926 \f;ROUTINE TO PRINT NUMBER
\r
3928 OUTNUM: SETOM STRFCN
\r
3931 PUSH P,E ;DO NOT CLOBBER E (FOR MATRIX)
\r
3932 MOVEI E,0 ;CHANGE IN EXPONENT
\r
3933 OUTN1A: CAMG T,D1E14 ;SCALE IF .GT. 10^14
\r
3935 ADDI E,^D18 ;ADD 18 TO SCALE
\r
3936 FMPR T,D1EM18 ;AND MULTIPLY BY 10^-18
\r
3938 OUTN1B: CAML T,D1EM4 ;SCALE IF .LT. 10^-4
\r
3940 SUBI E,^D14 ;SUBTRACT 14 FROM SCALE
\r
3941 FMPR T,D1E14 ;AND MULT BY 10^14
\r
3942 JRST OUTN1B ;GOT SEE IF MORE SCALING
\r
3943 OUTN1C: MOVE A,T ;LOOK UP IN DEC ROLL
\r
3946 JFCL ;DONT CARE IF FOUND
\r
3947 CAME A,(B) ;FUDGE BY 1 IF EXACT MATCH
\r
3949 SUBI B,DECTAB ;FIND DIST FROM MIDDLE
\r
3950 JUMPN E,OUTN2 ;(NOT INTEGER IF WE SCALED)
\r
3951 CAIGE B,^D8 ;CHK 8 DIG NUMBER
\r
3954 CAML T,FIXCON ;IS THIS 2^26?
\r
3955 JRST OUTN1D ;YES, ITS 27 BIT INT.
\r
3957 FAD X1,FIXCON ;INTEGER?
\r
3960 JRST OUTN2 ;NOT SUCH (LOST FRACTIONAL PART)
\r
3961 FAD T,FIXCON ;SUCH. FIX NUMBER
\r
3963 OUTN1D: TLZ T,377000 ;(IN CASE 27-BIT INTEGER)
\r
3964 POP P,E ;RESTORE E
\r
3967 OUTN2: FDVR T,DECTAB(B) ;GET MANTISSA
\r
3971 CAMGE T,[EXP ^D1000000]
\r
3973 IDIVI T,^D10 ;ROUNDING MADE 7 DIGITS
\r
3974 ADDI B,1 ;MAKE IT 6 AGAIN
\r
3975 CAIL T,^D100000 ;ROUNDING MADE 5 DIGITS?
\r
3977 IMULI T,^D10 ;YES. MAKE 6 AGAIN
\r
3979 ADDB B,E ;ADD TOGETHER TWO PARTS OF SCALE
\r
3980 AOJL E,.+2 ;BETWEEN 10^-1 AND 10^6?
\r
3982 SKIPA E,[EXP 1] ;NO. PRINT 1 DIG BEFORE POINT
\r
3983 PUSHJ P,CHKNEF ;PRINT WITHOUT EXP (CHK ROOM FOR ^8 SP)
\r
3984 PUSHJ P,CHKEF ;PRINT WITH EXP (CHK ROOM FOR ^14 SP)
\r
3985 PUSHJ P,PSIGN ;PRINT "SIGN"
\r
3986 JUMPN E,OUTN3 ;SHOULD DEV. POINT PRECEDE NUMER?
\r
3987 MOVEI C,"0" ;YES,SEND OUT LEADING ZERO.
\r
3990 OUTN3: PUSHJ P,DNPRNT ;GO PRINT NUMBER WITH DECIMAL
\r
3992 ;HERE TO PRINT EXPONENT
\r
3995 POP P,E ;RESTORE E
\r
4000 JUMPGE B,.+2 ;SPIT OUT SIGN
\r
4003 MOVM T,B ;USE PRTNUM TO PRINT EXPON
\r
4007 ;SUBROUTINE USED BY OUTNUM TO PRINT DECIMAL NUMBER. PRINTS
\r
4008 ;SIX DIGITS (INTEGER IN T) WITH CONTENTS(E) DIGITS
\r
4009 ;TO THE LEFT OF DECIMAL POINT
\r
4011 DNPRNT: MOVEI D,-1 ;SIGNAL TRAILING ZERO UNLESS...
\r
4012 JUMPE B,.+2 ;E-NOTATION
\r
4014 DNPRN0: IDIVI T,^D10 ;GET LAST DIGIT
\r
4015 JUMPE T,DNPRN1 ;IS IT FIRST?
\r
4016 JUMPN T1,.+2 ;NON ZERO DIGIT?
\r
4017 SKIPA T1,D ;NO, STASH ZERO OR TRAILZERO
\r
4018 MOVEI D,0 ;YES. TRAILER IS OVER.
\r
4019 HRLM T1,(P) ;NO. STASH DIGIT
\r
4020 PUSHJ P,DNPRN0 ;CALL DNPRNT RECURSIVELY
\r
4021 HLRE T1,(P) ;RESTORE DIGIT
\r
4022 JUMPGE T1,.+3 ;ORDINARY DIGIT?
\r
4023 JUMPLE E,CPOPJ ;NO, TRAILZERO. AFTER DECIMAL POINR?
\r
4024 MOVEI T1,0 ;NO, STASH A ZERO.
\r
4026 DNPRN1: MOVEI C,60(T1) ;PRINT DIGIT
\r
4028 SOJN E,CPOPJ ;COUNT DIGITS. PRINT NEXT?
\r
4029 DNPRN2: MOVEI C,"." ;YES. PRINT POINT
\r
4032 ;CHECK FOR ROOM ON A LINE FOR E-FORM NUMBER:
\r
4033 CHKEF: MOVEI X1,^D14 ;NEED 14 SP TO PRINT THIS NUMBER
\r
4034 PUSH P,B ;SAVE EXPONENT
\r
4038 CHKNEF: MOVEI X1,^D9
\r
4040 MOVEI B,0 ;NO EXPONENT.
\r
4041 JRST CPOPJ1 ;SKIP-RTN
\r
4043 ;POWER-OF-TEN TABLE.
\r
4045 D1EM18: OCT 105447113564 ;10^-18
\r
4048 D1EM4: OCT 163643334273
\r
4052 DECTAB: DEC 1.0 ;10^0
\r
4064 OCT 250721522451 ;10^12
\r
4066 D1E14: OCT 257553630410 ;10^14
\r
4070 DECFIX: EXP 225400000000
\r
4071 FIXCON: EXP 233400000000
\r
4073 ;FLAGS USED BY DECIMAL READER/PRINTER
\r
4075 F.NUM=200000 ;DIGIT SEEN
\r
4076 F.MIN=100000 ;MINUS SEEN
\r
4077 F.MXP=40000 ;MINUS EXPONENT
\r
4078 F.DOT=20000 ;DECIMAL POINT SEEN
\r
4079 \f SUBTTL RUN-TIME ROUTINES
\r
4081 ;RUN-TIME GOSUB ROUTINES
\r
4083 GOSBER: MOVE X1,@40
\r
4085 HRLM R,@40 ;SAVE PRECEDING CALL
\r
4086 MOVE R,40 ;FETCH CURRENT CALL
\r
4088 TRNN X1,777777 ;IF FCN, BEGINS AT CTRL WRD + 1
\r
4090 TLNN X1,777777 ;CHECK RECURSIVE CALL
\r
4093 PUSHJ P,INLMES ;RECURSIVE CALL
\r
4094 ASCIZ /SUBROUTINE OR FUNCTION CALLS ITSELF IN /
\r
4095 GOSR2: PUSH P,[EXP UXIT] ;PRINT LINE NUMBER AND END EXECUTION
\r
4103 FORCOM: HRRZI X1,313000 ;RUNTIME COMPARE FIX-DONT USE IF CONN
\r
4105 HRRZI X1,315000 ;SET UP COMPARE FOR ENTIRE LOOP
\r
4109 XCTON: JUMPLE N,XCTON1 ;IS ON ARGUMENT <=0?
\r
4111 HRRZ T,N ;GET INTEGER PART
\r
4113 ADDI T,(Q) ;GET THE "GOTO" ADDRESS
\r
4114 CAMGE T,(Q) ;IS IT IN RANGE?
\r
4115 JRST @(T) ;YES, GOGO
\r
4117 XCTON1: PUSHJ P,INLMES
\r
4118 ASCIZ /ON EVALUATED OUT OF RANGE IN /
\r
4121 \f;HERE ON OVFLOW ERROR
\r
4122 OVTRAP: PUSH P,X1 ;SAVE THIS REG IN CASE FALSE ALARM.
\r
4124 CALL X1,[SIXBIT /APRENB/]
\r
4125 HRRZ X1,JOBTPC ;GET TRAP ADDRESS.
\r
4126 CAML X1,FLCOD ;TRAP IN USER PROG?
\r
4128 JRST OVFLCM ;NO. FALSE TRAP.(NOT BY USER)
\r
4129 MOVE X1,JOBTPC ;GET TRAP FLAGS.
\r
4132 TLNE X1,(1B11) ;UNDERFLOW?
\r
4134 TLNE X1,(1B12) ;ZERO DIVIDE?
\r
4137 JRST OVFLCM ;NOT OVFLOW EITHER. IGNORE
\r
4138 OVTR0: PUSHJ P,INLMES
\r
4139 ASCIZ /OVERFLOW IN /
\r
4140 SKIPL N ;NEG OVFLOW?
\r
4141 OVTR2: HRLOI N,377777 ;LRG NUMBER
\r
4144 OVTR1: PUSHJ P,GOSR3
\r
4148 UNTRAP: PUSHJ P,INLMES
\r
4149 ASCIZ /UNDERFLOW IN /
\r
4150 SETZI N, ;RESULT IS ZERO.
\r
4152 DVTRAP: PUSHJ P,INLMES
\r
4153 ASCIZ /DIVISION BY ZERO IN /
\r
4156 RETURN: SETZI T,0 ;GOSUB RETURN, NOTHING ON PLIST
\r
4157 FRETRN: MOVE R,FCNLNK
\r
4158 JUMPE R,BADRET ;CHECK RETURN TOO FAR
\r
4159 MOVS X1,(R) ;FETCH LINK BACK
\r
4160 HRRZS (R) ;MARK SUBR NOT IN USE
\r
4163 POP P,X2 ;SAVE REAL RETURN LOCATION
\r
4164 SUB P,T ;POP ANY ARGUMENTS OFF THE PUSH LIST
\r
4167 BADRET: PUSHJ P,INLMES
\r
4168 ASCIZ /RETURN BEFORE GOSUB IN /
\r
4172 ;RUN-TIME RANDOMIZER
\r
4173 RANDER: CALL N,[SIXBIT /MSTIME/]
\r
4174 IMUL N,N ;USE THE 31 LOW ORDER BITS OF MILLISECS IN DAY ^2
\r
4176 JRST WRANB ;PRINT RANDOM FCN AND RETURN.
\r
4177 >;ASSEMBLE ABOVE IF INCLUDING RANDOM FACILITY
\r
4179 DOREAD: MOVE R,[XWD NXREAD,PREAD]
\r
4182 DOINPT: SETZM N,PINPUT
\r
4184 MOVE R,[XWD NXINPT,PINPUT]
\r
4188 ;ROUTINE TO GET A DATA WORD
\r
4190 DATAER: SKIPN T,(R) ;MORE ON SAME LINE?
\r
4192 PUSHJ P,NXCH ;PUT FIRST CHAR OF NEXT NUMBER IN C
\r
4193 DATAE0: PUSHJ P,EVANUM
\r
4198 MOVEM T,(R) ;STORE THE DATA WORD.
\r
4200 SKIPN T ;END OF A LINE?
\r
4201 SKIPN INPFLA ;YES, IS THIS INPUT
\r
4202 JRST (X1) ;NO, RETURN
\r
4203 MOVEM X1,INPFLA ;YES, RESTART NEXT ERROR FROM HERE.
\r
4206 DATR1: MOVS X1,R ;DISPATCH ADDRS FOR MORE DATA
\r
4209 ;ROUTINE TO GET A DATA STRING
\r
4212 SDATAE: MOVE T,1(R) ;GET CURRENT LINE POINTER
\r
4213 SKIPE INPFLA ;INPUT,INSTRUCTION?
\r
4214 MOVE T,(R) ;YES, SHARE POINTER WITH NUMBER DATA
\r
4215 SKIPN T ;MOVE ON CURRENT STRING DATA LINE?
\r
4216 JRST SDATR1 ;NO. HUNT FOR NEXT DATA LINE
\r
4217 PUSHJ P,NXCH ;GET FIRST CHAR
\r
4218 SDAT1: PUSHJ P,REDSTR ;READ THE STRING AND STORE IT
\r
4219 PUSHJ P,SSKIP ;BAD STRING
\r
4222 MOVEM T,1(R) ;SAVE STRING DATA POINTER.
\r
4223 SKIPE INPFLA ;INPUT?
\r
4224 MOVEM T,(R) ;YES , SHARE POINTER
\r
4227 SDATR1: MOVS X1,R ;DISPATCH ADDRESS FOR STRING DATA..
\r
4229 >;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY
\r
4231 \f;GET AN ARRAY DATA WORD
\r
4233 ADT1ER: PUSH P,40 ;DATAER NEEDS STORE LOC
\r
4237 JRST AST1ER ;GO STORE THE WORD
\r
4245 ;GO TO NEXT LINE OF DATA
\r
4247 NXREAD: TDZA Q,Q ;GET NEXT DATA LINE FOR NUMBER ITEM
\r
4248 MOVEI Q,1 ;GET NEXT DATA LINE FOR STRING ITEM
\r
4249 NSRSTR: MOVE T,DATLIN(Q) ;GET NXT DATA LINE NO
\r
4250 AOBJP T,NXRE2 ;JUMP IF OUT OF DATA
\r
4252 HRRZ T,(T) ;GET ADDRS OF SOURCE LINE
\r
4255 PUSHJ P,QSA ;LOOK FOR "DATA"
\r
4259 JUMPG Q,SDAT1 ;GO GET STRING?
\r
4261 JRST DATAE0 ;NO, GO GET NUMBER
\r
4262 \f;REQUEST NEXT LINE OF INPUT
\r
4264 NXVINP: SETOI Q, ;GET LINE AND RETURN TO "MATIN"
\r
4266 NXINPT: TDZA Q,Q ;GET A LINE OF INPUT; NUMBER ITEM NEXT
\r
4268 NXIN1: SKIPN IFIFG
\r
4271 ASCIZ /NOT ENOUGH INPUT--ADD MORE
\r
4273 NXIN2: PUSHJ P,INLMES
\r
4276 MOVE T,[POINT 7,LINB0]
\r
4278 PUSHJ P,INLINE ;READ THE LINE AND GET FIRST CHAR.
\r
4279 TLNE C,F.CR ;NULL LINE?
\r
4280 JUMPL Q,CPOPJ1 ;YES. ALLOW THIS ON MAT INPUT
\r
4281 PUSHJ P,DATCHK ;CHECK
\r
4283 JUMPE Q,DATAER ;GET NUMBER ITEM
\r
4285 JUMPG Q,SDATAE ;GET STRING ITEM
\r
4288 INPERP: POP P,X1 ;GET RID OF CALL TO NXVINP!
\r
4289 INPERR: PUSHJ P,INLMES
\r
4290 ASCIZ /INPUT DATA NOT IN CORRECT FORM--RETYPE LINE
\r
4293 INPER1: HRRZ X1,INPFLA
\r
4294 JRST (X1) ;START LINE OVER.
\r
4295 \f;RESTORE DATA POINTER
\r
4297 RESTOR: PUSHJ P,RESTOS ;RESTORE BOTH NUMBER AND STRINGS
\r
4298 RESTON: TDZA X1,X1 ;RESTORE NUMERIC DATA
\r
4299 RESTOS: MOVEI X1,1 ;RESTORE STRINGS
\r
4303 MOVEM T,DATLIN(X1)
\r
4304 SETZM PREAD(X1) ;CLEAR CURRENT LINE POINTER
\r
4307 NXRE2: PUSHJ P,INLMES ;OUT OF DATA
\r
4308 ASCIZ /OUT OF DATA IN /
\r
4316 \f;RUNTIME MAT INPUT ROUTINE
\r
4318 MATIN: PUSHJ P,DOINPT ;SET INPUT LOOP
\r
4319 HRRZ X1,40 ;GET VECTOR 2-WD BLOCK ADDRESS
\r
4320 HRRZ X2,(X1) ;GET ADDRESS OF FIRST ELEMENT
\r
4321 MOVEM X2,NUMRES ;SAVE THIS VALUE FOR COUNTING ELEMENT LATER
\r
4322 HLRZ X1,(X1) ;GET MAXIMUM VECTOR SIZE
\r
4323 ADD X1,X2 ;UPPER BOUND OF VECTOR
\r
4324 MOVEM X1,ELETOP ;SAVE FOR COMPARISION LATER
\r
4325 HRRM X2,40 ;SET UP ELEMENT ADDRESS FOR DATA ROUTINES
\r
4327 MATIN1: MOVEI X1,MATIN4 ;POINT "INPUT ERR" TO SPECIAL ROUTINE
\r
4328 HRL X1,40 ;REMEMBER FIRST ELEMENT ON LINE
\r
4330 PUSHJ P,NXVINP ;INPUT THE LINE
\r
4332 MATIN5: CAIA ;THERE IS ANOTHER ELEMENT.
\r
4333 JRST MATIN6 ;NULL LINE. NO MORE ELEMENTS.
\r
4334 HRRZ X1,40 ;MAY WE ACCEPT ANOTHER ELEMENT?
\r
4337 AOS 40 ;POINT TO NEXT ELEMENT
\r
4338 PUSH P,[EXP MATIN2] ;YES. SETUP RETURN FROMDATA ROUTINE
\r
4340 CAML X1,SVRBOT ;NUMBER OR STRING VECTOR?
\r
4341 JRST SDATAE ;STRING
\r
4343 JRST DATAER ;NUMBER
\r
4345 MATIN2: SETOM IFIFG
\r
4346 TLNE C,F.COMA ;END OF INPUT?
\r
4353 MATIN3: PUSHJ P,INLMES
\r
4354 ASCIZ /TOO MANY ELEMENTS -- RETYPE LINE
\r
4358 MATIN4: HLRZ X1,INPFLA
\r
4362 MATIN6: HRRZ X1,40
\r
4370 REDSTR: TLNN C,F.LETT+F.QUOT
\r
4372 AOS (P) ;THIS IS A LEGITIMATE STRING
\r
4377 MOVEI Q,F.COMA+F.TERM ;ASSUME A STRING WITHOUT QUOTES
\r
4378 TLNN C,F.QUOT ;IS IT A QUOT STRING?
\r
4381 PUSHJ P,NXCHS ;SKIP QUOTE
\r
4382 REDS1: SETZI X2, ;INITIALIZE COUNT.
\r
4383 SKIPE (F) ;NEW STRING?
\r
4384 SETZM VPAKFL ;NO, GARBAGE NEW EXISTS
\r
4389 IDPB C,F ;STORE A CHAR
\r
4392 REDS3: TLNE C,F.QUOT
\r
4394 HRRZ X1,F ;GET NEW FREE LOCATION
\r
4399 SSKIP: SKIPE INPFLA ;IS THIS INPUT OR READ?
\r
4400 JRST SSKP1 ;INPUT. CANT SKIP ANY FIELDS
\r
4401 PUSHJ P,SKIPDA ;SKIP OVER A DATA FIELD
\r
4402 HALT . ;IMPOSSIBLE ERROR
\r
4404 TLNE C,F.TERM ;END OF DATA LINE?
\r
4405 JRST -4(X1) ;YES. FORCE DATA SEARCH
\r
4406 JRST -3(X1) ;RETURN TO DATAERR OR SDATAE
\r
4408 SSKP1: ADD P,[XWD -2,-2] ;CLEAN UP PUSH LIST
\r
4411 ;ROUTINE THAT SKIPS OVER ONE DATA FIELD
\r
4412 SKIPDA: TLNE C,F.QUOT ;QUOTE STRING?
\r
4413 JRST QSKIP ;YES, USE QSKIP ROUTINE
\r
4414 TLNE C,F.COMA+F.TERM ;FIELD TERMINATOR?
\r
4418 >;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY
\r
4421 SKIPDA: POPJ P, ;STRINGS NOT ALLOWED. DATA ERROR
\r
4422 SSKIP: ADD P,[XWD -2,-2] ;CLEAN UP PUSHLIST
\r
4426 PRDLER: PUSHJ P,FIRCHK
\r
4432 FINPNT: MOVE X1,FMTPNT ;FINISH WITH CR?
\r
4435 PCRLF: PUSHJ P,INLMES ;ROUTINE TO END A LINE.
\r
4443 ;RUN-TIME NUMBER PRINTER
\r
4445 PRNMER: PUSHJ P,TABBR
\r
4446 MOVE N,@40 ;GET THE NUMBER
\r
4448 AOS TABVAL ;CAUSE A SPACE TO FOLLOW NUMBER.
\r
4451 PRNTBR: PUSHJ P,TABBR
\r
4461 FIRCHK: PUSHJ P,TABBR
\r
4465 ;"TABBR" ANALYSES THE LAST FORMAT CHARACTER USING "TABB0", "TABB1", AND
\r
4466 ;"TABB3", WHICH HANDLE THE <PA>, COMMA, AND SEMICOLON, RESPECTIVELY.
\r
4467 ;"TABVAL" CONAINS THE NUMBER OF SPACES WAITING TO BE TYPED OUT
\r
4468 ;(OR IS NEGATIVE IF A <RETURN> MUST FOLLOW.)
\r
4471 CHROOM: MOVE B,TABVAL
\r
4472 ADD X1,B ;TOTAL SPACE NEEDED FOR FIELD
\r
4475 JRST PCRLF ;NO ROOM, GO TO NEXT LINE
\r
4477 JUMPE B,CPOPJ ;NO SPACING TO DO.
\r
4478 MOVEI C," " ;HERE TO PUT OUT SPACES
\r
4484 TABBR: LDB X1,[POINT 4,40,12]
\r
4485 EXCH X1,FMTPNT ;GET OLD POSITION AND SAVE NEW FORMAT
\r
4486 TABB1: MOVE A,TABVAL
\r
4490 POPJ P, ;NO FMT CHAR
\r
4491 POPJ P, ;<CR> WAS TYPED WHEN FIRST SEEN.
\r
4492 JRST TABB3 ;SEMICOLON
\r
4499 TABB2: ADDB B,TABVAL
\r
4502 TABB3: CAILE A,112
\r
4508 SETCR: SETOM TABVAL ;FORCE <RETURN TO BE NEXT>
\r
4510 TABOUT: MOVEI X1,3
\r
4514 SUBTTL RUN-TIME STRING MANIPULATION ROUTINES.
\r
4517 ;GETSTR IS CALLED WITH THE ADDRESS OF A POINTER IN REG.
\r
4518 ;THE ROUTINE SETS UP THE POINTER IN F, AND THE NEGATIVE COUNT OR
\r
4519 ;(FOR LITERAL STRINGS) A POSITIVE QUANTITY IN G. (G=0 IF NULL STRING)
\r
4521 GETSTR: PUSHJ P,PNTADR ;GET ADDRESS OF STRING POINTER
\r
4523 HLRE G,F ;PUT NEGATIVE CHAR LENGTH IN G, IF NOT APP BLK OR 0.
\r
4525 HRLI F,440700 ;NOTAPP BLK, INITIALIZE POINTER.
\r
4528 ;ROUTINE TO SET UP A NUMBER VECTOR INSTEAD OF A STRING
\r
4529 GETVEC: HRRZ F,@40 ;THE LEFT SIDE OF (F) IS ZERO, IMPLYING VECTOR ADR,
\r
4530 MOVE G,(F) ;GET VECTOR LENGTH
\r
4531 JUMPL G,GETVF ;NEGATIVE?
\r
4532 FAD G,FIXCON ;FIX THE LENGTH
\r
4534 HLRZ X1,@40 ;DOES THE LENGTH EXCEED VECTOR BOUNDS?
\r
4538 AOJA F,CPOPJ ;NO. POINT TO FIRST "CHAR" AND RETURN
\r
4540 GETVF: PUSHJ P,INLMES
\r
4541 ASCIZ /IMPOSSIBLE VECTOR LENGTH IN /
\r
4550 CAIN C,42 ;CHECK IF "
\r
4554 ;ROUTINE TO GET NEXT VECTOR ELE AS A CHARACTER
\r
4555 GETEL: AOJG G,CPOPJ ;IS THERE ANOTHER ELEMENT?
\r
4556 MOVE C,(F) ;YES. GET IT
\r
4557 JUMPL C,GETELF ;TOO SMALL TO BE AN ASCII
\r
4558 LDB Q,[POINT 8,C,8] ;GET EXPONENT
\r
4559 TLZ C,777000 ;TURN IT OFF
\r
4560 LSH C,-233(Q) ;SHIFT INTO INTEGER POSISITON
\r
4562 AOJA F,CPOPJ1 ;BUMP ELEMENT POINTER AND RETURN
\r
4564 GETELF: PUSHJ P,INLMES
\r
4565 ASCIZ /NON-ASCII CHAR SEEN IN /
\r
4568 ;ROUTINE TO STORE "NUMERIC" CHARS INTO A STR.
\r
4569 STRCHA: PUSHJ P,PNTADR
\r
4577 STRCH1: PUSH P,[XWD STRCH2]
\r
4581 STRCH2: JRST REDS8
\r
4591 PUTVEC: HRRZ X1,@40
\r
4594 PUTV1: PUSHJ P,GETCH
\r
4597 TLO C,233400 ;YES. FLOAT IT
\r
4600 AOBJP X1,PUTV1 ;COUNT CHARS IN LEFT HALF OF X1
\r
4602 PUTV2: HLRZ X1,X1 ;GET SIZE
\r
4603 HRLI X1,233400 ;FLOAT IT
\r
4605 MOVEM X1,@N ;FIRST ELEMENT GETS SIZE
\r
4608 PUTVF: PUSHJ P,INLMES
\r
4609 ASCIZ /NO ROOM FOR STRING IN /
\r
4612 ; COMPARE TWO STRINGS.
\r
4618 IFST1: PUSHJ P,GETPCH ;GET PAIR OF CHARS IN (A) AND (C)
\r
4619 JUMPG Q,IFST3 ;HAVE BOTH STRINGS ENDED?
\r
4620 JUMPE Q,IFST2 ;HAS ONE STRING ENDED?
\r
4621 CAMN C,A ;ARE THESE TWO CHARS THE SAME?
\r
4622 JRST IFST1 ;YES. LOOK AT NEXT PAIR
\r
4624 IFST2: SETOI Q, ;CHECK BOTH STRINGS FOR TRAILING BLANKS
\r
4625 CAIN C," " ;IS THIS CHAR A BLANK?
\r
4626 PUSHJ P,IFST4 ;YES, GO CHECK STRING
\r
4627 PUSHJ P,EXCH6 ;LOOK AT OTHER STRING
\r
4630 IFST3: HLLZ X1,@(P) ;GET RELATION
\r
4632 IOR X1,[Z A,C] ;SETUP COMPARE
\r
4634 POPJ P, ;RETURN AND "GOTO"
\r
4635 JRST CPOPJ1 ;RETURN AND STAY IN LINE
\r
4637 IFST4: PUSHJ P,GETCH
\r
4639 CAIN C," " ;IS NEXT CHAR A BLANK?
\r
4640 JRST N,IFST4 ;YES KEEP LOOKING
\r
4641 MOVEI C," " ;NO. USE BLANK FOR COMPARE
\r
4644 ;ROUTINE TO GET A PAIR OF CHARS
\r
4645 GETPCH: SETOI Q, ;COUNT TERMINATED STRINGS IN X2
\r
4656 \f;PRSTRR PRINTS A STRING WHOSE POINTER IS ADDRESSED IN (40)
\r
4663 PRST1: PUSHJ P,GETCH
\r
4674 >;ASSEMBLE ABOVE FOR STRINGS
\r
4677 ;ROUTINE TO PUT ADDRESS OF POINTER IN REG
\r
4678 PNTADR: HRRZ N,40 ;GET UUO ADDRESS
\r
4680 JUMPGE X1,CPOPJ ;ALL DONE IF THIS IS 0 OR AN APP BLK.
\r
4681 TLNN X1,377777 ;ALL DONE IF THIS IS NEGATIVE COUNT
\r
4684 >;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY
\r
4686 SAD1ER: MOVE D,[JRST SADEND] ;FETCH ADR OF ARRAY ELEMENT
\r
4689 ASN1ER: MOVE D,[MOVNM N,(A)] ;NEGATIVE ARRAY STORE
\r
4691 AST1ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE
\r
4692 AFT1ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH
\r
4693 MOVEI A,0 ;PSEUDO LEFT HALF
\r
4694 MOVE B,40 ;ARRAY ADDRESS
\r
4695 HRRZ C,1(B) ;TRY RIGHT DIMENSION
\r
4696 TRNN C,777776 ;ROW VECTOR?
\r
4697 HLRZ C,1(B) ;NO, MUST BE COLUMN VECTOR
\r
4698 JRST AFT2C ;FINISH UP WITH 2-DIM CODE
\r
4700 ASN2ER: MOVE D,[MOVNM N,(A)] ;NEGATIVE ARRAY STORE
\r
4702 AST2ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE
\r
4703 AFT2ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH
\r
4704 MOVE B,40 ;ARRAY ADDRESS
\r
4705 HLRZ C,1(B) ;LEFT DIMENSION
\r
4706 PUSHJ P,SUBSCR ;GET AND FIX SUBSCRIPT IN E
\r
4708 IMUL A,E ;LEFT SCRIPT TIMES RIGHT DIM!
\r
4709 HRRZ C,1(B) ;RIGHT DIMENSION
\r
4710 AFT2C: PUSHJ P,SUBSCR ;GET AND FIX SUBSCRIPT IN E
\r
4711 ADD A,E ;ADD TO LEFT DIM
\r
4712 ADD A,(B) ;ADD ARRAY ADDRS
\r
4713 XCT D ;DO THE OPERATION
\r
4717 SADEND: HRRZI N,(A) ;PUT STRING VECTOR POINTER ADDRESS IN N
\r
4718 TLO N,(1B0) ;MAKE IT LOOK LIKE AN ADDRESS, NOT A POINTER
\r
4721 \f;ROUTINE TO FETCH AND CHECK SUBSCRIPT
\r
4723 ;CALL: MOVE C,DIMENSION
\r
4727 SUBSCR: MOVE E,@-1(P) ;GET SUBSCRIPT
\r
4728 AOS N,-1(P) ;SKIP ARGUMENT
\r
4730 FAD E,[XWD 233400,0];FIX SUBSCRIPT
\r
4732 CAMGE E,C ;CHECK DIMENSION
\r
4734 ;ON ERROR, FALL INTO DIMERR
\r
4737 ;DIMENSION ERR ROUTINE
\r
4741 DIMERR: PUSHJ P,INLMES
\r
4742 ASCIZ /DIMENSION ERROR IN /
\r
4744 \f SUBTTL MATRIX OPERATION RUN-TIME ROUTINES
\r
4747 ;SET MATRIX DIMENSION -- SDIM UUO
\r
4750 SDIMER: MOVSI C,1 ;DONT FAIL IN SUBSCR
\r
4751 PUSHJ P,SUBSCR ;FIRST DIM
\r
4753 PUSHJ P,SUBSCR ;SECOND DIM
\r
4755 AOBJP A,MS0CHK ;GO CHECK DIMS AND STORE THEM
\r
4758 ;MATRIX OPERATION SETUP ROUTINE
\r
4759 ;USE ENTRY POINT MS2 IF 2 ARGS, MS1 IF 1 ARG, MS0 OR MS0CHK IF 0 ARGS.
\r
4760 ;ALL ENTRIES EXPECT MS0 EXCEPT DIMENSION [XWD ROWS,COLS]
\r
4761 ; OF DESTINATION TO BE SET UP IN A AND CHECK FOR ROOM
\r
4762 ; AND SET DIMENSION OF DESTINATION.
\r
4763 ;AT CALL, LOCATION 40 CONTAINS THE ADDRS OF DESTINATION DOPE VECTOR,
\r
4764 ; RIGHT SIDE OF T1 CONTAINS ADDRS OF DOPE VECTOR FOR ARG 1
\r
4765 ; RIGHT SIDE OF T CONTAINS ADDRS OF DOPE VECTOR FOR ARG 2
\r
4766 ;RIGHT SIDES OF T1,T,B ARE REPLACED WITH ADDRESSES OF ELEMENTS 0,0
\r
4767 ; OF ARG 1, ARG 2, DEST, RESPECTIVELY, WITHOUT CHANGING LEFT SIDES,
\r
4768 ; AND THE RESULTS ARE STORED IN TEMP1, TEMP2, AND TEMP3, RESPECTIVELY.
\r
4769 ;THE MAXIMUM ROW NUMBER OF DEST IS STORED IN SB1M1, THE MAXIMUM
\r
4770 ; COLUMN NUMBER OF DEST IS STORED IN SB2M1
\r
4771 ;E, T1, AND G ARE SET TO FIRST ROW NUMBER, FIRST COL NUMBER,
\r
4772 ; AND RELATIVE LOCATION OF FIRST ELEMENT, RESPECTIVELY
\r
4773 ;IT IS INTENDED THAT E, T1, G, TEMP1, TEMP2, TEMP3 BE SET UP FOR
\r
4774 ; IMMEDIATE CALL TO MLP, AND THAT ELEMENTS OF FIRST
\r
4775 ; ARGUMENT, SECOND ARGUMENT, AND DESTINATION BE ACCESSED
\r
4776 ; BY INDIRECT ADDRESSING THROUGH TEMP1, TEMP2, AND TEMP3, RESPECTIVELY.
\r
4779 MS2: HRR T,(T) ;ADDRS OF FIRST ARG
\r
4780 MS1: HRR T1,(T1) ;ADDRS OF SECOND OR ONLY ARG
\r
4781 MS0CHK: HRR B,40 ;DOPE VECTOR OF DEST
\r
4782 HLLZ X1,A ;CHECK NEW DIMENSION
\r
4783 IMULI X1,(A) ;X1 := (TOTAL SIZE)0
\r
4784 CAMLE X1,0(B) ;IS THERE ROOM IN ARRAY?
\r
4785 JRST DIMERR ;NO. DIMENSION ERROR
\r
4786 MOVEM A,1(B) ;STORE NEW DIMENSION
\r
4788 MS0: HRR B,40 ;ENTER HERE FOR NO DIM CHECK
\r
4789 MOVE A,1(B) ;FETCH DIMENSIONS
\r
4790 SUB A,[XWD 1,1] ;E := (MAX ROW)MAX COL
\r
4791 HLRZM A,SB1M1 ;FIRST DIMENSION -1
\r
4792 HRRZM A,SB2M1 ;SECOND DIMENSION -1
\r
4794 HRR B,(B) ;ADDRS OF DEST (LEAVE IN B FOR MINV)
\r
4795 MOVEM T1,TEMP1 ;STORE FIRST XCT INSTRUCTION
\r
4796 MOVEM T,TEMP2 ;STORE SECOND XCT INSTRUCTION
\r
4797 MOVEM B,TEMP3 ;STORE THIRD XCT INSTRUCTION
\r
4799 ;NOW SETUP E, T1, AND G FOR "MLP"
\r
4801 SKIPE E,SB1M1 ;MORE THEN 0'TH ROW?
\r
4802 MOVEI E,1 ;YES. USE FIRST
\r
4803 SKIPE T1,SB2M1 ;MORE THAN 0'TH COL
\r
4804 MOVEI T1,1 ;YES. USE FIRST
\r
4805 MOVE G,SB2M1 ;CALCUATE FIRST ELT OF RESLT
\r
4812 ;MATRIX OPERATION MAIN LOOP
\r
4814 ;ON CALLING, T, T1, G ARE SET UP TO ROW NUMBER, COL NUMBER, AND
\r
4815 ; REL LOC OF CURRENT ELEMENT IN DESTINATION MATRIX.
\r
4816 ;MLP EXECUTES THE CONTENT OF TEMP1, TEMP2, TEMP3 FOR EACH
\r
4817 ; ELEMENT OF CURRENT ROE. AT END OF ROW, MLP RETURNS
\r
4818 ; WITHOUT SKIP TO ALLOW ONCE-PER-ROW OPERATIONS TO BE PERFORMED.
\r
4819 ; WHEN ALL ROWS HAVE BEEN PROCESSED, MLP RETURNS WITH SKIP.
\r
4820 ;NOTE SPECIAL CODING SO THAT ROW AND COLUMN VECTORS ARE
\r
4821 ; HANDLED CORRECTLY.
\r
4830 SKIPE SB2M1 ;MORE THAN A 0'TH COL?
\r
4831 AOJA G,.+2 ;YES. SKIP 0'TH COL
\r
4832 TDZA T1,T1 ;NO. SET TO USE 0'TH COL
\r
4833 MOVEI T1,1 ;YES AGAIN. SET TO USE COL 1.
\r
4835 CAML E,SB1M1 ;ALL ROWS USED?
\r
4836 AOS (P) ;YES. SET FOR SKIP RETURN
\r
4837 AOJA E,CPOPJ ;BUMP ROW AND RETURN
\r
4840 ;MATRIX READ ROUTINE
\r
4842 ;SET UP AND CALL MLP. FOR EACH ELEMENT, THE FOLLOWING
\r
4844 ; TEMP1: PUSHJ P,MTRELT
\r
4845 ; TEMP2: ... ;(SKIPPED)
\r
4846 ; TEMP3: MOVEM N,<DEST>(G)
\r
4847 ;MTRELT READS A NUMBER INTO N
\r
4849 MTRDER: MOVE T1,[PUSHJ P,MTRELT]
\r
4851 HRRZ X1,@40 ;GET ADDRESS OF ZEROTH ELEMENT.
\r
4852 CAML X1,SVRBOT ;IS THIS A STRING VECTOR?
\r
4853 JRST MTRDS ;ELEMENTS WILL BE STRINGS.
\r
4854 HRLI B,G(MOVEM N,)
\r
4855 MTRD1: PUSHJ P,MS0 ;SET UP FOR LOOP
\r
4856 SETZM 40 ;NOP THE STORE THAT DATAER USES
\r
4857 MTRD2: PUSHJ P,MLP ;EXECUTE LOOP
\r
4858 JRST .-1 ;NO ACTION ON ROW
\r
4861 ;ROUTINE CALLED BY MTRDER TO PRINT AN ELEMENT
\r
4863 MTRELT: PUSHJ P,DATAER
\r
4866 MTRDS: MOVSI T1,(SKIPA)
\r
4870 ;MATRIX PRINT ROUTINE
\r
4872 ;SET UP AND CALL MLP:
\r
4874 ; TEMP2: PRNM <FORMAT CODE>,<DEST>(G)
\r
4876 MTPRER: MOVE T1,[PUSH P,T1] ;TO SAVE T1 AROUND PRNM
\r
4877 PUSHJ P,MS0 ;SET UP FOR LOOP
\r
4878 HLL B,40 ;PICK UP UUO AC FIELD
\r
4879 TLZ B,777000 ;CONSTRUCT PRNM INSTR
\r
4880 SKIPE SB1M1 ;COLUMN VECTOR?
\r
4882 JRST .+3 ;YES. ALLOW <CR> FORMAT
\r
4883 TLNN B,(Z 16,) ;OH, NO. TREAT <RET> FORMAT ==<COMA> FORMAT.
\r
4886 CAMGE X1,SVRBOT ;NUMBER ARRAY?
\r
4887 TLO B,G(PRNM) ;YES, SETUP NUMBER UUO
\r
4888 CAML X1,SVRBOT ;STRING ARRAY?
\r
4889 TLO B,G(PRSTR) ;YSE SEUP STRING PRINT UUO.$
\r
4890 MOVEM B,TEMP2 ;SET UP TEMP2 AND TEMP3
\r
4891 MOVE X1,[POP P,T1]
\r
4893 MTP1D: PUSHJ P,MTP3D ;TOW BLANK LINES
\r
4894 MTP2D: PUSHJ P,MLP
\r
4896 MTP3D: PUSHJ P,PCRLF
\r
4899 MTP4D: SKIPE SB1M1 ;VECTOR OR ARRAY?
\r
4901 JRST MTP2D ;ARRAY... SPACE BETW ROWS
\r
4902 JRST MTP1D ;VECTOR...DONT SPACE BETW ROWS
\r
4905 ;MATRIX ADD AND SUBTRACT ROUTINES
\r
4907 ;SET UP AND CALL MLP:
\r
4908 ; TEMP1: MOVE N,<ARG 2>(G) ;OR MOVN
\r
4909 ; TEMP2: FADR N,<ARG 1>(G)
\r
4910 ; TEMP3: MOVEM N,<DEST>(G)
\r
4911 MTADER: TLOA T1,G(MOVE N,) ;MAKE ADD INSTR (T LOADED WITH MOVEI)
\r
4912 MTSBER: HRLI T1,G(MOVN N,) ;MAKE SUBTRACT INSTR
\r
4913 HRLI T,G(FADR N,) ;FETCH
\r
4914 HRLI B,G(MOVEM N,)
\r
4915 MOVE A,1(T) ;GET AND CHECK DIMENSIONS OF ARGS
\r
4918 PUSHJ P,MS2 ;SET UP MATRIX LOOP
\r
4919 JRST MTRD2 ;FINISH -- NO EACH ROW RTN
\r
4921 ;MATRIX SCALE ROUTINE
\r
4923 ;SET UP AND CALL MLP:
\r
4924 ; TEMP1: MOVE A,<ARG 1>(G)
\r
4926 ; TEMP3: MOVEM A,<DEST>(G)
\r
4928 MTSCER: HRLI T1,G(MOVE A,)
\r
4929 MOVSI T,(FMPR A,N)
\r
4930 MTSC1: HRLI B,G(MOVEM A,)
\r
4936 ;MATRIX ZERO, IDENTITY, AND ONE ROUTINES
\r
4938 ;SET UP AND CALL MLP:
\r
4939 ; ..IDEN.. ..ZERO.. ..ONE..
\r
4940 ; TEMP1: SETZM@TEMP3 SETZM @TEMP3 CAIA
\r
4941 ; TEMP2: CAMN T,T1 CAIA ...
\r
4942 ; TEMP3: MOVEM A,<DEST>(G)......................
\r
4945 MTIDER: SKIPA T,[CAMN E,T1]
\r
4946 MTZRER: MOVSI T,(CAIA)
\r
4947 SKIPA T1,[SETZM @TEMP3]
\r
4948 MTCNER: MOVSI T1,(CAIA)
\r
4949 HRLI B,G(MOVEM D,)
\r
4950 MOVSI D,(DEC 1.0) ;CONSTANT 1.0 TO STORE
\r
4951 JRST N,MTRD1 ;GO FINISH WITH READ CODE
\r
4954 ;MATRIX TRANSPOSE ROUTINE
\r
4956 ;SET UP AND CALL MLP:
\r
4957 ;A CONTAINS RELATIVE LOC OF CURRENT ELE IN SOURCE
\r
4958 ; TEMP1 : FETCH SOURCE ELEMENT
\r
4959 ; TEMP2 : UPDATE SOURCE INDEX
\r
4960 ; TEMP3 : STORE DESTINATION ELEMENT
\r
4964 MTTNER: MOVS A,1(T1) ;FETCH DESTINATION DIMENSION
\r
4966 HLRZ T,A ;E := ADDI A,<NBR ROWS>
\r
4968 HRLI B,G(MOVEM N,)
\r
4969 PUSHJ P,MS1 ;SET UP CHK DIMENSION
\r
4971 MTTN1: MOVE A,SB1M1 ;A := <NBR ROWS>*COL + ROW
\r
4976 PUSHJ P,MLP ;MOVE A ROW
\r
4982 ;MATRIX MULTIPLY ROUTINE
\r
4984 ;SET UP AND CALL MLP
\r
4985 ;FOR EACH ELEMENT OF DESTINATION MATRIX, CALL SUBROUTINE
\r
4986 ; MYELT TO FORM THE DOT PRODUCT OF THE APPROPRIATE ROW AND COLUMN
\r
4989 MTMYER: MOVE A,1(T) ;CHECK DIMENSIONS
\r
4990 HLRZ D,1(T1) ;D := INNER DIMENSION
\r
4991 CAIE D,(A) ;SAVE AS FIRST ARG?
\r
4995 HRLI T1,T1(MOVEI X2,) ;TO COMPUTE ADDRESS OF 1ST ELT 2ND ARG
\r
4996 HRLI T,(MOVEI X1,) ;DITTO 1ST ARG
\r
4997 HRLI B,G(MOVEM N,) ;STORE INSTR
\r
4998 PUSHJ P,MS2 ;SETUP NEW DIMENSIONS AND MLP ARGS
\r
4999 MOVEI X1,1(A) ;PREPARE TO SKIP ROW ZERO IF..
\r
5000 CAIE D,1 ;INNER DIM=1?
\r
5002 MOVE B,[PUSHJ P,MYELT] ;CALL TO ELT COMPUTATION
\r
5005 CAIE D,1 ;INNER DIM 1? (IE PROD OF VECTORS)
\r
5006 ADDI B,1 ;NO. SKIP 0'TH COL OF 1'ST ARG
\r
5007 JUMPE E,MTMY2 ;DONT SKIP FIRST ROW IF ONLY 1
\r
5009 MTMY1: ADDM D,B ;NEXT ROW OF FIRST ARG
\r
5010 MTMY2: PUSHJ P,MLP
\r
5014 ;SUBROUTINE TO COMPUTE ELEMENT OF PRODUCT
\r
5015 ;X1 CONTAINS ADDRS OF 1ST ELT OF 1ST ARG FOR DOT PRODUCT,
\r
5016 ; AFTER FIRST XCT BELOW, X2 CONTAINS ADDRS OF SAME FOR 2ND ARG
\r
5019 MOVEI N,0 ;TO ACCUMULATE DO PRODUCT
\r
5020 MOVEI C,-1(D) ;NUMER OF ADDS= REAL INNER DIMENSION
\r
5022 MYEL1: MOVE Q,(X1) ;PRODUCT OF 2 ELTS
\r
5024 FADR N,Q ;ADD INTO DOT PRODUCT
\r
5025 ADDI X2,1(A) ;NEXT ROW OF 2ND ARG
\r
5026 SOJLE C,CPOPJ ;DONE?
\r
5027 AOJA X1,MYEL1 ;NO. TO NEXT ELT
\r
5029 \f SUBTTL RUN-TIME MATRIX INVERTER
\r
5032 ;SUBROUTINE TO CALL MATRIX INVERTER
\r
5034 MTIVER: MOVS A,1(T1) ;MAKE SURE SQUARE MATRIX
\r
5038 HRLI T1,G(SKIPA A,) ;MOVE DESTINATION
\r
5039 PUSHJ P,MTSC1 ;(USE MTCNER CODE)
\r
5040 SKIPE SB1M1 ;GO INVERT UNLESS ONLY ELT IS (0,0)
\r
5044 MOVEM B,TEMP3 ;ONLY ELEMENT IS (0,0)
\r
5045 AOS SB1M1 ;FOOL MINV INTO THINGING ITS (1,1)
\r
5048 ;THIS PORTION OF THE MAT INVERSE PROG RUNS IN ACS 0-7
\r
5053 ZERO: CAMN JX,NT ;SKIP SAME COL
\r
5055 MOVE TAC,@TEMP1 ;A(I,J)=A(I,J)+A(NT,J)*A(I,NT)
\r
5056 FMPR TAC,(KX) ;***
\r
5057 MOD: FADRM TAC,0(JX) ;ADDR MODIFIED BY OUTER LOOP
\r
5058 JXIT: CAMGE JX,SB1M1 ;LOOP DONE?
\r
5060 JRST IXIT ;YES RETURN
\r
5064 ;SOME AC DEFS FOR MINV
\r
5066 NT=10 ;OUTERMOST LOOP INDEX
\r
5067 IX=11 ;I SUBSCRIPT
\r
5068 JX=12 ;J SUBSCRIPT
\r
5069 KX=13 ;SCRATCH INDEX REG
\r
5072 TAC1=16 ; " (MUST BE SAVE & RESTORED)
\r
5075 ;MAIN ROUTINE ENTERS HERE TO SET UP REGS
\r
5076 ;ROUTINE EXPECTS 1) ARRAY ADDR IN TEMP3
\r
5077 ; 2) ORDER OF ARRAY IN SB1M1
\r
5078 ;ROUTINE USES 1) VECT1 & VECT2 AS SCRATCH
\r
5079 ; 2) SB2M1 AS CNT OF ELEMENTS / ROW
\r
5081 MINVB: HRRZS TEMP3 ;MAKE SURE ADDR ONLY
\r
5082 MOVE TAC,SB1M1 ;GET ORDER
\r
5083 ADDI TAC,1 ;ADD ONE FOR 0'TH ROW & COL
\r
5084 MOVEM TAC,SB2M1 ;SAVE IN SB2
\r
5086 MOVSI TAC,(1.0) ;INIT DETERM.
\r
5088 HRLZI TAC,JX ;SET INDEX REG IN
\r
5089 HLLZM TAC,TEMP1 ;TEMP1 FOR INDIRECT
\r
5090 MOVE TAC,[XWD JLOOP,ZERO]
\r
5091 BLT TAC,7 ;PUT JLOOP INTO ACS
\r
5093 MOVEI NT,1 ;INITIALIZE OUTER LOOP
\r
5094 MINVLP: MOVE TAC,NT
\r
5095 IMUL TAC,SB2M1 ;CALC (NT,NT) SUBSCR
\r
5097 ADD TAC,TEMP3 ;***
\r
5098 MOVEM TAC,TEMP2 ;SAVE IT FOR LATER
\r
5099 CAMN NT,SB1M1 ;LAST ITER?
\r
5100 JRST FOUND1 ;SAVE SEARCH STUFF
\r
5101 MOVM TAC,(TAC) ;GET A(NT,NT)
\r
5102 MOVE IX,NT ;INITIALIZE SEARCH
\r
5104 LUPI: MOVE KX,SB2M1 ;CALC I INDEX
\r
5107 MOVE JX,NT ;INIT J INDEX
\r
5109 ADD LX,JX ;FINISH INDEX FOR ELEMENT
\r
5110 MOVM LX,(LX) ;GET IT
\r
5111 CAMGE LX,TAC ;IS IT LARGER THAN PRESENT
\r
5113 MOVE TAC,LX ;YES SAVE IT
\r
5114 MOVEM IX,VECT1(NT) ;AND INDEXES
\r
5115 MOVEM JX,VECT2(NT)
\r
5116 LUPEND: CAMGE JX,SB1M1 ;END OF J LOOP LOGIC
\r
5123 FOUND1: MOVE TAC,@TEMP2 ;GET PIVOT ELEMENT
\r
5124 JUMPE TAC,SING ;TEST FOR SINGULARITY.
\r
5125 MOVEM TAC,PIVOT ;SAVE IT
\r
5126 FMPRM TAC,DETER ;PERPETUATE DETERM
\r
5127 MOVSI TAC,(1.0) ;1./A(NT,NT)
\r
5128 FDVRM TAC,PIVOT ;***
\r
5130 MOVEI IX,1 ;SET UP I
\r
5131 ILOOP: CAMN IX,NT ;SKIP SAME ROW
\r
5132 JRST IXIT ;AS PIVOT ROW
\r
5133 MOVE LX,SB2M1 ;CALCUATE ALL ROW OFFSETS
\r
5135 ADD LX,TEMP3 ;LX= IX*N+A
\r
5137 ADD KX,NT ;KX=LX+NT
\r
5138 MOVN TAC,PIVOT ;GET -PIVOT
\r
5139 FMPRM TAC,(KX) ;A(I,NT)=A(I,NT)/(-A(NT,NT))
\r
5140 MOVEI JX,1 ;SET J LOOP START
\r
5143 ADD TAC,TEMP3 ;TAC=NT*N+A
\r
5144 HRRM TAC,TEMP1 ;STORE FOR @TMEP1(JX)
\r
5145 HRR MOD,LX ;SAT ADDR IN INNER LOOP
\r
5148 IXIT: CAMGE IX,SB1M1 ;RETURN HERE FROM ACS
\r
5150 MOVEI JX,1 ;SET LOOP FOR LAST COL
\r
5151 MOVE TAC,PIVOT ;GET PIVOT
\r
5152 LCOL: FMPRM TAC,@TEMP1 ;A(NT,J)=A(NT,J)/A(NT,NT)
\r
5153 CAMGE JX,SB1M1 ;DONE
\r
5155 MOVEM TAC,@TEMP2 ;A(NT,NT)=PIVOT
\r
5156 CAMGE NT,SB1M1 ;INVERSE DONE?
\r
5160 ;HERE WHEN INVERSE DONE PUT MATRIX BACK TOGETHER
\r
5162 MOVE NT,SB1M1 ;DO LOOP IN REVERSE ORDER
\r
5163 INVFIX: SOJLE NT,OUT ;FINISHED
\r
5164 PUSHJ P,BSWAP ;SWAP ROW - COL IN REV.
\r
5166 BSWAP: MOVE KX,VECT2(NT)
\r
5167 MOVE LX,VECT1(NT) ;SET REGS
\r
5169 FSWAP: MOVE KX,VECT1(NT)
\r
5171 SWAP: MOVE TAC1,NT
\r
5172 IMUL TAC1,SB2M1 ;CALC BOTH ROW OFFSETS
\r
5179 SWP1: MOVE TAC,@TAC1 ;EXCHANGE ITEMS IN ROWS
\r
5187 ADD KX,TEMP3 ;GET COL ADDR
\r
5190 SWP2: MOVE TAC,@LX
\r
5193 CAML IX,SB1M1 ;CHECK DONE
\r
5195 ADD KX,SB2M1 ;TO NEXT COL
\r
5198 ;HERE TO RETURN OR MAKE SINGULAR
\r
5200 SING: SETZB ZERO,DETER
\r
5202 DETB: MOVE ZERO,DETER
\r
5208 \f SUBTTL INTRINSIC FUNCTIONS (ADAPTED FROM LIB4 V.005)
\r
5210 ;FLOATING POINT SINGLE PRECISION ARCTANGENT FUNCTION
\r
5211 ;ATAN(X) = X(B0+A1(Z+B1-A2(Z+B2-A3(Z+B3)**-1)**-1)**-1)
\r
5212 ;WHERE Z=X^2, IF 0<X<=1
\r
5214 ;IF X>1, THEN ATAN(X) = PI/2 - ATAN(1/X)
\r
5215 ;IF X>1, THEN RH(A) =-1, AND LH(A) = -SGN(X)
\r
5216 ;IF X<1, THEN RH(A) = 0, AND LH(A) = SGN(X)
\r
5218 ATANB: ;ENTRY TO ARCTANGENT ROUTINE
\r
5219 MOVM T, N ;GET ABSF OF ARGUMENT
\r
5220 CAMG T, A1 ;IF A<2^33, THEN RETURN WITH...
\r
5221 POPJ P, ;ATAN(X)=X
\r
5222 HLLO B, N ;SAVE SIGN, SET PH(A) = -1
\r
5223 CAML T, A2 ;IF A>2^33, THEN RETURN WITH
\r
5224 JRST N, AT4 ;ATAN(X) = PI/2
\r
5225 MOVSI T1, (1.0) ;FORM 1.0 IN T1
\r
5226 CAMG T, T1 ;IS ABSF(X)>1.0?
\r
5227 TRZA B, -1 ;IF T .E. 1.0, THEN RH(A) = 0
\r
5228 FDVM T1, T ;B IS REPLACED BY 1.0/B
\r
5229 TLC B, (B) ;XOR SIGN WITH .G. 1.0 INDICATOR
\r
5230 MOVEM T, C3 ;SAVE THE ARGUMENT
\r
5232 MOVE T1, KB3 ;PICK UP N CONSTANT
\r
5233 FAD T1, T ;ADD B^2
\r
5234 MOVE N, KA3 ;ADD IN NEXT CONSTANT
\r
5235 FDVM N, T1 ;FORM -A3/(B^2 + B3)
\r
5236 FAD T1, T ;ADD B^2 TO PARTIAL SUM
\r
5237 FAD T1, KB2 ;ADD B2 TO PARTIAL SUM
\r
5238 MOVE N, KA2 ;PICK UP -A2
\r
5239 FDVM N, T1 ;DIVIDE PARTIAL SUM BY -A2
\r
5240 FAD T1, T ;ADD B^2 TO PARTIAL SUM
\r
5241 FAD T1, KB1 ;ADD B1 TO PARTIAL SUM
\r
5242 MOVE N, KA1 ;PICK UP A1
\r
5243 FDV N, T1 ;DIVIDE PARTIAL SUM BY A1
\r
5244 FAD N, KB0 ;ADD B0
\r
5245 FMP N, C3 ;MULTIPLY BY ORIGINAL ARGUMENT
\r
5246 TRNE B, -1 ;CHECK .G. 1.0 INDICATOR
\r
5247 FSB N, PIOT ;ATAN(N) = -(ATAN(1/A)-PI/2)
\r
5249 AT4: MOVE N, PIOT ;GET PI/2 AS ANSWER
\r
5250 NEGANS: SKIPGE B ;LH(A)= -SGN(T) IF B>1.0
\r
5251 MOVNS N ;NEGATE ANSWER
\r
5254 A1: 145000000000 ;2**-33
\r
5255 A2: 233000000000 ;2**33
\r
5256 KB0: 176545543401 ;0.1746554388
\r
5257 KB1: 203660615617 ;6.762139240
\r
5258 KB2: 202650373270 ;3.316335425
\r
5259 KB3: 201562663021 ;1.448631538
\r
5260 KA1: 202732621643 ;3.709256262
\r
5261 KA2: 574071125540 ;-7.106760045
\r
5262 KA3: 600360700773 ;-0.2647686202
\r
5263 PIOT: 201622077325 ;PI/2
\r
5264 \f;FLOATING POINT TRUNCATION FUNCTION
\r
5265 ;TRUNCATES FRACTIONAL PART OF FLOATING POINT NUMBER
\r
5266 ;AND RETURNS ANSWER AS N FLOATING POINT NUMBER. THE
\r
5267 ;ALGORITHM MAKES USE OF THE NORMALIZING PROPERTIES OF FAD.
\r
5268 ;ROUTINE EXITS WITH (T)=ZERO IF NUMBER WAS AN INTEGER.
\r
5271 MOVE B,N ;SAVE ARGUMENT
\r
5272 MOVMS N ;GET ABSF(ARG)
\r
5273 SKIPGE B ;NEGATIVE?
\r
5274 FAD N,ALMST1 ;YES. MAKE AINT[-2.3]=-3 ETC.
\r
5275 CAML N,MOD1 ;IS ARGUMENT<=2**26?
\r
5276 JRST NEGANS ;YES; IT MUST BE AN INTERGER ALREADY
\r
5278 FSB N,MOD1 ;NOW FRACTIONAL PART HAS BEEN LOST.
\r
5279 JRST NEGANS ;CHECK SIGN AND EXIT.
\r
5281 MOD1: XWD 233400,000000 ; 2**26
\r
5283 ALMST1: XWD 200777,777777 ;1.0-<SMALLEST QUANTITY>
\r
5285 \f;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
\r
5286 ;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
\r
5287 ;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS
\r
5289 ;LOGE(X) = (I + LOG2(F))*LOGE(2)
\r
5290 ;WHERE X = (F/2)*2^(I+1), AND LOG2(F) IS GIVEN BY
\r
5291 ;LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 1/2
\r
5292 ;AND Z = (F-SQRT(2))/(F+SQRT(2))
\r
5296 LOGB0: MOVMS N, N ;USE ABSOLUTE VALUE
\r
5297 JUMPE N, LZERO ;CHECK FOR ZERO ARGUMENT
\r
5298 CAMN N, ONE ;CHECK FOR 1.0 ARGUMENT
\r
5299 JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.
\r
5300 ASHC N, -33 ;SEPARATE FRACTION FROM EXPONENT
\r
5301 ADDI N, 211000 ;FLOAT THE EXPONENTY AND MULT. BY 2
\r
5302 MOVSM N, C3 ;NUMBER NOW IN CORRECT FL. FORMAT
\r
5303 MOVSI N, 567377 ;SET UP -401.0 IN N
\r
5304 FADM N, C3 ;SUBTRACT 401 FORM EXP.*2
\r
5305 ASH T, -10 ;SHIFT FRACTION FOR FLOATING
\r
5306 TLC T, 200000 ;FLOAT THE FRACTION PART
\r
5307 FAD T, L1 ;B = T-SQRT(2.0)/2.0
\r
5308 MOVE N, T ;PUT RESULTS IN N
\r
5309 FAD N, L2 ;A = N+SQRT(2.0)
\r
5311 MOVEM T, SX ;STORE NEW VARIABLE IN LZ
\r
5312 FMP T, T ;MULTIPLY BY Z^2
\r
5313 MOVE N, L3 ;PICK UP FIRST CONSTANT
\r
5314 FMP N, T ;MULTIPLY BY Z^2
\r
5315 FAD N, L4 ;ADD IN NEXT CONSTANT
\r
5316 FMP N, T ;MULTIPLY BY Z^2
\r
5317 FAD N, L5 ;ADD IN NEXT CONSTANT
\r
5318 FMP N, SX ;MULTIPLY BY Z
\r
5319 FAD N, C3 ;ADD IN EXPONENT TO FORM LOG2(X)
\r
5320 FMP N, L7 ;MULTIPLY TO FORM LOGE(X)
\r
5322 LZERO: PUSHJ P,INLMES
\r
5323 ASCIZ /LOG OF ZERO IN /
\r
5327 ZERANS: SETZI N, ;MAKE ARG ZERO
\r
5330 ;CONSTANTS FOR ALOGB
\r
5334 L1: 577225754146 ;-0.707106781187
\r
5335 L2: 201552023632 ;1.414213562374
\r
5336 L3: 200462532521 ;0.5989786496
\r
5337 L4: 200754213604 ;0.9614706323
\r
5338 L5: 202561251002 ;2.8853912903
\r
5339 ALOGB1: PUSH P,N ;SAVE ARGUMENT
\r
5341 ASCIZ /LOG OF NEGATIVE NUMBER IN /
\r
5342 PUSHJ P,GOSR3 ;PRINT LINE NUMBER
\r
5343 POP P,N ;GET ARGUMENT
\r
5345 L7: 200542710300 ;0.69314718056
\r
5346 MIFI: XWD 400000,000001 ;GOAL POSTS. LARGEST NEGATIVE NUMBER.
\r
5347 NUMB: MOVE N,NUMRES
\r
5350 JUMPE N,ZERANS ;RETURN ZERO ANSWER
\r
5352 MOVSI N,(1.0) ;RETURN 1.0
\r
5353 JRST NEGANS ;CHECK IF MINUS RESULT
\r
5355 \f;FLOATING POINT SINGLE PRECISION SINE AND COSINE FUNCTION
\r
5356 ;THE ARGUMENT IS IN RADIANS.
\r
5357 ;ENTRY POINTS ARE SIN AND COS.
\r
5358 ;COS CALLS SIN TO CALCULATE SIN(PI/2 + X)
\r
5360 ;THE ROUTINE CALCULATES SINES AFTER REDUCING THE ARGUMENT TO
\r
5361 ;THE FIRST QUADRANT AND CHECKING THE OVERFLOW BITS TO DETERMINE
\r
5362 ;THE QUADRANT OF THE ORIGINAL ARGUMENT
\r
5363 ;000 - 1ST QUADRANT
\r
5364 ;001 - 2ND QUADRANT, X=-(X-PI)
\r
5365 ;010 - 3RD QUADRANT, X=-(X-PI)
\r
5366 ;011 - 4TH QUADRANT, X=X-3*PI/2-PI/2
\r
5367 ;THE ALGORITHM USES N MODIFIED TAYLOR SERIES TO CALCULATE
\r
5368 ;THE SINE OF THE NORMALIZED ARGUMENT.
\r
5371 COSB: ;ENTRY TO COSINE RADIANS ROUTINE
\r
5372 FADR N, PIOT ;ADD PI/2
\r
5373 ;FALL INTO SINE ROUTINE
\r
5375 SINB: ;ENTRY TO SINE RADIANS ROUTINE
\r
5376 MOVE T, N ;PICK UP THE ARGUMENT IN T
\r
5377 MOVEM T, SX ;SAVE IT
\r
5378 MOVMS T ;GET ABSF OF ARGUMENT
\r
5379 CAMG T, SP2 ;SINX = X IF X<2^-10
\r
5380 POPJ P, ;EXIT WITH ANS=ARG
\r
5381 FDV T, PIOT ;DIVIDE X BY PI/2
\r
5382 CAMG T, ONE ;IS X/(PI/2) < 1.0?
\r
5383 JRST S2 ;YES, ARG IN 1ST QUADRANT ALREADY
\r
5384 MULI T, 400 ;NO, SEPARATE FRACTION AND EXP.
\r
5385 ASH T1, -202(T) ;GET X MODULO 2PI
\r
5386 MOVEI T, 200 ;PREPARE FLOATING FRACTION
\r
5387 ROT T1, 3 ;SAVE 3 BITS TO DETERMINE QUADRANT
\r
5388 LSHC T, 33 ;ARGUMENT NOW IN RANHGE (-1,1)
\r
5389 FAD T, SP3 ;NORMALIZE THE ARGUMENT
\r
5390 JUMPE T1, S2 ;REDUCED TO FIRST QUAD IF BITS 00
\r
5391 TLCE T1, 1000 ;SUBTRACT 1.0 FROM ARG IF BITS ARE
\r
5392 FSB T, ONE ;01 OR 11
\r
5393 TLCE T1, 3000 ;CHECK FOR FIRST QUADRANT, 01
\r
5394 TLNN T1, 3000 ;CHECK FOR THIRD QUADRANT, 10
\r
5397 S2: SKIPGE SX ;CHECK SIGN OF ORIGINAL ARG
\r
5398 MOVNS T ;SIN(-X) = -SIN(X)
\r
5399 MOVEM T, SX ;STORE REDUCED ARGUMENT
\r
5400 FMPR T, T ;CALCULATE X^2
\r
5401 MOVE N, SC9 ;GET FIRST CONSTANT
\r
5402 FMP N, T ;MULTIPLY BY X^2
\r
5403 FAD N, SC7 ;ADD IN NEXT CONSTANT
\r
5404 FMP N, T ;MULTIPLY BY X^2
\r
5405 FAD N, SC5 ;ADD IN NEXT CONSTANT
\r
5406 FMP N, T ;MULTIPLY BY X^2
\r
5407 FAD N, SC3 ;ADD IN NEXT CONSTANT
\r
5408 FMP N, T ;MULTIPLY BY X^2
\r
5409 FAD N, PIOT ;ADD IN LAST CONSTANT
\r
5410 FMPR N, SX ;MULTIPLY BY X
\r
5414 SC3: 577265210372 ;-0.64596371106
\r
5415 SC5: 175506321276 ;0.07968967928
\r
5416 SC7: 606315546346 ;0.00467376557
\r
5417 SC9: 164475536722 ;0.00015148419
\r
5419 SP2: 170000000000 ;2**-10
\r
5422 SCD1: 206712273406
\r
5423 \f;FLOATING POINT SINGLE PRECISION SQUARE ROOT FUNCTION
\r
5424 ;THE SQUARE ROOT OF THE ABSOLUTE VALUE OF THE ARGUMENT IS
\r
5425 ;CALCULATED. THE ARGUMENT IS WRITTEN IN THE FORM
\r
5426 ; X= F*(2**2B) WHERE 0<F<1
\r
5427 ;SQRT(X) IS THEN CALCULATED AS (SQRT(X))*(2**B)
\r
5428 ;SQRT(F) IS CALCULATED BY N LINEAR APPROXIMATION, THE NATURE
\r
5429 ;OF WHICH DEPENDS ON WHETHER 1/4 < F < 1/2 OR 1/2 < F < 1,
\r
5430 ;FOLLOWED BY TWO ITERATIONS OF NEWTON'S METHOD.
\r
5432 SQRTB: MOVE T, N ;PICK UP THE ARGUMENT IN T
\r
5433 SQRTB0: JUMPL T, SQRMIN ;SQRT OF NEGATIVE NUMBER?
\r
5434 JUMPE T, ZERANS ;CHECK FOR AGUMENT OF ZERO
\r
5435 ASHC T, -33 ;PUT EXPONENT IN T, FRACTION IN T1
\r
5436 SUBI T, 201 ;SUBTRACT 201 FROM EXPONENT
\r
5437 ROT T, -1 ;CUT EXP IN HALF, SAVE ODD BIT
\r
5438 HRRM T, EX1 ;SAVE FOR FUTURE SCALING OF ANS
\r
5439 ;IN FSC N,. INSTRUCTION
\r
5440 LSH T, -43 ;GET BIT SAVED BY PREVIOUS INST.
\r
5441 ASH T1, -10 ;PUT FRACTION IN PROPER POSITION
\r
5442 FSC T1, 177(T) ;PUT EXPONENT OF FRACT TO -1 OR 0
\r
5443 MOVEM T1, N ;SAVE IT. 1/4 < F < 1
\r
5444 FMP T1, SQCON1(T) ;LINEAR FIRST APPROX,DEPENDS ON
\r
5445 FAD T1, SQCON2(T) ;WHETHER 1/4<F<1/2 OR 1/2<F<1.
\r
5446 MOVE T, N ;START NEWTONS METHOD WITH FRAC
\r
5447 FDV T, T1 ;CACULATE X(0)/X(1)
\r
5448 FAD T1, T ;X(1) + X(0)/X(1)
\r
5449 FSC T1, -1 ;1/2(X(1) + X(0)/X(1))
\r
5450 FDV N, T1 ;X(0)/X(2)
\r
5451 FADR N, T1 ;X(2) + X(0)/X(2)
\r
5455 SQCON1: 0.8125 ;CONSTANT, USED IF 1/4<FRAC<1/2
\r
5456 0.578125 ;CONSTANT, USED IF 1/2<FRAC<1
\r
5457 SQCON2: 0.302734 ;CONSTANT, USED IF 1/4<FRAC<1/2
\r
5458 0.421875 ;CONSTANT, USED IF 1/2<FRAC<1
\r
5460 SQRMIN: PUSH P,T ;SAVE ARG
\r
5462 ASCIZ /SQRT OF NEGATIVE NUMBER IN /
\r
5463 PUSHJ P,GOSR3 ;PRINT LINE NUMBER
\r
5466 JRST SQRTB0 ;USE ABSOLUTE VALUE
\r
5468 \f;TAN - SINGLE PRECISION TANGENT ROUTINE.
\r
5470 ;BASED ON ACM ALGORITHM 229, (COMM. ACM, 7, MAY 1964, J. MORELOCK).
\r
5474 ;TAN(N*(PI/2)+A) = -(1/TAN(A)) IF N IS ODD,
\r
5475 ;TAN(N*(PI/2)+A) = TAN(A) IF N IS EVEN.
\r
5477 ;/A/ IS <= 0.5*(PI/2).
\r
5479 ;ON ENTRY, THE ARG IS IN AC N.
\r
5480 ;ON EXIT, THE ANSWER IS IN AC N.
\r
5482 ;COTAN (X)=TAN(PI/2-X)
\r
5484 COTB: MOVNS N ;CALCULATE -X...
\r
5485 FADR N,PIOT ;PLUS PI/2
\r
5486 TANB: MOVEM N,PIVOT
\r
5493 TANB1: PUSHJ P,INLMES
\r
5494 ASCIZ 'TAN OF PI/2 OR COTAN OF ZERO IN '
\r
5496 \f;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
\r
5497 ;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
\r
5498 ; -88.028<X<88.028
\r
5499 ;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
\r
5500 ;IF X>88.028, THE PROGRAM RETURNS +INFINITY AS THE ANSWER
\r
5501 ;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
\r
5502 ;EXP(X) = 2**(X*LOG(B)BASE2) = 2**(M+F)
\r
5503 ;WHERE M IS AN INTEGER AND F IS N FRACTION
\r
5504 ;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
\r
5505 ;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS
\r
5507 ;2**F = 2(0.5+F(A+B*F^2 - F-C(F^2 + D)**-1)**-1
\r
5509 ;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
\r
5512 ;THE ARGUMENT IS IN N
\r
5513 ;THE ANSWER IS RETURNED IN ACCUMULATOR N
\r
5515 EXPB: ;ENTRY TO EXPONENTIAL ROUTINE
\r
5516 MOVE T, N ;PICK UP THE ARGUMENT IN T
\r
5517 MOVM N, T ;GET ABSF(X)
\r
5518 CAMLE N, E7 ;IS ARGUMENT IN PROPER RANGE?
\r
5519 JRST N, EXTOLG ;EXP TO LARGE.;##MSG +CON OR STOP?
\r
5521 SETZM N, ES2 ;INITIALIZE ES2
\r
5522 MULI T, 400 ;SEPARATE FRACTION AND EXPONENT
\r
5523 TSC T, T ;GET N POSITIVE EXPONENT
\r
5524 MUL T1, E5 ;FIXED POINT MULTIPLY BY LOG2(B)
\r
5525 ASHC T1, -242(T) ;SEPARATE FRACTION AND INTEGER
\r
5526 AOSG T1 ;ALGORITHM CALLS FOR MULT. BY 2
\r
5527 AOS T1 ;ADJUST IF FRACTION WAS NEGATIVE
\r
5528 HRRM T1, EX ;SAVE FOR FUTURE SCALING
\r
5529 ASH A, -10 ;MAKE ROOM FOR EXPONENT
\r
5530 TLC A, 200000 ;PUT 200 IN EXPONENT BITS
\r
5531 FADB A, ES2 ;NORMALIZE, RESULTS TO A AND ES2
\r
5532 FMP A, A ;FORM X^2
\r
5533 MOVE N, E2 ;GET FIRST CONSTANT
\r
5534 FMP N, A ;E2*X^2 IN N
\r
5535 FAD A,E4 ;ADD E4 TO RESULTS IN A
\r
5536 MOVE T, E3 ;PICK UP E3
\r
5537 FDV T, A ;CALCULATE E3/(F^2 + E4)
\r
5538 FSB N, T ;E2*F^2-E3(F^2 + E4)**-1
\r
5539 MOVE T1, ES2 ;GET F AGAIN
\r
5540 FSB N, T1 ;SUBTRACT FROM PARTIAL SUM
\r
5541 FAD N, E1 ;ADD IN E1
\r
5542 FDVM T1, N ;DIVIDE BY F
\r
5544 XCT EX ;SCALE THE RESULTS
\r
5547 E1: 204476430062 ;9.95459578
\r
5548 E2: 174433723400 ;0.03465735903
\r
5549 E3: 212464770715 ;617.97226953
\r
5550 E4: 207535527022 ;87.417497202
\r
5551 E5: 270524354513 ;LOG(B), BASE 2
\r
5553 E7: 207540071260 ;88.028
\r
5554 EXTOLG: PUSHJ P,INLMES
\r
5555 ASCIZ /EXP TOO LARGE IN /
\r
5558 \f;SINGLE PRECISION EXP.2 FUNCTION
\r
5559 ;THIS ROUTINE CALCULATES A FLOATING POINT NUMBER TO A FIXED
\r
5560 ;POINT POWER. THE CALCULATION IS A**B, WHERE T IS OF THE FORM
\r
5562 ; T=Q(0) + Q(1)*2 + Q(2)*4 + ...WHERE Q(I)=0 OR 1
\r
5564 ;THE BASE IS IN ACCUMULATOR N
\r
5565 ;AND THE EXPONENT IS IN ACCUMULATOR (N+1) WHEN THE ROUTINE IS
\r
5566 ;CALLED. THE ANSWER IS RETURNED IN ACCUMULATOR N.
\r
5567 ;EXP.2 IS CALLED ONLY BY EXP.3. IT IS GUARANTEED THAT THE
\r
5568 ;BASE AND THE EXPONENT ARE NON-ZERO.
\r
5571 EXP2.0: JUMPE N,FEXP3
\r
5574 MOVMS N,T ;ABSOLUTE VALUE
\r
5579 FEXP1: FMP N,N ;FORM A**N, FLOATING POINT
\r
5580 LSH T,-1 ;SHIFT EXPONENT FOR NEXT BIT
\r
5581 FEXP2: TRZE T,1 ;IS THE BIT ON?
\r
5582 FMP T1,N ;YES, MULTIPLY ANSWER BY A**N
\r
5583 JUMPN T,FEXP1 ;UPDATE A**N UNLESS ALL THOUGH
\r
5584 MOVE N,T1 ;PICK UP RESULT FROM T1
\r
5590 ;SINGLE PRECISION FORTRAN IV EXP.3 FUNCTION
\r
5591 ;THIS ROUTINE CALCULATES A FLOATING POINT NUMBER RAISED TO A
\r
5592 ;FLOATING POINT POWER. THE CALCULATION IS
\r
5593 ; A**B= EXP(B*LOG(N))
\r
5595 ;IF THE EXPONENT IS AN INTEGER THE
\r
5596 ;RESULT WILL BE COMPUTED USING "EXP2.0" .
\r
5598 ;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
\r
5600 ;THE BASE IS IN ACCUMULATOR N
\r
5601 ;AND THE EXPONENT IS IN ACCUMULATOR (N+1) WHEN THE ROUTINE
\r
5602 ;IS CALLED. THE RESULT IS RETURNED IN ACCUMULATOR N.
\r
5607 EXP3.0: JUMPE T,EXP3A ;IS EXPONENT ZERO?
\r
5608 JUMPE N,EXP3B ;IS BASE ZERO?
\r
5609 EXP3A0: MOVM A,T ;SET UP ABS VAL OF EXPON FOR SHIFTING
\r
5610 JUMPL N,EXP3C ;IS BASE NEGATIVE?
\r
5611 EXP3A1: MOVEI T1,0 ;CLEAR AC T1 TO ZERO
\r
5612 LSHC T1,11 ;SHIFT 9 PLACES LEFT
\r
5613 SUBI T1,200 ;TO OBTAIN SHIFTING FACTOR
\r
5619 SKIPGE T ;YES, WAS IT NEG. ?
\r
5620 MOVNS T1 ;YES, NEGATE IT
\r
5621 MOVE T,T1 ;MOVE INTEGER INTO T
\r
5622 JRST EXP2.0 ;OBTAIN RESULT USING EXP2.0
\r
5623 EXP3GO: PUSH P,T ;SAVE EXPONENT
\r
5624 PUSHJ P,LOGB ;CALCULATE LOG OF N
\r
5625 FMPR N,(P) ;CALCULATE B*LOG(N)
\r
5626 PUSHJ P,EXPB ;CALCULATE EXP(B*LOG(N))
\r
5630 EXP3A: MOVSI N,(1.0) ;ANSWER IS 1.0
\r
5633 EXP3B: JUMPGE T,ZERANS
\r
5635 ASCIZ /ZERO TO A NEGATIVE POWER IN /
\r
5637 LRGNS1: HRLOI N,377777 ;LARGEST ANSWER
\r
5644 JRST EXP3A1 ;NEGATIVE BASE, INTEGRAL POWER
\r
5645 PUSH P,N ;SAVE ARGUMENTS
\r
5648 ASCIZ /ABSOLUTE VALUE RAISED TO POWER IN /
\r
5655 \f SUBTTL RUN-TIME RANDOM NUMBER ROUTINES
\r
5658 ;;WRANB -- PSEUDO-RANDOM RESET/WARMUP
\r
5661 ;THE ARG IS IN ACCUMULATOR A
\r
5663 ; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.
\r
5664 ; 2. W IS A BIT VECTOR (BITS 05-35 SIGNIFICANT).
\r
5665 ; 3. RETURNS NO USEFUL VALUE IN AC Z.
\r
5666 ; 4. CREATES A BASIS OF "NNN" VECTORS AT VRANT IN VRAN,
\r
5667 ; BASED ON THE WARMUP ARGUMENT W. (STANDARD VALUE
\r
5668 ; IS W=0.) RESETS VRAN'S OWN INDEX. USES VRAN LOCATIONS
\r
5669 ; VRANR ; VRAN OWN INDEX RESET VALUE.
\r
5670 ; VRANW ; VRAN'S WARMUP CONSTANT.
\r
5671 ; VRANT ; VRAN'S VECTOR-TABLE.
\r
5672 ; VRANN ; NEGATIVE TABLE LENGTH.
\r
5673 ; 5. FORTRAN AC ASSIGNMENTS ARE
\r
5674 ; N=00 ; FUNCTION-VALUE RETURN AC.
\r
5675 ; T=1 ; SCRATCH AC.
\r
5676 ; P=17 ; PUSHDOWN LIST
\r
5677 ; T1=2 ; INDEX AC.
\r
5679 ; 6. WRAN MAY BE USED FREELY TO REPEAT A PREVIOUSLY GENERATED
\r
5680 ; SEQUENCE (BY CALLING WRAN WITH THE PREVIOUSLY USED VALUE
\r
5681 ; FOR W), OR TO CAUSE THE GENERATION OF A COMPLETELY NEW
\r
5682 ; SEQUENCE (BY CALLING WRAN WITH A NEW VALUE FOR W).
\r
5685 ...=0 ; ELLIPSIS (FOR CONVENIENCE).
\r
5688 WRANB: XOR N,VRANW ; ADJUST,
\r
5689 TLZ N,(37B4) ; IGNORE BITS 00-04
\r
5690 JUMPE N,WRANB ; REJECT 0.
\r
5691 MOVSI T1,777771 ; ESTABLISH OUTER LOOP.
\r
5692 WRAN2: MOVNI A,6 ;ESTABLISH INNER LOOP.
\r
5693 WRAN3: MOVE T,N ; COPY ARGUMENT,
\r
5694 ROT T,13 ; POSITION BITS 05-10 FOR
\r
5695 XOR T,N ; MOD 2 SUM WITH BITS 30-35.
\r
5696 ROT T,-6 ; USE RESULT AS NEW
\r
5697 LSHC N,6 ; ARGUMENT BITS 30-35
\r
5698 AOJN A,WRAN3 ; SIX BYTES DONE? NO, BACK.
\r
5699 MOVEM N,VRANT(T1) ; YES, ARGUMENT IS BASIS VECTOR.
\r
5700 AOBJN T1,WRAN2 ; "NNN" VECTORS DONE? NO, BACK.
\r
5701 MOVE N,VRANR ; RESET VRAN OWN INDEX.
\r
5702 MOVEM N,VRANX ; (AFTER RESTORING AC'S!)
\r
5703 POPJ P, ; RETURN (OVER "ARG").
\r
5705 ;FRANB -- FLOATING-POINT PSEUDO-RANDOM GENERATOR.
\r
5709 ; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.
\r
5710 ; 3. RETURNS IN AC N A FLOATING-POINT NUMBER AS AN
\r
5711 ; INSTANCE OF A REAL RANDOM VARIABLE UNIFORMLY
\r
5712 ; DISTRIBUTED ON THE OPEN INTERVAL (0,1).
\r
5713 ; 4. REQUIRES THE VECTOR GENERATOR FUNCTION VRAN.
\r
5715 ; 5. FORTRAN AC ASSIGNMENTS ARE
\r
5717 FRAN1: PUSHJ P,VRANB ; GET RANDOM VECTOR,
\r
5718 LSH N,-9 ; SCALE TO MANTISSA,
\r
5719 JUMPE N,FRAN1 ; REJECT ZERO.
\r
5720 TLO N,(1B1) ; FORCE EXPONENT OF 2^0.
\r
5721 FAD N,[1B1] ; NORMALIZE.
\r
5722 POPJ P, ; RETURN (IGNORE "ARG").
\r
5724 ;VRAN7B -- 36-BIT PSEUDO-RANDOM GENERATOR.
\r
5726 ;; NAME SHOULD ALWAYS BE
\r
5727 ;; "VRANXX", WHERE "XX" IS THE ASSEMBLED VALUE OF
\r
5728 ;; THE PARAMETER "NNN". (SEE 6. BELOW.) USE ONLY THE
\r
5729 ;; STATISTICALLY BEST "EEE" VALUE FOR EACH "NNN" VALUE.
\r
5733 ; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.
\r
5734 ; 3. RETURNS IN AC N A 36-BIT PSEUDO-RANDOM VECTOR.
\r
5735 ; VRANX ; AC STORAGE, OWN INDEX.
\r
5736 ; VRANR ; OWN INDEX RESET VALUE.
\r
5737 ; VRANW ; WARMUP CONSTANT.
\r
5738 ; VRANT ; VECTOR-TABLE.
\r
5739 ; VRANN ; NEGATIVE TABLE LENGTH.
\r
5740 ; 6. VRAN HAS THREE ASSEMBLY PARAMETERS:
\r
5742 NNN=7 ; VECTOR-TABLE SIZE.
\r
5743 EEE=3 ; VECTOR-TABLE OFFSET.
\r
5745 W=013702175435 ; VECTOR-TABLE GENERATOR.
\r
5746 ; WHICH ARE USED TO ESTABLISH AN INITIAL TABLE OF
\r
5747 ; "NNN" BASIS VECTORS <V[J] : 0 .LE. J .LT. NNN>, AND TO
\r
5748 ; GENERATE SUCCESSIVE VECTORS ACCORDING TO THE RULE:
\r
5749 ; V[NNN+J] = (V[0+J] + V[EEE+J]) MODULO (2^36) : 0 .LE. J.
\r
5750 ; (SEE RANPAK.TXT FOR ADMISSABLE VALUES FOR <NNN,EEE,W>,
\r
5751 ; AND A DISCUSSION OF THE ALGORITHM.)
\r
5753 VRANN=-NNN ; NEGATIVE TABLE LENGTH (FOR WRAN).
\r
5756 VRANB: MOVE T1,VRANX ; SET UP OWN INDEX.
\r
5757 MOVE N,VRANT+NNN(T1) ; ADDEND V[E+J] IF J .LT. N-E
\r
5758 TRNN T1,(1B0) ; [J.LT.N-E]=[RH(T1).LT.0]?
\r
5759 MOVE N,VRANT+0(T1) ; ADDEND V[E+J] IF J .GE. N-E.
\r
5760 ADDB N,VRANT+NNN-EEE(T1) ; AUGEND V[0+J] AND RESULT V[N+J].
\r
5761 AOBJN T1,VRAN1 ; SETP J; J.GT.N? NO,OVER.
\r
5762 MOVE T1,VRANR ; YES, RESET J.
\r
5763 VRAN1: MOVEM T1,VRANX ; SAVE OWN INDEX
\r
5766 VRANR: XWD -<NNN+1>,-<NNN-EEE> ; OWN INDEX RESET VALUE
\r
5768 VRANW: EXP W ;WARMUP CONSTANT (FOR WRAN).
\r
5776 FRSTLN: BLOCK 1 ;141
\r
5777 LASTLN: BLOCK 1 ;142
\r
5778 LOWEST: BLOCK 1 ;143
\r
5779 PREAD: BLOCK 2 ;144
\r
5780 PINPUT: BLOCK 2 ;146
\r
5781 DATLIN: BLOCK 2 ;150
\r
5782 DATAFF: BLOCK 1 ;152
\r
5783 HPOS: BLOCK 1 ;153
\r
5784 REGPNT: BLOCK 1 ;154
\r
5785 TMPLOW: BLOCK 1 ;155
\r
5786 TMPPNT: BLOCK 1 ;156
\r
5787 PSHPNT: BLOCK 1 ;157
\r
5788 SEQPNT: BLOCK 1 ;160
\r
5789 TOPSTG: BLOCK 1 ;161
\r
5790 SVRBOT: BLOCK 1 ;162
\r
5791 SVRTOP: BLOCK 1 ;163
\r
5792 FMTPNT: BLOCK 1 ;164
\r
5793 IFFLAG: BLOCK 1 ;165
\r
5795 VARFRE: BLOCK 1 ;166
\r
5796 FCNLNK: BLOCK 1 ;167
\r
5797 ELETOP: BLOCK 1 ;170
\r
5798 FUNAME: BLOCK 1 ;171
\r
5799 LETSW: BLOCK 1 ;172
\r
5800 MTIME: BLOCK 1 ;173
\r
5802 FUNSTA: BLOCK 1 ;175
\r
5803 FUNLOW: BLOCK 1 ;176
\r
5804 LOWSTA: BLOCK 1 ;177
\r
5805 SB1M1: BLOCK 1 ;200
\r
5806 SB2M1: BLOCK 1 ;201
\r
5807 TEMP1: BLOCK 1 ;202
\r
5808 TEMP2: BLOCK 1 ;203
\r
5809 TEMP3: BLOCK 1 ;204
\r
5812 TTYBUF: BLOCK 3 ;213
\r
5814 LINB0: BLOCK 20 ;216
\r
5816 DRMBUF: BLOCK 2 ;236
\r
5817 VECT1: BLOCK 100 ;240
\r
5818 VECT2: BLOCK 100 ;340
\r
5820 STRFCN: BLOCK 1 ;441
\r
5821 TABVAL: BLOCK 1 ;442
\r
5822 RUNFLA: BLOCK 1 ;443
\r
5823 OLDFLA: BLOCK 1 ;444
\r
5824 RENFLA: EXP -1 ;445
\r
5825 CURDEV: BLOCK 1 ;446
\r
5826 CURNAM: BLOCK 1 ;447
\r
5827 CUREXT: BLOCK 1 ;450
\r
5828 DETER: BLOCK 1 ;451
\r
5829 NUMRES: BLOCK 1 ;452
\r
5830 VRANX: BLOCK 1 ;453
\r
5831 FILDIR: BLOCK 1 ;454
\r
5835 EX: FSC N,0 ;SCALE THE RESULTS
\r
5836 BADMSG: ASCII /MISSING LINE NUMBER FOLLOWING LINE /
\r
5847 DEFINE .WRAN(NN,WW) < ; ASSEMBLES "WRAN(0)" BASIS.
\r
5851 %Q=<%A ! %Q> & <-1-<%A & %Q>>
\r
5852 %A=<%A>B<35-6> ! <%Q & 77> >
\r
5858 VRANT: .WRAN(NNN,W)
\r
5860 NEWOL1: SIXBIT /DSK/
\r
5863 WEAV: SIXBIT /DSK/
\r
5866 SAVEX: SIXBIT /DSK/
\r
5897 PSHROL=200000 ;ADDRESS ASSOCIATED WITH THIS
\r
5898 ;PHANTOM ROLL ARE ABSOLUTE, INDEXED BY (P)
\r
5935 COMBOT=VARROL ;BOTTOM COMPILE ROLL AFTER CODROL
\r
5936 COMTOP=NXTROL ;TOP COMPILE ROLL.
\r
5937 ONCESW: EXP -1 ;ONCE-ONLY SWITCH FOR START
\r
5938 ;AFTERWARDS, THE CONSTANT ZERO.
\r
5940 PAKFLA: BLOCK 1 ;612 ;-1 IF TEXT IS NOT PACKED
\r
5941 VPAKFL: BLOCK 1 ;613 ;-1 IF VARIABLE SPACE PACKED.
\r
5942 INPFLA: BLOCK 1 ;614 ;NON-ZERO DURING INPUT,ZERO DURING READ
\r
5943 IFIFG: BLOCK 1 ;615
\r
5944 PIVOT: ES2: C3: BLOCK 1 ;616
\r
5949 EXTERN JOBSA,JOBREL,JOBFF,JOBREN,JOBOPC,JOBAPR,JOBTPC
\r
5951 MINFLG=400000 ;MINUS FLAG IN LEFT HALF OF EXPR PNTR
\r
5952 ROLMSK=377777 ;ROLL NUMBER MASK IN SAME
\r
5958 INTERN CE'A,FL'A >
\r
git://git.sky-visions.com / retro-software/dec/tops10/v4.5.git / blob