SEARCH FORPRM TV FORCNV CONVERSION ROUTINES ,6(2033) ;COPYRIGHT (C) 1981 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED ;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE ;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER ;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY ;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY ;TRANSFERRED. ;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE ;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT ;CORPORATION. ;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. SUBTTL REVISION HISTORY COMMENT \ ***** Begin Revision History ***** 256 ----- CORRECT %LSTDR TO CHANGE F%ELT TO F%EXT 345 (Q2322) OUTPUT 2 WORDS OF DBLE PREC VAR EVEN IF F FORMAT REQUIRED 347 ----- RESTRICT DELIMITER FOR LIST-DIRECTED INPUT TO BLANK, COMMA AND LINE TERMINATOR 350 (13704) LIST-DIRECTED INPUT DOES NOT TAKE END= RETURN 354 ----- FIX FREE FORMAT ON INPUT 357 ----- REDEFINE LABEL ERROR FOR MACRO V50 366 ----- FIX LIST DIRECTED I/O FOR ARRAYS 367 (13951) FIXED INTEGER FORMAT LOOSES BLANKS AT END OF RECORD 372 ----- FIX NAMELIST 373 (13917) FIX SCALING FACTOR 374 ----- END OF NAMELIST LIST FOR F10-V2 376 ----- CORRECT FIXED "A" FORMAT AFTER FREE FORMAT 377 ----- FIX F FORMAT 400 ----- FIX TO EDIT 372 426 15142 HAVE NAMELIST ACCEPT ANY 6 CHARS NAMELIST NAME 430 15596 FIX SO SCALING ON OUTPUT AFTER NAMELIST INPUT WORKS 433 15880 FIX INPUT OF OCTAL NUMBERS TO CORRECTLY HANDLE MINUS SIGN 441 16108 FIX %FLOUT SO SINGLE PREC. NOS. LIKE -1.999999 DON'T LOSE PRECISION 445 16517 FIX NAMELIST INPUT SO FLOATING POINT TO INTEGER CONV. WORKS FOR ALL CASES EVEN #'S LIKE 1.0 *************** BEGINNING OF VERSION 4C 461 16741 FIX NAMELIST TO ACCEPT ANY 6 CHAR VARIABLE NAME 462 16796 FIX %FLIRT SO CALL TO ILL CAUSES ILLEGAL CHARS IN DATA TO BE SET TO ZERO AND NOT SKIP VALID FOLLOWING CHARS 465 17142 FIX %NMLST TO INPUT STRINGS INTO DOUBLE PRECISION AND COMPLEX VARIABLES CORRECTLY. 476 17725 FIX G FORMAT WHEN FIELD TOO SMALL UNLESS 4X REMOVED. 517 18268 FIX F2.0 TO NEVER PRINT JUST A DOT. 533 19239 FIX %LSTDR TO CORRECTLY INPUT STRINGS INTO DOUBLE PRECISION NUMBERS. 534 19239 FIX %NMLST FOR INPUT OF STRINGS INTO ARRAYS 541 19793 FIX %NMLST FOR LIST-DIRECTED INPUT OF QUOTED STRINGS INTO ARRAYS WILL CLEAR F%QOT 544 12882 MAKE P SCALING WORK WITH F FORMAT FOR NUMBERS WHICH ARE IDENTICALLY ZERO 563 (V5) MAKE F FORMAT USE BOTH WORDS FOR DOUBLE PRECISION (%FLIRT AND %FLOUT) 566 Q00569 PRINT ZERO EXPONENT FOR IDENTICAL ZERO, D OR E FORMAT (%FLOUT) 574 Q00654 LIST DIRECTED INPUT OF COMPLEX NUMBERS SHOULD REQUIRE PARENTHESIS AROUND THE ARGUMENT, AND IF THERE IS A REPEAT COUNT IT SHOULD BE DELIMITED BY AN ASTERISK. 575 18964 LIST-DIRECTED I/O DOES NOT PROPERLY HANDLE S-LISTS WITH INCREMENTS NOT EQUAL TO ONE. 576 18964 LIST DIRECTED INPUT DOES NOT PROPERLY HANDLE S-LISTS WITH INCREMENTS OTHER THAN ONE. BEGIN VERSION 5A, 7-NOV-76 622 QA873 NAMELIST PARTIAL ARRAYS AT END OF LIST *************** BEGINNING OF VERSION 5A 652 22508 EXPONENT FIELDS SHOULD ACCEPT LOWER CASE D AND E 653 22543 ACCEPT LOWER CASE T AND F FOR TRUE AND FALSE 654 ----- FIX FLIRT TO HANDLE ALL INTEGERS CORRECTLY AND FIX NAMELIST TO STORE DATA TYPE IN LOW CORE 660 ----- FIX %FLOUT TO USE 8 NOT 9 AS MAX NUMBER OF MANTISSA DIGITS TO PRINT ON SINGLE PRECISION SO 5.55 IN F20.17 WON'T PRINT AS 5.55000001... NULLIFIED IN VERSION 6 - THE SINGLE PRECISION REPRESENTATION OF 5.55 IS 5.55000001. IF THE USER WANTS MORE DIGITS THAN THE "ACCURACY" OF THE MACHINE, WE WILL PRINT WHAT IS THERE, SO AS TO PRINT ENOUGH PRECISION TO HAVE ABSOLUTE DIFFERENTIATION BETWEEN NUMBERS (I.E., SO THAT OUTPUT FOLLOWED BY INPUT WILL ALWAYS YIELD THE SAME INTERNAL REPRESENTATION). 673 22607 IMPLEMENT VBL WIDTH DOUBLE PRECISION OCTAL I/O. *************** BEGIN VERSION 5B 735 24788 FIX EDIT 673 FOR KA SO THAT NEXT WORD IS NOT OVERWRITTEN WHEN DOING SINGLE PRECISION OCTAL INPUT 740 24891 FIX LIST-DIRECTED/NAMELIST OUTPUT TO SET G FORMAT FLAG BEFORE CALLING %REAL ON EACH PART OF COMPLEX VBL 756 25638 USE DEFAULT F FORMAT TO COUNT THE NO. OF ZEROS AFTER DECIMAL POINT WHEN THE NUMBER IS TOO SMALL TO PRINT. 761 11923 FIX EDIT 654 TO HANDLE INPUT INTEGERS CORRECTLY IN %FLIRT. 764 26523 IN %NMLST, CHECK FOR NULL FIELDS WITH LIST DIRECTED INPUT OF LOGICAL VARIABLE. 770 26836 FIX %NMLST TO HANDLE THE NAMELIST COMPLEX ARRAYS CORRECTLY BEGIN VERSION 6 REWORK ALL CONVERSION ROUTINES SO THEY HAVE SEPARATE INPUT AND OUTPUT ENTRY POINTS WITH COMMON SETUP ROUTINES. SEPARATED R-FORMAT CODE FROM A-FORMAT CODE, BUT USED COMMON SETUP ROUTINES. REDUCED NUMBER OF ACCUMULATORS USED BY FLIRT AND FLOUT, AND REWORKED ALL CONVERSION ROUTINES TO USE VERSION 6 ACCUMULATOR CONVENTIONS. INSTALLED EXTENDED EXPONENT HANDLING IN FLIRT, FLOUT, AND NAMELIST/LIST-DIRECTED I/O. INSTALLED SPARSE POWER OF TEN IN POWTAB FOR USE WITH EXTENDED EXPONENT. INCREASED NUMBER OF ENTRY POINTS IN FLOUT, AND THEREBY MADE G-FORMAT FLAG, E-FORMAT FLAG, AND D-FORMAT FLAG LOCAL TO FLOUT (ALTHOUGH THEY ARE STILL DEFINED IN FORPRM). MADE ALL NUMBER-HANDLING IN FLIRT/FLOUT DOUBLE-PRECISION, THUS ELIMINATING EXTRA SINGLE-PRECISION CODE, INCREASING ACCURACY OF SINGLE PRECISION NUMBERS, AND INCREASING TIME SPENT BY 1% OR SO. COMPLETELY REWROTE ROUNDING ALGORITHM, USING 9'S DIGIT COUNTER INSTEAD OF ADDING (INACCURATE) AMOUNTS FROM A ROUNDING TABLE. REMOVED OPTIONAL LEADING ZERO FROM FLOUT, THEREBY REMOVING A GREAT DEAL OF EXCESS CODE. IMPLEMENTED VARIABLE-SIZE EXPONENT WIDTH, INCLUDING LEAVING OFF 'D' OR 'E' IF EXPONENT IS TOO BIG. IMPLEMENTED S,SP,SS,BN,BZ FORMATS, AS WELL AS Iw.m AND Ow.m. MOVED ALL FREE-FORMAT HANDLING (SCANNING FOR DELIMITERS, ETC) OUT OF CONVERSION ROUTINES INTO THE FORMAT PROCESSOR, NAMELIST/LDIO, AND %SKIP. ???? ??? ??-???-80 Q10-04560 FIXED ERROR CALL IN NAMELIST/LDIO AT SETNUL. SHOULD HAVE BEEN %ILCHR, WAS %ILCH1, ARROW WAS OFF BY 1. 1153 JLC 9-Sep-80 --------- SPED UP ALPHI/ALPHO BY REMOVING SOME COMMON CODE, REMOVING CALL TO %SAVE2. 1154 JLC 9-Sep-80 --------- FIX TO INTI FOR OVERFLOW - OUTPUTS OVERFLOW MSG AND SETS VALUE TO HIGHEST INTEGER. 1155 JLC 9-Sep-80 --------- FIX FLOUT TO TURN OFF BIT 0 OF 2ND WORD TO PREVENT INTEGER OVERFLOWS FROM FLOUT. 1156 JLC 26-Sep-80 --------- NAMELIST WAS NOT INSISTING ON BEGINNING '$' BEING IN COLUMN 2 AFTER SKIPPING DATA. IT WAS ALSO EATING THE BEGINNING '$' OF A NAMELIST WHILE TRYING TO READ THROUGH GARBAGE RECORDS IF THE GARBAGE HAD A ENDING '$' FROM A PREVIOUS ABORTIVE NAMELIST READ 1163 JLC 23-Oct-80 --------- FIXED R-FORMAT INPUT 1172 JLC 2-Dec-80 Q20-01318 DPFLG WAS NOT GETTING CLEARED IN ALPHI/ALPHO. 1314 EDS 4-Mar-81 Q20-01392 Change NAMELIST input to ignore anything in column 1 of the data stream under a feature test switch FTNLC1. Change NAMELIST output to terminate with $END. 1347 DAW 16-Mar-81 Patch to allow FLIRT. to run in extended addressing, also changes to list-directed I/O routines. 1371 JLC 27-Mar-81 Make zero-trip I/O loops work for list-directed I/O 1440 DAW 17-Apr-81 Some extended addressing support. 1446 DAW 22-Apr-81 Rework NMLST code to not smash P4 in a lower-level routine; fixes bug caused by edit 1440. 1464 DAW 12-May-81 Error messages. 1470 CKS 22-May-81 Q20-1360 Fix overflow in FLOUT. Incrementing double integer didn't check for carry between words. 1514 JLC 8-Jun-81 Fix several bugs in NAMELIST code (subscript out of range), added code to accept rest of array if data specifies array reference, fixed column 1 skip feature test code. 1521 JLC 26-Jun-81 Change EOF processing so it doesn't use D%EOF to check. Instead check D%END and IRCNT(D).LE.0. 1522 JLC 01-Jul-81 Fix R format output to match R format input. For width greater than 5, bit 0 of low-order word is still 0, and excess characters are right justified in the high-order word. 1532 DAW 14-Jul-81 OPEN rewrite: Base level 1 1557 JLC 24-Jul-81 FLOUT uses double precision for everything. Therefore output the same number of digits maximum (20) if the program asks for them. 1560 DAW 28-Jul-81 OPEN rewrite: Base level 2 1606 DAW 13-Aug-81 Fix right-justified output of one-word items. 1625 DAW 21-Aug-81 Get rid of "DF". 1626 DAW 24-Aug-81 Change AC names in FLIRT and FLOUT so "D" is not defined there. 1644 JLC 27-Aug-81 Make free-format A stop on comma. Change R*C to be R*C, at least for version 6. Leave code to make it R*,C in repeat 0 in case the ANSI Committee makes a firm decision. 1662 DAW 4-Sep-81 %CALU; user error handling routine. 1710 JLC 14-Sep-81 Fixed problems with delimiter in namelist/ldio. 1733 BL 22-Sep-81 Problem finding beginning of NAMELIST. 1736 JLC 23-Sep-81 Fix to edit 1733. 1740 JLC 23-Sep-81 Added check for legal delimiter at end of scan for namelist and list-directed I/O. 1745 JLC 24-Sep-81 Fixed "r*,", was skipping over the comma. 2014 AHM/JLC 19-Oct-81 Number of dimensions in a NAMELIST is now bits 2-8 for extended addressing compatability. Fixed illegal (too big) subscript in NAMELIST to give error. 2016 JLC 20-Oct-81 Remove temporary one-trip in LDSET, now fixed in SLIST and ELIST. 2021 JLC 22-Oct-81 Change ALPHI to substitute 5 or 10 for field width of 0, required by ANSI standard. 2024 DAW 26-Oct-81 Make $ECALL ILC return to %ABORT - it's a fatal error now. 2032 JLC 29-Oct-81 Fix KI code for DPMUL. 2033 JLC 19-Nov-81 Pad R-format with spaces instead of nulls (like V5A). Make ILS error go to %ABORT if no ERR= branch. ***** End Revision History ***** \ PURGE $SEG$ PRGEND TITLE ALPHA ALPHANUMERIC INPUT/OUTPUT ROUTINES SUBTTL D. TODD/DRT/HPW/MD 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION ;FROM LIB40 %4(354) SEGMENT CODE ENTRY %ALPHI,%ALPHO,%RIGHI,%RIGHO EXTERN %IBYTE,%OBYTE,W.PNTR EXTERN IO.ADR,IO.TYP,%SAVE2 EXTERN %SIZTB DPFLG==20 %ALPHI: PUSHJ P,ALPSET ;DO SETUP MOVE T2,IO.ADR ;GET THE VARIABLE ADDR MOVE T0,[ASCII / /];GET A SET OF 5 BLANKS MOVEM T0,(T2) ;SET THE VARIABLE TO BLANK CLEAR BIT 35 TXNE F,DPFLG ;DOUBLE? MOVEM T0,1(T2) ;YES. CLEAR THE LOW ORDER WORD JUMPG T5,AL1 ;IF NO FIELD WIDTH MOVEI T5,(T4) ;USE THE DEFAULT AL1: SUBI T4,(T5) ;GET NEG FILL NEEDED JUMPGE T4,ALPHI1 ;NO FILL IF .GE. 0 ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT ALPHI0: PUSHJ P,%IBYTE ;EXCESS W SKIP INPUT CHARACTERS AOJL T4,ALPHI0 ;CONTINUE SKIPPING ALPHI1: PUSHJ P,%IBYTE ;GET AN INPUT BYTE IDPB T1,IXBP ;PUT IN USER'S VARIBLE SOJG T5,ALPHI1 ;CONTINUE UNTIL W=0 ALPHI2: POPJ P, ;RETURN TO FOROTS %ALPHO: PUSHJ P,ALPSET ;DO SOME SETUP JUMPG T5,AO1 ;WIDTH SPECIFIED MOVEI T5,(T4) ;NO-SET DEFAULT AO1: SUBI T4,(T5) ;GET NEG FILL NEEDED JUMPGE T4,ALPHO1 ;NO FILL IF .GE. 0 ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT MOVEI T1," " ;YES, GET A BLANK AOSLP: PUSHJ P,%OBYTE ;FILL OUTPUT FILL WITH BLANKS AOJL T4,AOSLP ;CONTINUE UNTIL MAX W IS REACHED ALPHO1: ILDB T1,IXBP ;GET THE CHARACTER FROM THE VARIABLE JUMPN T1,ALPHO2 ;JUMP IF NOT A NULL MOVEI T1," " ;NULL, GET A BLANK ALPHO2: PUSHJ P,%OBYTE ;OUTPUT THE CHARACTER SOJG T5,ALPHO1 ;CONTINUE UNTIL W=0 POPJ P, ;RETURN TO FOROTS ;ROUTINES TO RIGHT JUSTIFY ASCII STRING IN THE USER'S VARIABLE %RIGHI: PUSHJ P,ALPSET ;DO GENERAL SETUP MOVE T2,IO.ADR ;GET THE VARIABLE ADDR JUMPG T5,RI1 ;WIDTH SPECIFIED MOVEI T5,(T4) ;NO-SET DEFAULT RI1: SUBI T4,(T5) ;GET NEG FILL NEEDED JUMPGE T4,RIGHI1 ;NO SKIP IF .GE. 0 ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT RIGHI0: PUSHJ P,%IBYTE ;EXCESS W SKIP INPUT CHARACTERS AOJL T4,RIGHI0 ;CONTINUE SKIPPING RIGHI1: SETZB T3,T4 ;CLEAR THE RECEIVING WORD RIGHI2: LSHC T3,^D7 ;SHIFT A CHARACTER PUSHJ P,%IBYTE ;READ A CHARACTER IOR T4,T1 ;INSERT THE CHARACTER SOJG T5,RIGHI2 ;CONTINUE LSHC T3,1 ;CLEAR THE LOW ORDER SIGN BIT LSH T4,-1 ;AND POSITION MOVEM T4,(T2) ;STORE THE LOW ORDER WORD (SINGLE) TXNE F,DPFLG ;DOUBLE PRECISION? DMOVEM T3,(T2) ;STORE BOTH WORDS (DOUBLE) POPJ P, ;RETURN %RIGHO: PUSHJ P,ALPSET ;DO GENERAL SETUP SETZ T2, ;CLEAR HIGH ORDER WORD MOVE T3,@IO.ADR ;GET LOW WORD TXNE F,DPFLG ;BUT IF DOUBLE PRECISION DMOVE T2,@IO.ADR ;GET BOTH WORDS LSH T3,1 ;PUSH LOW WORD TO BIT 0 TXNE F,DPFLG ;If double-precision, LSHC T2,1 ;PUSH BOTH WORDS TO BIT 0 JUMPG T5,RO1 ;SPECIFIED MOVEI T5,(T4) ;NO-SET DEFAULT RO1: SUBI T4,(T5) ;GET NEG FILL NEEDED ;Note: T5= # chars to output ; T4= 0 if output (T5) chars ; T4= positive if first chars must be skipped ; T4= negative if not enough chars (pad with spaces) JUMPGE T4,INCPT ;IF NO FILL, TRY SKIP ADD T5,T4 ;SET DATA WIDTH TO DEFAULT MOVEI T1," " ;OUTPUT SPACES FOR SKIP WIDTH RIGHO1: PUSHJ P,%OBYTE ;OUTPUT THE SPACE AOJL T4,RIGHO1 ;LOOP FOR SKIP WIDTH INCPT: JUMPLE T4,ROLP1 ;IF NO SKIP, GO OUTPUT CHARS RIGHO2: LSHC T2,7 ;TOSS THE CHARACTER SOJG T4,RIGHO2 ROLP1: TXNN F,DPFLG ;If single precision, MOVE T2,T3 ;Get correct word to output ROLP2: ROTC T2,7 ;ROTATE CHAR INTO T3 MOVEI T1,(T3) ;COPY THE CHAR (WITH TRASH) ANDI T1,177 ;TOSS THE TRASH JUMPN T1,RONN ;IF NULL MOVEI T1," " ;USE A SPACE CHAR RONN: PUSHJ P,%OBYTE ;OUTPUT THE CHAR SOJG T5,ROLP2 POPJ P, ;RETURN TO FOROTS ;Routine to setup for alphabetic conversions ;Sets: ; T3/ index for indexed byte ptr. ; T4/ # fill chars needed ALPSET: MOVSI T3,(POINT 7,(T3)) ;Create normal indexed byte ptr MOVEM T3,IXBP MOVE T3,IO.ADR ;Get byte ptr. MOVEI T4,5 ;ASSUME SINGLE PRECISION MOVE T1,IO.TYP ;GET THE VARIABLE TYPE MOVE T1,%SIZTB(T1) ;GET ENTRY SIZE ASH T4,-1(T1) ;IF DP, MUL # CHARS BY 2 CAIN T1,2 ;DOUBLE? TXOA F,DPFLG ;YES. SET FLAG TXZ F,DPFLG ;NO. CLEAR IT LDB T5,W.PNTR ;GET THE WIDTH FIELD POPJ P, SEGMENT DATA IXBP: 0 PURGE $SEG$ PRGEND TITLE FLIRT FLOATING POINT INPUT SUBTTL DAVE NIXON AND TOM EGGERS SUBTTL D.M.NIXON /DMN/DRT/HPW/MD/CLRH/DCE/CYM 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION SEGMENT DATA FL.RFR: BLOCK 2 ;RAW FRACTION FL.RBX: 0 ;RAW BINARY EXPONENT SEGMENT CODE ENTRY %FLIRT,%GRIN,%ERIN,%DIRT ENTRY FL.RFR,FL.RBX EXTERN %IBYTE,W.PNTR,D.PNTR EXTERN IO.ADR,IO.TYP,IO.INF,%SAVE4,SCL.SV,ILLEG. EXTERN %HITEN,%LOTEN,%EXP10,%PTLEN EXTERN %SKIP,%SIZTB,%HIMAX IFN FTKL, EXTERN %ABORT ;IF THE FLAG ILLEG. HAS BEEN SET (BY A CALL TO ILL), THE ;INPUT WORD WILL BE SET TO 0 IF ANY ILLEGAL CHARACTERS ;ARE SCANNED FOR THAT WORD. ;THE SYNTAX ANALYSIS FOR THE SINGLE AND DOUBLE PRECISION INPUT ;IS STATE TABLE DRIVEN. EACH NEW INPUT CHARACTER IS CONVERTED TO ;A CHARACTER TYPE AND COMBINED WITH THE OLD "STATE". THIS RESULT ;IS THEN LOOKED UP IN THE TABLE "NXTSTA" TO GET THE NEW STATE AND ;AN INDEX INTO THE "XCTTAB" TABLE TO DISPATCH FOR THE INPUT ;CHARACTER. THE STATE TABLE LOGIC AND THE DISPATCH ROUTINES BUILD ;THREE RESULTS: A DOUBLE PRECISION INTEGER(IN B,C) FOR THE FRACTIONAL ;PART OF THE RESULT, AN INTEGER(IN XP) FOR THE EXPONENT AFTER ;"D" OR "E", AND A COUNTER(IN "X") TO KEEP TRACK OF THE DECIMAL POINT. ;WHEN A TERMINATING CHARACTER IS FOUND, THE DOUBLE PRECISION INTEGER ;IS NORMALIZED TO THE LEFT TO GIVE A DOUBLE PRECISION FRACTION. ;THE DECIMAL POINT POSITION(FROM "X")OR THE IMPLIED DECIMAL POINT ;POSITION FROM THE FORMAT STATEMENT, THE "D" OR "E" EXPONENT, AND ANY ;SCALING FROM THE FORMAT STATEMENT ARE COMBINED INTO A DECIMAL ;EXPONENT. THIS DECIMAL EXPONENT IS USED AS AN INDEX INTO A POWER ;OF TEN TABLE (KEPT IN DOUBLE PRECISION INTEGER PLUS EXPONENT FORM ;SO INTERMEDIATE RESULTS WILL HAVE 8 MORE BITS OF PRECISION THAN ;FINAL RESULTS) TO MULTIPLY THE DOUBLE PRECISION FRACTION. THIS ;RESULT IS THEN ROUNDED TO GIVE A SINGLE PRECISION, ;PDP6/KI10 DOUBLE PRECISION RESULT. ;OVERFLOWS RETURN THE LARGEST POSSIBLE ;NUMBER (WITH CORRECT SIGN), WHILE UNDERFLOWS RETURN 0. NO ERROR ;MESSAGE IS GIVEN FOR EITHER OVER OR UNDERFLOW. ;OLD ACCUMULATOR DEFINITIONS A==T0 B=A+1 ;RESULT RETURNED IN A OR A AND B C=B+1 ;B,C, AND D ARE USED AS A MULTIPLE PRECISION D1=C+1 ; REGISTER FOR DOUBLE PRECISION OPERATIONS E=D1+1 ;EXTRA AC XP=T5 ;EXPONENT AFTER D OR E BXP=P1 ;BINARY EXPONENT ST==P1 ;STATES ;ST+1 ;TEMPORARY, USES P2 WHICH CAN BE DESTROYED HERE ;P3 ;Used for really temp purposes only X==P4 ;COUNTS DIGITS AFTER POINT W==FREEAC ;FIELD WIDTH (** Uses FOROTS's free ac ** ) ;RIGHT HALF FLAGS IN AC "F" DOTFL==1 ;DOT SEEN MINFR==2 ;NEGATIVE FRACTION MINEXP==4 ;NEGATIVE EXPONENT EXPFL==10 ;EXPONENT SEEN IN DATA (MAY BE 0) DPFLG==20 ;VARIABLE IS DOUBLE PRECISION EEFLG==40 ;VARIABLE IS EXTENDED EXPONENT LOCFLG==DOTFL+MINFR+MINEXP+EXPFL+DPFLG+EEFLG ;INPUT CHARACTER TYPES CRTYP==1 ;CARRIAGE RETURN DOTTYP==2 ;DECIMAL POINT DIGTYP==3 ;DIGITS 0-9 SPCTYP==4 ;SPACE OR TAB EXPTYP==5 ;D OR E PLSTYP==6 ;PLUS SIGN (+) MINTYP==7 ;MINUS SIGN (-) ;ANYTHING ELSE IS TYPE 0 %DIRT: %ERIN: %GRIN: %FLIRT: ;INPUT PUSHJ P,%SAVE4 ;SAVE P1-P4 DSETZM FL.RFR ;CLEAR ALL RAW DATA AND EXPS SETZM FL.RBX TXZ F,LOCFLG ;CLEAR LOCAL FLAGS IN F MOVE T1,IO.TYP ;GET VARIABLE TYPE CAIN T1,TP%DPX ;EXTENDED EXPONENT? TXO F,EEFLG ;YES. SET FLAG MOVE T1,%SIZTB(T1) ;GET ENTRY SIZE CAIN T1,2 ;IS IT DOUBLE PRECISION? TXO F,DPFLG ;YES. SET FLAG SETZM IO.INF ;CLEAR INFORMATION WORD LDB W,W.PNTR ;GET THE FIELD WIDTH SETZB C,D1 ;INIT D.P. FRACTION SETZB ST,XP ;INIT STATE AND DECIMAL EXPONENT SETZ X, ;INIT "DIGITS AFTER POINT" COUNTER JUMPG W,GETCH1 ;FIELD SPECIFIED SETO W, ;SET FREE FORMAT FLAG PUSHJ P,%SKIP ;FREE FORMAT - SKIP SPACES JRST ENDF1 ;COMMA OR EOL = NULL FIELD JRST GETCH2 ;PROCESS FIELD GETNXT: GETCHR: JUMPE W,ENDF1 ;END OF FIELD LSH ST,-^D30 ;MOVE STATE TO BITS 30-32 GETCH1: PUSHJ P,%IBYTE ;GET NEXT CHARACTER GETCH2: CAIL T1,"0" ;CHECK FOR NUMBER CAILE T1,"9" JRST CHRTYP ;NO, TRY OTHER SUBI T1,"0" ;CONVERT TO NUMBER GOT1: IORI ST,DIGTYP ;SET TYPE GOTST: LSHC ST,-2 ;DIVIDE BY NUMBER OF BYTES IN WORD TLNE ST+1,(1B0) ;TEST WHICH HALF SKIPA ST,NXTSTA(ST) ;RIGHT HALF (BYTES 2 OR 3) HLRZ ST,NXTSTA(ST) ;UNFORTUNATELY BYTES 0 OR 1 TLNN ST+1,(1B1) ;WHICH QUADRANT LSH ST,-9 ;BYTES 0 OR 2 ANDI ST,777 ;LEAVE ONLY RIGHT MOST QUARTER ROT ST,-3 ;PUT DISPATCH ADDRESS IN BITS 32-35 ; AND NEW STATE IN BITS 0-2 LDB P3,[POINT 6,ST,35] ;Just get right-most bits XCT XCTTAB(P3) ;DISPATCH OR EXECUTE SOJA W,GETNXT ;RETURN FOR NEXT CHAR. XCTTAB: JRST ILLCH ; (00) ILLEGAL CHAR JRST BLNKIN ; (01) CR-LF IORI F,DOTFL ; (02) PERIOD JRST DIG ; (03) DIGIT BEFORE POINT JRST BLNKIN ; (04) BLANK OR TAB SOJA W,GETNXT ; (05) RETURN FOR NEXT CHAR. IORI F,MINFR ; (06) NEGATIVE FRACTION IORI F,MINEXP ; (07) NEGATIVE EXP SOJA X,DIGAFT ; (10) DIGIT AFTER POINT JRST DIGEXP ; (11) EXPONENT JRST DELCK ; (12) DELIMITER TO BACK UP OVER CHRTYP: CAIN T1,"+" ;CONVERT INPUT CHARS TO CHARACTER TYPE IORI ST,PLSTYP CAIN T1,"-" IORI ST,MINTYP CAIE T1," " ;SPACE CAIN T1," " ;TAB IORI ST,SPCTYP CAIE T1,"." ;DECIMAL POINT? JRST NOTDOT ;NO IORI ST,DOTTYP HRROS IO.INF ;SIGNAL DECIMAL POINT FOUND NOTDOT: CAIE T1,"D" CAIN T1,"E" JRST GOTEXP CAIE T1,"d" ;LOWER CASE D? CAIN T1,"e" ;LOWER CASE E? JRST GOTEXP ;YES JRST NOTEXP ;NO GOTEXP: IORI ST,EXPTYP ;SET STATUS FOR EXPONENT HRROS IO.INF ;SET INFO FOR EXPONENT FOUND NOTEXP: MOVE P3,FLAGS(D) TXNE P3,D%EOR ;End of line set TRC ST,SPCTYP!CRTYP ;56;SET UP A BLANK JRST GOTST ;GO DISPATCH ON OLD STATE AND CHAR TYPE DIGAFT: AOS IO.INF ;INCR # DIGITS AFTER DOT DIG: JUMPN C,DPDIG ;NEED D.P. YET? CAMLE D1,MAGIC ;NO, WILL MUL AND ADD CAUSE OVERFLOW? JRST DPDIG ;MAYBE, SO DO IT IN DOUBLE PRECISION IMULI D1,12 ;NO, MULTIPLY BY 10 SINGLE PRECISION ADD D1,T1 ;ADD DIGIT INTO NUMBER SOJA W,GETNXT ;GO GET NEXT CHARACTER DPDIG: CAMLE C,MAGIC ;WILL MULTIPLY AND ADD CAUSE OVERFLOW? AOJA X,DIGRET ;YES IMULI C,12 ;MULTIPLY HIGH D.P. FRACTION BY 10 MULI D1,12 ;MULTIPLY LOW D.P. FRACTION BY 10 ADD C,D1 ;ADD HI PART OF LO PRODUCT INTO RESULT MOVE D1,E ;GET LO PART OF LO PRODUCT TLO D1,(1B0) ;STOP OVERFLOW IF CARRY INTO HI WORD ADD D1,T1 ;ADD DIGIT INTO FRACTION TLZN D1,(1B0) ;SKIP IF NO CARRY INTO HI WORD ADDI C,1 ;PROPOGATE CARRY INTO HI WORD DIGRET: SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR MAGIC: <377777777777-9>/^D10 ;LARGEST NUM PRIOR TO MULTIPLY AND ADD DIGEXP: HRROS IO.INF ;SET INFO FOR EXPONENT FOUND IORI F,EXPFL ;SET FLAG TO SAY WE'VE SEEN EXPONENT IMULI XP,12 ;MULTIPLY BY TEN ADD XP,T1 ;ADD IN NEXT DIGIT SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR ; ? ,CR , . ,0-9, ,D E, + , - , NXTSTA: BYTE (9) 000,010,022,031,050,000,051,061, 000,011,022,031,041,053,054,074, 000,012,120,102,042,053,054,074, 000,013,120,114,043,000,054,074, 000,014,120,114,044,000,120,120 ;ERROR PROCESSING. IF A REAL ILLEGAL CHARACTER (E.G. ALPHA CHAR) IS ;FOUND DIRECTLY AFTER A NUMBER, IT IS ILLEGAL. IF THE "ILLEGAL FLAG" (ILLEG.) ;IS SET, WE JUST IGNORE THE REST OF THE INPUT AND SET THE RESULT ;TO 0. ILLCH: DELCK:: CAME W,[-1] ;FIRST ILLEGAL CHAR IN FREE FORMAT JUMPL W,ENDF ;NO - DELIMITER OF FREE FORMAT SKIPE ILLEG. ;ILLEGAL CHAR. FLAG SET? JRST ERROR1 ;YES. THROW AWAY REST AND RESULT=0 $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" POPJ P, ;RETURN TO FOROTS BLNKIN: SETZ T1, ;SET TO NULL CHAR JUMPL W,ENDF ;FREE FORMAT MOVE P3,FLAGS(D) TXNN P3,D%BZ ;BZ FORMAT ON? SOJA W,GETNXT ;NO. SKIP THE SPACE LSH ST,-^D30 ;YES. PUT STATE IN BITS 30-32 JRST GOT1 ;AND USE IT ERROR1: SOJLE W,ZERO ;HAVEN'T DECR WIDTH YET PUSHJ P,%IBYTE ;THROW AWAY CHAR JRST ERROR1 ;KEEP GOING UNTIL DONE ENDF: ENDF1: DMOVE A,C ;MOVE 2-WORD RESULT TO BOTTOM AC'S TXNE F,DOTFL ;HAS DECIMAL POINT BEEN INPUT? JRST ENDF2 ;YES LDB D1,D.PNTR ;NO, GET DIGITS AFTER POINT FROM FORMAT SUB X,D1 ; AND MODIFY DECIMAL EXPONENT ENDF2: HRRE D1,SCL.SV ;GET SCALE FACTOR TXNN F,EXPFL ;EXPONENT IN DATA? SUB X,D1 ;NO, ADD INTO EXPONENT TXNE F,MINEXP ;WAS D OR E EXPONENT NEGATIVE? MOVNS XP ;YES, SO NEGATE IT ADD X,XP ;ADD EXPONENT FROM D OR E NORM: MOVEI BXP,106 ;INIT BINARY EXPON FOR D.P. INTEGER JUMPN A,NORM1 ;XFER IF AT LEAST ONE 1 IN HIGH HALF EXCH A,B ;HIGH HALF ZERO, MOVE LOW HALF TO HIGH, ;AND CLEAR LOW HALF SUBI BXP,^D35 ;AND ADJUST EXPONENT FOR 35 SHIFTS NORM1: JUMPE A,ZERO ;LEAVE IF BOTH WORDS ZERO MOVE D1,A ;COPY 1ST WORD JFFO D1,NORM2 ;JUST IN CASE JRST ZERO ;EE CLEARS OUT EVERYTHING NORM2: ASHC A,-1(E) ;NORMALIZE D.P. INTEGER WITH BIN POINT ;BETWEEN BITS 0 AND 1 IN HIGH WORD SUBI BXP,-1(E) ;AND ADJUST EXPON TO ALLOW FOR SHIFTING JUMPE X,ENDF6 ;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED ENDF3: MOVM D1,X ;GET MAG OF DEC EXP CAILE D1,%HIMAX ;LESS THAN MAX TABLE ENTRY? JRST BADXP2 ;NO. MUCH TOO BIG! IFN FTKL, < PUSHJ P,EETST ;GO TEST FOR BIG SCALING> MOVM D1,X ;GET MAGNITUDE OF DECIMAL EXPONENT CAILE D1,%PTLEN ;BETWEEN 0 AND MAX. TABLE ENTRY? MOVEI D1,%PTLEN ;NO, MAKE IT SO SKIPGE X ;AND RESTORE CORRECT SIGN MOVNS D1 SUB X,D1 ;LEAVE ANY EXCESS EXPONENT IN X DPMUL: MUL B,%HITEN(D1) ;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C) MOVE E,B ;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY MOVE B,A ;COPY HI PART OF FRACTION MOVE C,%LOTEN(D1) ;GET LOW POWER OF TEN ADDI C,1 ;BIAS IT - IT IS TRUNCATED MUL B,C ;HI FRAC TIMES LO POWER OF TEN TLO E,(1B0) ADD E,B ;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T MUL A,%HITEN(D1) ;HI FRACTION TIMES HI POWER OF TEN TLON E,(1B0) ;DID CARRY OCCUR? ALLOW FOR NEXT CARRY ADDI A,1 ;CARRY FROM ADDING CROSS PRODUCTS ADD B,E ;ADD CROSS PRODUCTS TO LO PART ; OF (HI FRAC TIMES HI POW TEN) TLZN B,(1B0) AOJA A,ENDF5 ;AND PROPOGATE A CARRY, IF ANY ENDF5: TLNE A,(1B1) ;NORMALIZED? 1.0 > RESULT >= 0.25 JRST ENDF5A ;YES, RESULT >= 0.5 ASHC A,1 ;NO, SHIFT LEFT ONE PLACE SUBI BXP,1 ;AND ADJUST EXPONENT ENDF5A: MOVE D1,%EXP10(D1) ;GET BINARY EXPONENT ADD BXP,D1 ;ADJUST BINARY EXPONENT JUMPN X,ENDF3 ;CONTINUE IF ANY MORE DEC EXP LEFT ENDF6: DMOVEM A,FL.RFR ;SAVE THE RAW LEFT-JUSTIFIED FRACTION MOVEM BXP,FL.RBX ;AND THE RAW BINARY EXPONENT TLO A,(1B0) ;START ROUNDING (ALLOW FOR OVERFLOW) TXNE F,DPFLG ;DOUBLE PRECISION? JRST DPRND ;TO DPRND SPRND: ADDI A,200 ;NO, ROUND IN HIGH WORD TRZ A,377 ;GET RID OF USELESS (UNUSED) BITS MOVEI B,0 ; DITTO ENDF7: TLZE A,(1B0) ;CARRY PROPOGATE TO BIT 0? JRST ENDF7A ;NO ASHC A,-1 ;YES, RENORMALIZE TO RIGHT ADDI BXP,1 ;AND ADJUST BINARY EXPONENT TLO A,(1B1) ;AND TURN ON HI FRACTION BIT ENDF7A: TXNE F,EEFLG ;EXTENDED EXPONENT? JRST EERET ;YES. RETURN DIFFERENT FORMAT CAIGE BXP,200 ;OUT OF RANGE CAMGE BXP,[-200] JRST BADEXP ;YES. RETURN ZERO OR INFINITY ADDI BXP,200 ;ADD IN EXCESS 200 ASHC A,-8 ;NO, LEAVE ROOM FOR EXPONENT DPB BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD RETURN: TXNE F,MINFR ;RESULT NEGATIVE? DMOVN A,A ;YES. SO NEGATE RESULT MOVE T3,IO.ADR ;GET VARIABLE ADDR MOVEM A,(T3) ;STORE IN USER AREA TXNE F,DPFLG ;DOUBLE PRECISION? MOVEM B,1(T3) ;YES, STORE LOW ALSO POPJ P, ;RETURN TO USER EERET: CAIGE BXP,2000 ;OUT OF RANGE? CAMGE BXP,[-2000] JRST BADEXP ;YES. RETURN ZERO OR INFINITY ADDI BXP,2000 ;ADD IN EXCESS 2000 ASHC A,-^D11 ;SHIFT TO MAKE ROOM FOR EXP DPB BXP,[POINT 12,A,11];DEPOSIT THE EXPONENT JRST RETURN BADEXP: HRLOI A,377777 ;SET NUMBER TO LARGEST POSSIBLE HRLOI B,377777 ;FOR PDP-6 OR KI10 JUMPG BXP,RETURN ;DONE IF EXPONENT .GT. ZERO ZERO: SETZB A,B ;IF NEGATIVE, SET TO ZERO JRST RETURN BADXP2: JUMPL X,ZERO ;RETURN ZERO IF DEC EXP NEGATIVE MOVEI A,3777 ;GET VERY LARGE EXP MOVEM A,FL.RBX ;SAVE AS RAW BXP HRLOI A,377777 ;GET LARGEST FRACTION HRLOI B,377777 DMOVEM A,FL.RFR ;SAVE AS RAW FRACTION JRST RETURN IFN FTKL,< ;IF RUNNING ON A KL, WE CAN USE THE SPARSE POWER ;OF TEN TABLE TO SCALE THE NUMBER. IT IS ABSOLUTELY NECESSARY ;FOR EXTENDED EXPONENT NUMBERS EETST: MOVM P2,X ;GET MAGNITUDE OF DECIMAL EXPONENT CAIG P2,%PTLEN ;WITHIN NORMAL RANGE? POPJ P, ;YES. JUST DO IT NORMALLY ASHC A,-1 ;PREVENT DIVIDE CHECK ADDI BXP,1 ;AND MODIFY BINARY EXPONENT ASH P2,1 ;CALCULATE FACTOR OF TEN TO USE IDIVI P2,^D21 ;IN SPARSE TABLE SUBI P2,2 ;STARTS WITH 10**21 IMULI P2,3 ;AND EACH ENTRY IS 3 LOCS JUMPL X,EENEG ;GO DO DIVIDE IF EXP NEGATIVE PUSHJ P,%EEMUL ;OR MULTIPLY IF POSITIVE SUBI X,(XP) ;REDUCE THE DECIMAL EXP ADDI BXP,(P3) ;AND ADD THE BINARY EXP FOUND POPJ P, EENEG: PUSHJ P,%EEDIV ;DO D.P. DIVIDE ADDI X,(XP) ;REDUCE MAGNITUDE OF X SUBI BXP,(P3) ;MODIFY BINARY EXPONENT POPJ P, > ;HERE FOR DOUBLE PRECISION ROUNDING DPRND: TLO B,(1B0) ;START ROUNDING (ALLOW FOR CARRYS) TXNE F,EEFLG ;EXTENDED EXPONENT? ADDI B,2000 ;YES. DO SPECIAL ROUNDING TXNN F,EEFLG ;CHECK AGAIN ADDI B,200 ;LOW WORD ROUNDING FOR PDP-6 OR KI10 TLZN B,(1B0) ;DID CARRY PROPOGATE TO SIGN? AOJA A,ENDF7 ;YES, ADD CARRY INTO HIGH WORD JRST ENDF7 ;AND GO RENORMALIZE IF NECESSARY PURGE $SEG$ PRGEND TITLE FLOUT FLOATING POINT OUTPUT SUBTTL D. NIXON AND T. W. EGGERS SUBTTL D. TODD /DMN/DRT/HPW/MD/JNG/CLRH/CYM 28-Oct-81 SUBTTL JLC - VERSION 6 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION SEGMENT CODE AC0==T0 ;FLOATING POINT NO. ON ENTRY AC1==T1 ;USED IN FORMING DIGITS AC2==T2 ;DITTO. D.P. ONLY AC3==T3 ;EXTENDED EXPONENT ONLY AC4==T4 AC5==T5 ;T3 ; NO. OF DIGITS AFTER DEC. POINT C==T4 ;CNTR./NO. OF CHARS BEFORE DEC. POINT XP==T5 ;DECIMAL EXPONENT SF==P4 ;SCALE FACTOR DF==FREEAC ;FLOUT smashes FOROTS' free ac. NUMSGN==1 ;NEGATIVE NUMBER DIGEXH==2 ;DIGITS EXHAUSTED NOSIGN==4 ;NO SPACE FOR + SIGN EQZER==10 ;ITEM IS IDENTICALLY ZERO DPFLG==20 ;VARIABLE IS DOUBLE PRECISION EEFLG==40 ;VARIABLE IS EXTENDED EXPONENT DOUBLE PRECISION NOEFLG==100 ;DO NOT PRINT "D" OR "E" IN EXPONENT LOCFLG==NUMSGN+DIGEXH+NOSIGN+EQZER+DPFLG+EEFLG+NOEFLG SPMAX==^D20 DPMAX==^D20 ;MAXIMUM NUMBER OF DIGITS TO PRINT ;IF WE PRINT ANY MORE, WE WILL BE LYING TO THE ;USER, AS THIS IS THE MAXIMUM PRECISION OF ;OUR SCALING FACTORS OF 10. ;WE CANNOT KNOW WHETHER THE NUMBER WE ;HAVE IN THE MACHINE IS AN EXACT REPRESENTATION ;OF WHATEVER WAS INPUT - WE MUST ASSUME THAT ;WHAT IS IN THE MACHINE IS EXACTLY WHAT IS DESIRED. ;THEREFORE THERE IS NO REASON NOT TO GIVE AS MANY ;DIGITS AS ARE ACCURATE. THE ONLY LIMITATION ON ;THIS CURRENTLY IS THE SCALING ALGORITHM. LZALWAYS==0 ;SWITCH FOR ALWAYS PRINTING LEADING ZEROES LZSOME==1 ;SWITCH FOR SOMETIMES - ALWAYS EXCEPT WHEN ;POSITIVE NUMBER IS PRINTED WITH ONLY ONE LEADING ;SPACE ENTRY %FLOUT,%DOUBT,%GROUT,%EOUT IFN FTKL, EXTERN %OBYTE,%EXP10,%HITEN,%LOTEN,%PTLEN EXTERN W.PNTR,D.PNTR,X.PNTR EXTERN IO.ADR,IO.TYP,IO.INF,SCL.SV,%SAVE4 EXTERN %SIZTB,%BEXP,%DEXP EXTERN %FTSER ;INSTEAD OF HAVING MANY GLOBAL FLAGS PASSED TO FLOUT, THERE ARE ;SEVERAL ENTRY POINTS WHICH SET FLAGS LOCAL TO THE ROUTINE. %DOUBT: TXZ F,F%GTP+F%ETP ;NOT G OR E FORMAT TXO F,F%DTP ;FLAG TO PRINT A "D" JRST REALO %GROUT: TXZ F,F%DTP+F%ETP ;TRY WITHOUT SCIENTIFIC NOTATION TXO F,F%GTP JRST REALO %EOUT: TXZ F,F%GTP+F%DTP ;TURN OFF THE OTHER FLAGS TXO F,F%ETP ;FLAG TO PRINT AN "E" JRST REALO %FLOUT: TXZ F,F%GTP+F%ETP+F%DTP REALO: PUSHJ P,%SAVE4 ;SAVE P1-P4 MOVE DF,FLAGS(D) ;DDB flags kept in DF throughout FLOUT. TXZ F,LOCFLG ;CLEAR LOCAL FLAGS IN F MOVE AC1,IO.TYP ;GET VARIABLE TYPE MOVE AC2,%SIZTB(AC1) ;GET ENTRY SIZE CAIN AC2,2 ;IS VARIABLE DOUBLE PRECISION? TXO F,DPFLG ;YES. SET FLAG CAIN AC1,TP%DPX ;EXTENDED EXPONENT? TXO F,EEFLG ;YES. SET FLAG MOVE AC2,IO.ADR ;GET VARIABLE ADDR MOVE AC0,(AC2) ;LOAD AC 0 WITH NUMBER SETZ AC1, ;CLEAR LOW WORD TXNE F,DPFLG ;DOUBLE PRECISION? MOVE AC1,1(AC2) ;YES, GET LOW WORD ALSO TLZ AC1,(1B0) ;ELIMINATE GARBAGE SIGN BIT TXZ F,NUMSGN!DIGEXH!NOSIGN!EQZER SETZ XP, ;CLEAR EXPONENT JUMPGE AC0,FLOUT1 ;NUMBER NEGATIVE? DMOVN AC0,AC0 ;YES. NEGATE IT TXO F,NUMSGN ;AND - SET SIGN FLAG ;THE INTENTION IN THE CODE FOLLOWING IS TO LEFT-JUSTIFY THE MANTISSA ;AFTER EXTRACTING THE BINARY EXPONENT, AND THEN TO "SCALE" THE NUMBER ;BY ONE OR MORE POWERS OF TEN SO THAT IT ENDS UP WITH VALUE LESS ;THAN 1.0 BUT GREATER THAN OR EQUAL TO 0.1, KEEPING TRACK OF THE ;POWERS OF TEN USED IN THE SCALING PROCESS. THESE POWERS OF TEN ;ARE ACCUMULATED INTO A DECIMAL EXPONENT, KEPT IN XP. ; ;EXTENDED EXPONENT NUMBERS WHICH REQUIRE A HUGE POWER OF TEN TO SCALE ;THEM DOWN (OR UP) ARE FILTERED THROUGH A SPECIAL ROUTINE WHICH USES ;A SPARSE POWER OF TEN TABLE TO BRING THE NUMBER INTO THE "NORMAL" ;RANGE. FLOUT1: JUMPN AC0,FLONZ ;OK IF NON-ZERO JUMPE AC1,FLOUT6 ;ZERO IF BOTH ZERO FLONZ: IFN FTKL,< TXNN F,EEFLG ;EXTENDED EXPONENT? JRST FLOU1A ;NO PUSHJ P,EEDEC ;YES. HANDLE SEPARATELY JRST FLOUT2> FLOU1A: HLRZ P1,AC0 ;EXTRACT EXPONENT LSH P1,-9 HRREI P1,-200(P1) ;EXTEND SIGN TLZ AC0,777000 ;GET RID OF HIGH EXP FLOUT2: ADDI P1,^D8 ;EXPONENT IS 8 BIGGER ON NORM MOVE AC3,AC0 ;GET THE HI FRACTION JFFO AC3,FLOU2A ;GET HI BIT EXCH AC0,AC1 ;NONE. SWAP LO AND HI SUBI P1,^D35 ;AND DECR BINARY EXPONENT MOVE AC3,AC0 ;GET NEW HI WORD JFFO AC3,FLOU2A ;GET HI BIT JRST FLOUT6 ;NUMBER IS ZERO FLOU2A: ASHC AC0,-1(AC4) ;NORMALIZE NUMBER SUBI P1,-1(AC4) ;AND MODIFY BINARY EXPONENT FLOU2B: MOVE P2,P1 ;GET BINARY EXPONENT IMULI P2,232 ;DEC EXP=LOG10(2)*BIN EXP=.232(OCTAL)*BIN EXP ADDI P2,400 ;ROUND TO NEAREST INTEGER ASH P2,-^D9 ;GET RID OF 3 OCTAL FRACTION DIGITS ;P2 HOLDS A FIRST TRIAL DECIMAL EXPONENT. IT MAY BE ;ONE (BUT NO MORE) TOO SMALL TO DIVIDE THE BINARY NUM ;BY TO GET THE RANGE 1.0 .GT. NUM .GE. 0.1 MOVM P3,P2 ;GET MAGNITUDE OF *10 SCALER CAIGE P3,%PTLEN ;IS THE POWER OF 10 TABLE LARGE ENOUGH JRST FLOUT3 ;YES SKIPL P2 ;NO, SCALE 1ST BY LARGEST ENTRY SKIPA P2,[%PTLEN] ;GET ADR OF LARGEST POSITIVE POWER OF 10 MOVNI P2,%PTLEN ;GET ADR OF LARGEST NEG POWER OF 10 PUSHJ P,DPMUL ;SCALE BY LARGE POWER OF 10 JRST FLOU2B ;AND GO DO THE SECOND SCALING IFN FTKL,< ;EXTENDED EXPONENT NUMBERS HAVE 3 MORE BITS OF EXPONENT, ;SO WE MOVE THE MANTISSA OVER TO WHERE IT WOULD BE WERE IT ;A NORMAL FLOATING POINT NUMBER. IF THE EXPONENT IS WITHIN THE NORMAL ;FLOATING POINT RANGE, WE JUST DROP INTO THE STANDARD CODE. IF NOT, ;WE USE A SPARSE POWER OF TEN TABLE TO SCALE THE MANTISSA ;AND LOWER THE MAGNITUDE OF THE BINARY EXPONENT. THE TABLE IS ARRANGED ;SO THAT EACH POWER OF TEN WILL SCALE 2**35 MORE THAN THE NEXT, ;SO WE JUST DIVIDE THE BINARY EXPONENT BY 35 TO GET THE TABLE ENTRY ;TO USE. ;WE LEAVE THE MANTISSA ALIGNED WITH BIT 9 TO AVOID DIVIDE CHECKS. WE ;DON'T LOSE ANY PRECISION THEREBY BECAUSE FOR BOTH MULTIPLICATION ;AND DIVISION WE GET A 4-WORD RESULT. AFTER THE SCALING OPERATION, ;WE HAVE TO ALIGN THE MANTISSA ON BIT 1. THIS TIME, ;HOWEVER, IT MIGHT START ANYWHERE, SO WE CALL %EENRM. EEDEC: LDB P1,[POINT 12,AC0,11];GET THE EXPONENT TLZ AC0,777700 ;AND WIPE IT OUT IN MANTISSA ASHC AC0,3 ;MAKE IT LOOK NORMAL HRREI P1,-2000(P1) ;EXTEND SIGN OF EXPONENT MOVM P2,P1 ;GET MAGNITUDE OF EXP CAIGE P2,200 ;OUT OF RANGE? POPJ P, ;NO. USE REGULAR CODE SUBI P2,^D70 ;MODIFY FOR SPARSE 10'S TABLE IDIVI P2,^D35 ;DERIVE INDEX FOR EXPONENT IMULI P2,3 ;GET PROPER INDEX JUMPL P1,EENEG ;GO DO MUL IF NEGATIVE PUSHJ P,%EEDIV ;AND DIVIDE IF POSITIVE SUBI P1,(P3) ;REDUCE THE BINARY EXPONENT POPJ P, EENEG: PUSHJ P,%EEMUL ;DO D.P. MULT MOVNI XP,(XP) ;RECORD NEGATIVE DECIMAL EXPONENT ADDI P1,(P3) ;REDUCE MAGNITUDE OF BINARY EXP POPJ P, %EEDIV: SETZB AC2,AC3 ;CLEAR LOWER AC'S SETZB AC4,AC5 ;AND EVEN LOWER AC'S DDIV AC0,%BEXP(P2) ;GET 2-WORD RESULT DDIV AC2,%BEXP(P2) ;GET 4-WORD RESULT JRST EECOM ;JOIN COMMON CODE %EEMUL: DMOVE AC2,%BEXP(P2) ;GET POWER OF TEN ADDI AC3,1 ;BIAS IT - IT IS TRUNCATED DMUL AC0,AC2 ;GET 4-WORD RESULT EECOM: PUSHJ P,%EENRM ;NORMALIZE IT TLO AC0,(1B0) ;PREPARE FOR OVERFLOW TLNE AC2,(1B1) ;ROUNDING BIT ON? DADD AC0,[EXP 0,1] ;YES. ROUND UP TLZ AC1,(1B0) ;TURN OFF LOW SIGN TLZE AC0,(1B0) ;DID WE OVERFLOW? JRST EEOK ;NO TLO AC0,(1B1) ;YES. TURN HIGH BIT ON ADDI P1,1 ;AND INCR THE BINARY EXP EEOK: HLRZ P3,%DEXP(P2) ;GET THE BINARY EXPONENT HRRZ XP,%DEXP(P2) ;GET DECIMAL EXPONENT POPJ P, %EENRM: MOVE T4,AC0 ;GET THE HIGH WORD JFFO T4,EENZ ;LOOK FOR 1ST 1 DMOVE AC0,AC1 ;SHOVE THE NUMBER OVER SUBI P1,^D35 ;AND MODIFY THE EXPONENT MOVE T4,AC0 ;TRY NEXT WORD JFFO T4,EENZ JRST EENEND ;STILL NONE EENZ: SOJE T5,EENEND ;LEAVE STARTING AT BIT 1, DONE IF NO SHIFT SUB P1,T5 ;MODIFY THE BINARY EXPONENT MOVN T4,T5 ;AND GET NEG SHIFT ALSO JUMPL T5,RGTSFT ;DIFFERENT FOR RIGHT SHIFT ASHC AC0,(T5) ;MOVE 1ST AND 2ND WORDS ASH AC1,(T4) ;MOVE BACK 2ND WORD ASHC AC1,(T5) ;MOVE 2ND AND 3RD WORD EENEND: POPJ P, RGTSFT: ASHC AC1,(T5) ;MOVE 2ND AND 3RD ASH AC1,(T4) ;MOVE 2ND BACK ASHC AC0,(T5) ;MOVE 1ST AND 2ND POPJ P, >;END FTKL ;SCALE DOUBLE FRACTION BY A POWER OF 10 DPMUL: JUMPE P2,CPOPJ ;IF DEC EXP IS 0, RETURN ADD XP,P2 ;PUT DEC SCALE FACTOR INTO XP MOVN P2,P2 ;TAKE RECIPROCAL OF EXPONENT MOVE P3,%EXP10(P2) ;GET CORRESPONDING BIN EXP ADD P1,P3 ;ADD POWER EXP INTO FRAC EXP IFN FTKL,< MOVE AC2,%HITEN(P2) ;GET DOUBLE SCALING FACTOR MOVE AC3,%LOTEN(P2) ADDI AC3,1 ;BIAS IT - IT IS TRUNCATED DMUL AC0,AC2 ;GET DP PRODUCT TLO AC1,(1B0) ;PREPARE FOR CARRY TLNE AC2,(1B1) ;ROUNDING BIT ON? ADDI AC1,1 ;YES. ADD 1 TO LOW WORD >;END FTKL IFE FTKL,< MOVE AC3,AC1 ;COPY LOW WORD MOVE AC4,%LOTEN(P2) ;GET LOW WORD ADDI AC4,1 ;BIAS IT - IT IS TRUNCATED MUL AC3,AC4 ;GET LOW PRODUCT MUL AC1,%HITEN(P2) ;FORM FIRST CROSS PRODUCT ;LOW RESULT IN AC2 MOVE P3,AC0 ;COPY HI FRACTION MOVE P4,%LOTEN(P2) ;GET LOW WORD ADDI P4,1 ;BIAS IT - IT IS TRUNCATED MUL P3,P4 ;FORM 2ND CROSS PRODUCT ;LOW RESULT IN P4 TLO P3,(1B0) ;AVOID OVERFLOW ADD P3,AC1 ;ADD CROSS PRODUCTS MUL AC0,%HITEN(P2) ;FORM HI PRODUCT TLON P3,(1B0) ;DID CROSS PRODUCT OVERFLOW ADDI AC0,1 ;YES ADD AC1,P3 ;ADD CROSS PRODUCTS IN TLON AC1,(1B0) ;OVERFLOW? ADDI AC0,1 ;YES SETZ AC4, ;CLEAR A CARRY REGISTER TLO AC3,(1B0) ;PREVENT OVERFLOW IN LOW RESULT ADD AC3,AC2 ;ADD 1ST LOW RESULT TLON AC3,(1B0) ;OVERFLOW? ADDI AC4,1 ;YES. CARRY ONE ADD AC3,P4 ;ADD 2ND LOW RESULT TLNN AC3,(1B0) ;OVERFLOW? ADDI AC4,1 ;YES. CARRY ONE AGAIN TLNE AC3,(1B1) ;NOW IS THE HIGH POSITIVE BIT SET? ADDI AC4,1 ;YES. ROUND UP ADDI AC1,(AC4) ;ADD IN LOW CARRIES >;END IFE FTKL TLZN AC1,(1B0) ;OVERFLOW ADDI AC0,1 ;YES TLNE AC0,(1B1) ;NORMALIZED? POPJ P, ;YES ASHC AC0,1 ;NO, SHIFT LEFT ONE SUBI P1,1 ;AND ADJUST EXPONENT CPOPJ: POPJ P, ;RETURN FLOUT3: MOVE P3,%EXP10(P2) ;GET BIN EXP THAT MATCHES DEC EXP CAMLE P3,P1 ;FRACTION .GT. POWER OF 10? JRST FLOT4A ;YES CAME P3,P1 AOJA P2,FLOT4A ;NOT IN EXPONENT CAMGE AC0,%HITEN(P2) ; JRST FLOT4A ;YES, IN HIGH FRACTION CAMN AC0,%HITEN(P2) CAML AC1,%LOTEN(P2) ADDI P2,1 ;NO, IN FRACTION PART FLOT4A: PUSHJ P,DPMUL ;SCALE BY POWER OF 10 ASHC AC0,(P1) ;SCALE BY ANY REMAINING POWERS OF 2 TLO T1,(1B0) ;PREVENT OVERFLOW ADDI T1,1 ;ROUND IT UP SOME MORE TLZN T1,(1B0) ;CARRY INTO SIGN? ADDI T0,1 ;YES, PROPAGATE TO HIGH WORD FLOUT6: LDB C,W.PNTR LDB T3,D.PNTR HRRE SF,SCL.SV ;GET THE SCALING FACTOR JUMPN AC0,FLOU6A ;IS NUMBER ZERO? TXO F,EQZER ;YES. SET FLAG TXZ F,NUMSGN ;AND CLEAR ANY SIGN! SETZ XP, ;AND THE EXPONENT! FLOU6A: JUMPN C,FLOUT7 TXNE F,DPFLG ;DOUBLE PRECISION? ADDI C,1 ;YES, INCREMENT INDEX INTO TABLE HRRZ T3,FRMTAB(C) ;PICKUP DEFAULT FORMAT FOR T3 HLRZ C,FRMTAB(C) ;SAME FOR WIDTH ;HERE IS THE FIRST G-FORMAT NUMBER FILTER. THE NUMBER IS CHECKED ;IF IT IS "PROPER MAGNITUDE" FOR G-FORMAT. IF THE MAGNITUDE OF THE ;NUMBER IS SMALLER THAN 10**D OR GREATER THAN OR EQUAL TO 0.1, ;THE NUMBER SHOULD BE PRINTED IN F-FORMAT. SINCE THE NUMBER HAS NOT ;BEEN ROUNDED YET, WE CHECK THE NUMBER JUST USING THE DECIMAL EXPONENT XP, ;AND ALLOW NUMBERS WITH XP GREATER THAN -1 (WHICH COULD INCLUDE ;NUMBERS LESS THAN 0.1). A SECOND CHECK IS DONE AT CHKRND, AFTER ;THE NUMBER HAS BEEN ENCODED, TO SEE IF ROUNDING FORCED THE NUMBER ;INTO OR OUT OF THE F-FORMAT RANGE. FLOUT7: TXNN F,F%GTP ;G TYPE CONVERSION? JRST FLOUT8 ;NO CAML XP,[-1] ;IF EXPONENT .LT. 1 CAMLE XP,T3 ;OR .GT. # DECIMAL PLACES TXOA F,F%ETP ;SET E CONVERSION JRST FLOUT8 ;NOT E, JUMP TXNE DF,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED? SUBI T3,1 ;YES, ACCOUNT FOR DIGIT BEFORE DEC PT ;HERE WE FIGURE OUT HOW MANY SIGNIFICANT DIGITS TO GET FROM THE ;NUMBER. FOR G-FORMAT, THIS IS JUST "D" (AS IN W.D). FOR D AND ;E-FORMATS, IT DEPENDS ON THE SCALE FACTOR. FOR SCALE FACTORS ;LESS THAN ZERO, THE NUMBER OF DIGITS IS REDUCED BY THE SCALE ;FACTOR. FOR POSITIVE SCALE FACTORS, THE NUMBER OF DIGITS IS ;INCREASED BY ONE, UNLESS THE SCALE FACTOR IS MORE ;THAN ONE LARGER THAN THE NUMBER OF DECIMAL PLACES, IN WHICH ;CASE THE NUMBER OF DIGITS IS SET TO THE SCALE FACTOR ALONE. ;FOR F-FORMAT, THE SIZE OF THE NUMBER (DECIMAL EXPONENT) IS ;ADDED TO THE NUMBER OF DIGITS IN ADDITION TO THE SCALE ;FACTOR. FLOUT8: MOVE P2,T3 ;GET # DECIMAL PLACES TXNN F,F%ETP!F%DTP ;D OR E FORMAT? JRST FLOU8A ;NO JUMPLE SF,FLOUT9 ;IF NEG, JUST GO ADD SCLFCT CAILE SF,1(T3) ;WITHIN DEFINED RANGE? MOVEI P2,-1(SF) ;NO. SET TO SCLFCT ADDI P2,1 ;YES. JUST ADD 1 JRST FLOU10 FLOU8A: TXNE F,F%GTP ;G-FORMAT? JRST FLOU10 ;YES. WE'RE ALL DONE ADD P2,XP ;NO. ADD MAGNITUDE OF NUMBER FLOUT9: ADD P2,SF ;ADD SCLFCT TO # DIGITS DESIRED FLOU10: JUMPN AC0,FLO10A ;IF NUMBER IS ZERO SETZ P2, ;DON'T ENCODE ANY DIGITS FLO10A: CAILE P2,DPMAX ;TOO MANY DECIMAL PLACES MOVEI P2,DPMAX ;YES, REDUCE TO MAX POSSIBLE TXNE F,DPFLG ;DOUBLE PRECISION? JRST DIGOK ;YES CAILE P2,SPMAX ;NO. RESTRICT TO SPMAX MOVEI P2,SPMAX DIGOK: MOVE P1,P ;MARK BOTTOM OF DIGIT STACK PUSH P,[0] ;AND ALLOW FOR POSSIBLE OVERFLOW SETZM IO.INF ;CLEAR 9'S COUNTER MOVE P3,P2 ;GET # OF DIGITS JUMPLE P2,CHKRND ;NO DIGITS WANTED. FLOU12: EXCH AC0,AC1 ;PUT HI WORD IN AC1 MULI AC1,^D10 ;MUL HI WORD BY 10 PUSH P,AC1 ;STORE DIGIT ON STACK MULI AC0,^D10 ;MUL LOW WORD BY 10 TLO AC0,(1B0) ;STOP OVERFLOW ADD AC0,AC2 ;ADD HI WORD BACK INTO AC0 TLZN AC0,(1B0) ;CARRY AOS (P) ;YES, INCREMENT DIGIT ON STACK MOVE AC2,(P) ;GET THE DIGIT CAIN AC2,^D9 ;IS IT A 9? AOSA IO.INF ;YES. INCR 9'S COUNT SETZM IO.INF ;NO. CLEAR 9'S COUNT SOJG P3,FLOU12 ;FOR G-FORMAT OUTPUT, THERE IS THE POSSIBILITY THAT ROUNDING THE ;NUMBER WILL MAKE IT TOO LARGE TO PRINT IN F-FORMAT, OR THAT NUMBERS ;THAT WE LET THROUGH AT FLOUT7 WILL NOT BE ROUNDED UP, AND WILL BE ;TOO SMALL TO PRINT IN F-FORMAT. THE FOLLOWING CODE CHECKS FOR ;THESE CONDITIONS, AND SETS THE E-FORMAT FLAG IF THE NUMBER IS TOO ;LARGE OR TOO SMALL. IF THERE IS A SCALE FACTOR INVOLVED, IT MODIFIES ;THE NUMBER OF DIGITS ENCODED - NEGATIVE SCALE FACTORS REDUCE THE ;NUMBER OF DIGITS ENCODED, WHILE POSITIVE SCALE FACTORS INCREASE THE ;NUMBER OF DIGITS ENCODED BY 1 DIGIT (OR IF THE SCALE FACTOR ;IS OUTSIDE THE DEFINED RANGE, MODIFIES THE NUMBER OF DIGITS ENCODED ;TO THE SCALE FACTOR). CHKRND: TXNE F,F%GTP ;G-FORMAT? TXNE F,F%ETP+F%DTP ;YES. D OR E? JRST CHKRN2 ;D OR E OR NOT G. LEAVE TLNE AC0,(1B1) ;ROUNDING BIT ON? JRST TEST9 ;YES. TEST # 9'S JUMPL XP,FGFIX ;NO. NG IF EXP STILL LOW JRST FLOU13 ;OTHERWISE OK TEST9: CAMN P2,IO.INF ;IS 9'S COUNT SAME AS DIGITS? JRST TESTXP ;YES. WE GOT OVERFLOW JUMPL XP,FGFIX ;NO. NG IF EXPONENT STILL LOW JRST DORND ;OTHERWISE WE'RE OK TESTXP: CAMGE XP,T3 ;IS UNINCREMENTED EXP TOO BIG? JRST DORND ;NO. WE'RE OK FGFIX: TXO F,F%ETP ;SET TO TYPE "E" JUMPE SF,CHKRN2 ;NO # DIGITS CHANGE IF SF=0 JUMPG SF,FGPOS ;NEED MORE IF SF.GT.0 MOVM AC2,SF ;GET MAGNITUDE OF SCLFCT CAMLE AC2,P2 ;.LE. # OF DIGITS? JRST FLOU13 ;NO. WE'RE ROUNDING ON ZEROES ADD P,SF ;NEED LESS IF SF.LT.0 ADD P2,SF ;ADJUST # DIGITS ADDM SF,IO.INF ;AND 9'S COUNTER SKIPGE IO.INF ;IF 9'S COUNT IS NOW .LT. 0 JRST FLOU13 ;WE HAVE NO ROUNDING JRST DORND ;NOW ROUND WITH FEWER DIGITS FGPOS: TXNE DF,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED? JRST NOEXDG ;YES. NO EXTRA DIGITS NEEDED MOVEI P3,(SF) ;ENCODE MORE DIGITS SUBI P3,(P2) ;EITHER 1 OR (SF-P2) CAIG SF,1(T3) ;WITHIN DEFINED RANGE? MOVEI P3,1 ;YES. JUST ADD 1 ADDI P2,(P3) ;INCREASE RECORDED # DIGITS JRST FLOU12 ;GO ENCODE NOEXDG: SUBI T3,1 ;REMOVE A DIGIT FOR NMLST/LDIO CHKRN2: TLNN AC0,(1B1) ;ROUNDING BIT ON? JRST FLOU13 ;NO DORND: MOVEI AC2,(P) ;GET STACK POINTER MOVE AC1,IO.INF ;GET 9'S COUNT JUMPLE AC1,FLO12B ;INCR LAST DIG IF NO 9'S ZERLP: SETZM (AC2) ;MAKE DIGIT ZERO SUBI AC2,1 ;DECR POINTER SOJG AC1,ZERLP ;DO FOR ALL CONSECUTIVE 9'S FLO12B: AOS (AC2) ;INCR NEXT DIGIT FLOU13: MOVEI P3,2(P1) ;GET BASE OF STACKED DIGITS SKIPN 1(P1) ;DID OVERFLOW OCCUR? JRST FLOU14 ;NO SUBI P3,1 ;YES - MOVE BACK BASE POINTER ADDI XP,1 ;INCREMENT EXPONENT ADDI P2,1 ;ADD 1 TO # DIGITS FLOU14: JUMPG P2,FLO14A ;ANY DIGITS? TXZ F,NUMSGN ;NO. CLEAR ANY SIGN FLO14A: TXNE F,F%GTP ;YET ANOTHER G-FORMAT TEST TXNE F,F%ETP+F%DTP JRST FLOU15 ;E OR D OR NOT G SETZ SF, ;SCLFCT IS USELESS NOW FOR G-FORMAT FLOU15: SUBI C,2(T3) ;SIGN, POINT AND CHARS. FOLLOWING TXNE F,F%ETP!F%DTP JRST FLOU16 ;HERE FOR F TYPE CONVERSION TXNE F,EQZER ;IS NUMBER ZERO? SETZ SF, ;YES. SET SCALE FACTOR TO 0 ADD SF,XP ;COUNT THE LEADING DIGITS TXNE F,F%GTP JRST [SUBI T3,(XP) ;NO, REDUCE CHAR. AFTER POINT FOR F JRST CHEKDE] ;BUT IGNORE SCALE FACTOR IN WIDTH JUMPLE SF,TRYFIT ;IGNORE NEG SCALING SUBI C,(SF) ;+SCALING JRST TRYFIT ;HERE FOR E AND D TYPE CONVERSION FLOU16: JUMPLE SF,CHEKDE ;IF FACTOR .LE. 0, GO CHECK EXP SUBI C,1 ;EXTRA DIGIT PRINTED SUBI T3,-1(SF) ;REDUCE DIGITS AFTER POINT JUMPGE T3,CHEKDE ;TO COMPENSATE FOR THOSE IN FRONT ADD C,T3 ;HOWEVER IF NOT ENOUGH LEFT ;TAKE FROM IN FRONT CHEKDE: LDB AC2,X.PNTR ;GET EXPONENT WIDTH JUMPN AC2,GOTEXW ;MIGHT BE DEFAULT MOVEI AC2,2 ;WHICH IS 2 GOTEXW: MOVEM AC2,IO.INF ;SAVE FOR LATER TXNE F,F%DTP+F%ETP ;D OR E FORMAT? CAIL AC2,3 ;YES. ROOM FOR LARGEST EXPONENT? JRST EXPOK ;SURE MOVE AC1,XP ;GET EXPONENT SUB AC1,SF ;REDUCE BY SCALE FACTOR MOVM AC1,AC1 ;GET MAGNITUDE CAML AC1,EXPTAB(AC2) ;WILL EXPONENT FIT? TXO F,NOEFLG ;MAYBE JUST BARELY WITH NO "D" OR "E" CAML AC1,EXPTAB+1(AC2);WILL IT FIT AT ALL? JRST NOFIT ;NO EXPOK: SUB C,IO.INF ;REDUCE SPACE FOR NUMBER SUBI C,2 ;ALLOW FOR E+ OR + AND 1ST DIGIT OF EXP TRYFIT: JUMPG C,FIT1 ;WILL IT FIT? JUMPL C,TRYF0 ;NO. SERIOUS IF .LT. 0 JUMPG SF,GO2ERF ;C=0, OK IF DIGITS BEFORE POINT IFN LZALWAYS,< TXNN F,NUMSGN ;IS SIGN POSITIVE? AOJA C,POSIGN ;YES. ELIMINATE IT FOR LEADING ZERO> JUMPG T3,GO2ERF ;NO. BUT WE'RE OK IF DIGITS AFTER POINT TRYF0: TXNE F,NUMSGN ;NO. IS SIGN POSITIVE JRST TRYF2 ;NO. JUMPG T3,TRYF1 ;YES. ANY DIGITS AFTER POINT? JUMPG SF,TRYF1 ;NO. ANY DIGITS BEFORE POINT? JUMPL C,TRYF2 ;NO. MUST BE ROOM FOR LEADING 0 TRYF1: CAML C,[-1] ;YES. WOULD THERE BE ROOM WITHOUT SIGN? AOJA C,POSIGN ;YES. PRINT WITHOUT SIGN TRYF2: TXNN F,F%ETP!F%DTP ;NO. IF E FORMAT WE LOSE TXZN F,F%GTP ;WAS IT G TO F CONVERSION? JRST NOFIT ;E TYPE OR NOT G TO F ADDI C,2 ;REMOVE THE "E+" TRAILING SPACES ADD C,IO.INF ;ADD THE EXPONENT WIDTH BACK JRST TRYFIT ;AND TRY AGAIN NOFIT: LDB AC2,W.PNTR ;GET THE WIDTH JUMPE AC2,FIT ;ALWAYS FITS IF FREE FORMAT IFN FTAST,< MOVE P,P1 ;RESTORE STACK POINTER MOVEI T1,"*" ;OUTPUT ASTERISKS PUSHJ P,%OBYTE SOJG AC2,.-1 PJRST %FTSER ;%Field width too small > IFE FTAST,< ADD SF,C ;LESS DIGITS TO OUTPUT ADD P2,C ;AND LESS IN STACK > FIT: JUMPLE C,GO2ERF ;NO LEADING BLANKS FIT1: JUMPG SF,FIT2 ;NO 2ND CHECK IF DIGITS BEFORE POINT CAIG C,1 ;MUST LEAVE ROOM FOR LEADING 0 JRST GO2ERF FIT2: PUSHJ P,SPACE ;OUTPUT SPACE SOJA C,FIT ;UNTIL ENOUGH POSIGN: TXO F,NOSIGN ;SIGNAL ROOM FOR LEADING ZERO ; AND NO ROOM FOR + SIGN GO2ERF: TXNN F,F%ETP!F%DTP ;TEST FLOATING POINT FLAGS JRST FFORM ;NO, USE FIXED POINT ;FALL INTO EFORM ;E FORMAT EFORM: SUB XP,SF ;SCALE EXPONENT JUMPG P2,EFORMA ;ANY SIGNIFICANT DIGITS? SETZ XP, ;NO. CLEAR THE EXPONENT EFORMA: JUMPLE SF,EFORM1 ;JUMP IF NOT POSITIVE SCALING PUSHJ P,SIGN ;OUTPUT SIGN EFORMB: PUSHJ P,DIGIT ;OUTPUT LEADING DIGITS SOJG SF,EFORMB ;RETURN FOR MORE PUSHJ P,PERIOD ;OUTPUT DOT JUMPLE T3,EFORM4 ;NO MORE IF NO DEC EFORMC: PUSHJ P,DIGIT ;OUTPUT ANOTHER DIGIT SOJG T3,EFORMC ;UNTIL DECS USED UP JRST EFORM4 ;GO OUTPUT EXPONENT EFORM1: PUSHJ P,SIGN ;OUTPUT SIGN IFN LZALWAYS!LZSOME,< JUMPLE C,EFORM2 ;IF ROOM, OUTPUT LEADING 0> IFE LZALWAYS!LZSOME,< JUMPG T3,EFORM2 ;OR IF NO TRAILING DIGITS> PUSHJ P,ZERO ;OUTPUT ZERO EFORM2: PUSHJ P,PERIOD ;AND DECIMAL POINT JUMPLE T3,EFORM4 ;GO TO EXPONENT IF NO DIGITS JUMPE SF,EFORM3 ;ACCOUNT FOR ZERO SCALING MOVM SF,SF ;GET MAGNITUDE CAIGE SF,(T3) ;SCLFCT .GE. # DECS? JRST EFRM2A ;NO. THINGS ARE OK CAIE SF,(T3) ;EQUAL? MOVEI SF,1(T3) ;GREATER. SET SF=D SUBI SF,1 ;EQUAL. SET SF=D-1 EFRM2A: SUBI T3,(SF) ;REDUCE # SIGNIFICANT DIGITS EFRM2B: PUSHJ P,ZERO ;OUTPUT LEADING ZEROES SOJG SF,EFRM2B EFORM3: JUMPLE T3,EFORM4 ;LEAVE IF NO DIGITS AFTER POINT EFRM3A: PUSHJ P,DIGIT ;OUTPUT FRACTIONAL DIGIT SOJG T3,EFRM3A ;RETURN IF MORE DIGITS EFORM4: MOVEI AC1,"E" TXNE F,F%DTP ;USER SPECIFY D-FORMAT? MOVEI AC1,"D" ;YES, GIVE D INSTEAD TXNN F,NOEFLG ;DON'T PRINT IF NO ROOM PUSHJ P,%OBYTE ;OUTPUT "E" OR "D" JUMPGE XP,EFORM5 TXO F,NUMSGN ;TYPE MINUS IF EXPONENT NEGATIVE EFORM5: PUSHJ P,PLUS ;PRINT SIGN MOVE C,IO.INF ;AND SET DIGIT COUNT TXNE F,NOEFLG ;DID WE PRINT "D" OR "E"? ADDI C,1 ;NO. MORE ROOM FOR EXPONENT MOVE P,P1 ;RESTORE STACK POINTER MOVM AC0,XP ;GET EXPONENT JRST OUTP1 ;AND LET OUTP1 DO THE WORK ;F FORMAT FFORM: JUMPLE SF,FFORM3 ;NO LEADING DIGITS PUSHJ P,SIGN ;OUTPUT SIGN FFORMA: PUSHJ P,DIGIT ;OUTPUT INTEGRAL DIGIT SOJG SF,FFORMA ;RETURN IF MORE DIGITS PUSHJ P,PERIOD ;PRINT DECIMAL POINT FFORM1: JUMPE T3,FFORM2 ;TEST FOR DIG AFTER POINT PUSHJ P,DIGIT ;OUTPUT FRACTIONAL DIGIT SOJG T3,FFORM1 ;RETURN IF MORE DIGITS FFORM2: MOVE P,P1 ;RESTORE STACK TXNN F,F%GTP ;G FORMAT REQUIRES 4 BLANKS JRST RETRNO ;FINISHED LDB C,X.PNTR ;GET EXPONENT WIDTH CAIN C,0 ;IF SET MOVEI C,2 ;IF NOT, DEFAULT IS 4 (2+2) ADDI C,2 ;PLUS 2 FOR E+ OR E- FFRM2A: PUSHJ P,SPACE ;BLANKS SOJG C,FFRM2A JRST RETRNO ;FINISHED FFORM3: PUSHJ P,SIGN ;OUTPUT SIGN IFN LZALWAYS!LZSOME,< JUMPLE C,NOLZ ;AND IF WE CAN,> IFE LZALWAYS!LZSOME,< JUMPG T3,NOLZ ;OR IF NO TRAILING DIGITS> PUSHJ P,ZERO ;OUTPUT LEADING "0" NOLZ: PUSHJ P,PERIOD ;OUTPUT DEC. POINT ADD T3,SF ;REDUCE DEC BY SCLFCT JUMPGE T3,FFRM3C ;FINISH IF OK SUB T3,SF ;RESTORE D MOVN SF,T3 ;USE FOR SCLFCT SETZ T3, ;AND NO DIGITS FFRM3C: JUMPGE SF,FFORM1 ;NOW FOR DIGITS PUSHJ P,ZERO ;ZERO AFTER POINT AOJA SF,FFRM3C ;LOOP ON ZEROS ; OUTPUT ROUTINES PERIOD: MOVEI AC1,"." ;DECIMAL POINT PJRST %OBYTE ;PRINT AND RETURN SPACE: TXNE DF,D%LSD+D%NML ;LIST-DIRECTED OR NMLST? POPJ P, ;YES. LEAVE MOVEI AC1," " ;SPACE PJRST %OBYTE ZERO: MOVEI AC1,"0" JRST %OBYTE PLUS: MOVEI AC1,"+" JRST SIGN1 SIGN: TXZE F,NOSIGN ;NO ROOM FOR SIGN? POPJ P, ;JUST RETURN MOVEI AC1," " TXNE DF,D%SP ;FORCE PLUS SIGN? MOVEI AC1,"+" ;YES SIGN1: TXZE F,NUMSGN ;ALWAYS CLEAR FLAG MOVEI AC1,"-" ;SELECT SIGN CAIN AC1," " ;IS IT A SPACE? TXNN DF,D%LSD+D%NML ;YES. LIST-DIRECTED OR NMLST? PJRST %OBYTE ;NO. PRINT POPJ P, DIGIT: JUMPLE P2,ZERO ;OUTPUT ZERO IF NO DIGITS SUBI P2,1 ;DECR # DIGITS LEFT MOVE AC1,(P3) ;GET NEXT DIGIT ADDI AC1,"0" ;CONVERT TO ASCII AOJA P3,%OBYTE ;AND PRINT OUTP1: MOVEI XP,1 ;SET UP DIGIT COUNT OUTP2: IDIVI AC0,^D10 ;AND GENERATE DIGITS IN REVERSE PUSH P,AC1 ;AND SAVE THEM ON THE STACK JUMPE AC0,OUTP3 ;ANY LEFT? AOJA XP,OUTP2 ;YES - COUNT AND CARRY ON OUTP3: CAML XP,C ;ANY LEADING SPACES? JRST OUTP4 ;NO PUSHJ P,ZERO ;YES - PRINT ONE SOJA C,OUTP3 ;AND DECREASE UNTIL FINISHED OUTP4: POP P,AC1 ;POP UP DIGIT ADDI AC1,"0" ;ADD ASCII OFFSET PUSHJ P,%OBYTE ;AND PRINT IT SOJN XP,OUTP4 ;REPEAT UNTIL FINISHED RETRNO: POPJ P, ; EXIT FROM ROUTINE FRMTAB: ^D15,,7 ;15.7 DEFAULT ^D25,,^D17 ;25.17 DEFAULT EXPTAB: 1 ;10**0 ^D10 ;10**1 ^D100 ;10**2 ^D1000 ;10**3 PURGE $SEG$ PRGEND TITLE INTEG DECIMAL INTEGER INPUT/OUTPUT SUBTTL D. TODD/DRT/HPW/MD 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION ;FROM LIB40 %4(367) SEGMENT CODE ENTRY %INTI,%INTO,%GINTI,%GINTO EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR EXTERN IO.ADR,%SAVE1 EXTERN %SKIP EXTERN %FTSER EXTERN %ABORT DGSEEN==400000,,0 ;MUST BE 400000, CHECKED WITH JUMPL SGNFLG==200000,,0 ;MINUS SIGN SEEN OVRFLG==100000,,0 ;INTEGER OVERFLOW %GINTI: %INTI: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,INTSET ;DO SETUP JUMPG T3,INTI1 ;FIELD WIDTH SPECIFIED SETO T3, ;SET VARIABLE FIELD FLAG PUSHJ P,%SKIP ;SKIP SPACES JRST INTI6 ;COMMA OR EOL (NULL FIELD) JRST INTI1B ;PROCESS FIELD INTI1: JUMPE T3,INTI6 ;FIELD EXHAUSTED PUSHJ P,%IBYTE ;NO, GET NEXT INPUT CHARACTER INTI1B: CAIG T1,"9" ;CHECK FOR A CAIGE T1,"0" ;DECIMAL DIGIT (0-9) JRST INTI3 ;NOT A DECIMAL DIGIT TXO T2,DGSEEN ;SET DIGIT SEEN FLAG INTI1A: ANDI T1,17 ;MAKE A BINARY NUMBER MOVE T4,T5 ;PREPARE FOR 2-WORD MUL MULI T4,12 ;MULT NUMBER BY A POWER OF 10 TLO T5,400000 ;TURN ON SIGN BIT TO STOP OVERFLOW ADD T5,T1 ;ACCUMULATE THE SUM TLZE T5,400000 ;DID WE OVERFLOW? JUMPE T4,INTI2 ;NO. ANYTHING IN HIGH WORD? TXO T2,OVRFLG ;YES. WE OVERFLOWED! INTI2: ADDI T4,1 ;YES. ADD ONE TO OVERFLOW SOJA T3,INTI1 ;GET NEXT DIGIT INTI3: CAIN T1,11 ; MOVEI T1," " ;CLEAR THE CHARACTER CAIE T1," " ;CHECK FOR A BLANK JRST INTI3A ;NOT A BLANK OR JUMPL T3,INTFRE ;YES, CHECK BZ IF NOT FREE FORM MOVE T0,FLAGS(D) TXNN T0,D%BZ ;BZ FORMAT ON? SOJA T3,INTI1 ;NO. SKIP THE CHAR JRST INTI1A ;YES. TREAT AS A ZERO INTFRE: JUMPGE T2,INTI1 ;NO DIGITS CONTINUE SCAN IF FREE FORM INTI3A: JUMPL T2,INTI4 ;DIGIT SEEN YET CAIN T1,"-" ;NO, IS THIS A MINUS SIGN TXOA T2,SGNFLG ;YES, SET THE FLAG CAIN T1,"+" ;CHECK FOR A PLUS SOJA T3,INTI1 ;YES, GET NEXT CHARACTER INTI4: CAME T3,[-1] ;IF FIRST CHAR THEN ILLEGAL JUMPL T3,INTI6 ;NO, CHECK FOR VARIABLE FIELD $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" POPJ P, ;RETURN TO FOROTS INTI6: TXNN T2,OVRFLG ;DID WE OVERFLOW? JRST INTI6A ;NO HRLOI T2,377777 ;YES. LOAD BIGGEST VALUE ; IOERR (IOV,64,571,%,Integer overflow,,INTI6A) $ECALL IOV INTI6A: TXNE T2,SGNFLG ;CHECK FOR SIGN MOVN T5,T5 ;NEGATE THE RESULT MOVEM T5,(P1) ;PUT RESULT IN USER'S VARIABLE POPJ P, ;RETURN TO FOROTS %GINTO: MOVEI T1,1 ;AT LEAST ONE DIGIT FOR G-FORMAT DPB T1,D.PNTR %INTO: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,INTSET ;DO SETUP SKIPN T3 ;FREE FORMAT? MOVEI T3,17 ;YES. TURN INTO FIXED! LDB T1,D.PNTR ;GET MIN # DIGITS DESIRED JUMPN T1,GOTMIN ;GOT IT MOVE T0,FLAGS(D) TXNE T0,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED? MOVEI T1,1 ;YES. PRINT AT LEAST 1 DIGIT GOTMIN: CAILE T1,(T3) ;BUT DON'T LET MINIMUM NUMBER MOVEI T1,(T3) ;GET BIGGER THAN FIELD WIDTH MOVE T4,(P1) ;GET USER'S VARIABLE JUMPE T4,INTZER ;INTEGER IS 0 INTO1: IDIVI T4,12 ;FORM AN INTEGER MOVM T5,T5 ;GET REMAINDER MAGNITUDE IORI T5,"0" ;CONVERT TO ASCII PUSH P,T5 ;SAVE ON THE STACK SKIPE T4 ;CHECK FOR END OF DIGITS AOJA T2,INTO1 ;COUNT THE DIGIT AND CONTINUE ADDI T2,1 ;COUNT THE LAST DIGIT INTZER: CAIGE T2,(T1) ;MINIMUM NUMBER PUSHED? JRST INTO1 ;NO. PUSH MORE MOVEI T4,(T3) ;COPY FIELD SIZE SUBI T4,(T2) ;FIND THE EXCESS FIELD SIZE SKIPL (P1) ;CHECK THE VARIABLE SIGN JUMPGE T4,INTO2 ;POSITIVE. GO OUTPUT IT JUMPG T4,INTO2 ;MUST HAVE ROOM FOR SIGN IFN FTAST,< HRL T2,T2 ;SETUP STACK RESET SUB P,T2 ;RESET STACK MOVEI T1,"*" ;OUTPUT ASTERISKS PUSHJ P,%OBYTE SOJG T3,.-1 PJRST %FTSER ;%Field width too small > IFE FTAST,< MOVM T4,T4 ;MAKE POSITIVE HRLI T4,(T4) ;SET UP EXCESS COUNT SUB P,T4 ;ADJUST THE STACK SETZ T4, ;CLEAR THE EXCESS COUNT > INTO2: CAIG T4,1 ;ROOM FOR BLANKS? JRST SGNOUT ;NO MOVEI T1," " ;YES. OUTPUT SOME MOVE T0,FLAGS(D) TXNN T0,D%NML+D%LSD ;BUT NOT IF NMLST OR LDIO PUSHJ P,%OBYTE SOJA T4,INTO2 SGNOUT: MOVE T0,FLAGS(D) ;T0= DDB flags JUMPLE T4,INTO5 ;DELETE SIGN IF NO ROOM MOVEI T1," " ;ASSUME EXTRA BLANK JUMPLE T2,NOPLUS ;NO PLUS IF NO DIGITS TXNE T0,D%SP ;FORCE A PLUS? MOVEI T1,"+" ;YES. OUTPUT A PLUS SIGN SKIPGE (P1) ;UNLESS THE VARIABLE IS NEGATIVE MOVEI T1,"-" ;FOR WHICH USE A MINUS SIGN CAIN T1," " ;OUTPUTTING A SPACE? NOPLUS: TXNN T0,D%LSD+D%NML ;YES. DON'T FOR NAMELIST OR LDIO PUSHJ P,%OBYTE INTO5: JUMPLE T2,INTO6 ;MIGHT BE NO DIGITS! POP P,T1 ;GET A CHARACTER FROM THE STACK PUSHJ P,%OBYTE ;OUTPUT A DIGIT SOJG T2,INTO5 ;CONTINUE OUTPUTTING THE DIGITS INTO6: POPJ P, ;RETURN TO FOROTS INTSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE LDB T3,W.PNTR ;GET THE FIELD WIDTH SETZB T5,T2 ;CLEAR STORAGE SETZ T4, POPJ P, PURGE $SEG$ PRGEND TITLE LOGIC LOGICAL INPUT/OUTPUT SUBTTL D. TODD/HPW/MD/DCE 28-OCT-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION SEGMENT CODE ENTRY %LINT,%LOUT,%GLINT,%GLOUT EXTERN %IBYTE,%OBYTE,W.PNTR EXTERN %SKIP EXTERN IO.ADR,IO.INF,%SAVE1 EXTERN %ABORT %GLINT: %LINT: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,LOGSET ;DO SETUP SETZM (P1) ;INPUT SET THE USER'S VARIABLE FALSE MOVEI T3,6 ;SETUP TO SAVE 6 CHARS MOVE T2,[POINT 6,IO.INF];IN SIXBIT JUMPG T4,LINT ;NOT FREE FORMAT SETO T4, ;FREE FORMAT PUSHJ P,%SKIP ;SKIP SPACES POPJ P, ;NULL FIELD JRST LINT0 ;PROCESS FIELD LINT: JUMPE T4,LINT3 ;IF W=0 RETURN PUSHJ P,%IBYTE ;SKIP AN INPUT CHARACTER LINT0: CAIE T1," " ;CHECK FOR A BLANK CAIN T1,11 ;OR SOJA T4,LINT ;YES, IGNORE THE CHARACTER CAIE T1,"." ;PERIOD? JRST NOTDOT ;NO SOJE T4,LINT2 ;ERROR IF JUST DOT PUSHJ P,%IBYTE ;GET NEXT CHAR NOTDOT: PUSHJ P,DEPINF ;DEPOSIT IN INFO WORD CAIE T1,"f" ;LOWER CASE F IS OK CAIN T1,"F" ;CHECK FOR FALSE JRST LINT1 ;YES, PROCESS THE FALSE CHARACTER CAIE T1,"t" ;CKECK, FOR TRUE CAIN T1,"T" ;UPPER CASE TOO TRNA ;FOUND A TRUE JRST LINT2 ;NO, ILLEGAL CHARACTER SETOM (P1) ;YES, SET USER'S VARIABLE PRUE LINT1: SOJE T4,LINT3 ;SPACING REQUIRED W=0 PUSHJ P,%IBYTE ;YES, SKIP AN INPUT CHARACTER JUMPG T4,LINT1 ;CONTINUE UNTIL W=0 CAIE T1," " ;SPACE, TAB, OR COMMA ENDS FREE FMT CAIN T1,11 POPJ P, CAIN T1,"," POPJ P, MOVE T0,FLAGS(D) TXNN T0,D%LSD ;LIST-DIRECTED? JRST NOTLSD ;NO CAIN T1,"/" ;SLASH ENDS LDIO POPJ P, NOTLSD: MOVE T0,FLAGS(D) TXNN T0,D%NML ;NAMELIST? JRST NOTNML ;NO CAIE T1,"(" ;YES. EQUAL AND LEFT PAREN CAIN T1,"=" ;ARE DELIMITERS POPJ P, ;SO WE STOP CAIE T1,"$" ;ALSO MIGHT BE NAMELIST DELIM! CAIN T1,"&" POPJ P, ;IN WHICH CASE WE LEAVE NOTNML: PUSHJ P,DEPINF ;ELSE DEPOSIT IN INFO WORD JRST LINT1 ;IGNORE ALL ELSE LINT2: $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" LINT3: POPJ P, ;RETURN %GLOUT: %LOUT: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,LOGSET ;DO SETUP MOVE T0,FLAGS(D) TXNE T0,D%NML+D%LSD ;IF NMLST OR LDIO JRST LOUT1 ;Don't bother with blank fill SKIPG T4 ;W SPECIFIED? SKIPA T4,[^D15-1] ;NO - SET DEFAULT = 15. SOJE T4,LOUT1 ;CHECK FOR W=1 MOVEI T1," " ;GET A BLANK FOR OUTPUT PUSHJ P,%OBYTE ;OUTPUT A FILL BLANK SOJG T4,.-1 ;CONTINUE FILLING LOUT1: MOVEI T1,"F" ;GET A F FOR FALSE SKIPGE (P1) ;IS VARIABLE FALSE MOVEI T1,"T" ;NO, SET T FOR TRUE PJRST %OBYTE ;OUTPUT THE VALUE AND RETURN TO FOROTS DEPINF: SOJL T3,INFDON ;NO MORE THAN 6 CHARS MOVEI T5,(T1) ;COPY THE CHAR CAIL T5,140 ;CONVERT TO SIXBIT SUBI T5,40 SUBI T5,40 IDPB T5,T2 ;DEPOSIT IN INFO WORD INFDON: POPJ P, LOGSET: SETZM IO.INF ;CLEAR INFO WORD MOVE P1,IO.ADR ;GET ADDR OF VARIABLE LDB T4,W.PNTR ;GET THE FILD WIDTH POPJ P, PURGE $SEG$ PRGEND TITLE OCTAL OCTAL INPUT/OUTPUT SUBTTL D. TODD/DRT/HPW/MD/SWG/DCE 28-OCT-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION SEGMENT CODE ENTRY %OCTI,%OCTO,%GOCTI,%GOCTO EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR,%SAVE2 EXTERN %SKIP,%SIZTB EXTERN IO.ADR,IO.TYP EXTERN %FTSER EXTERN %ABORT DGSEEN==400000,,0 ;MUST BE 400000, TEST WITH JUMPL SGNFLG==200000,,0 ;MINUS SIGN SEEN %GOCTI: %OCTI: PUSHJ P,%SAVE2 ;SAVE P1 & P2 PUSHJ P,OCTSET ;DO SETUP SETZB T4,T5 ;CLEAR THE OUTPUT WORD JUMPG T3,OCTI1 ;FIELD SPECIFIED SETO T3, ;NO, SET VARIABLE FLAG PUSHJ P,%SKIP ;SKIP SPACES JRST OCTI5 ;NULL FIELD DELIMITED BY COMMA OR EOL JRST OCTI1B ;PROCESS FIELD OCTI1: JUMPE T3,OCTI5 ;CHECK FOR END OF FIELD PUSHJ P,%IBYTE ;GET AN INPUT CHARACTER OCTI1B: CAIG T1,"7" ;CHECK FOR AN OCTAL CAIGE T1,"0" ;DIGIT (0-7) JRST OCTI2 ;56;NO, NOT AN OCTAL DIGIT TXO T2,DGSEEN ;SET DIGIT SEEN FLAG OCTI1A: ANDI T1,7 ;MAKE AN OCTAL DIGIT LSHC T4,3 ;POSITION OUTPUT WORD TRO T5,(T1) ;OR IN DIGIT SOJA T3,OCTI1 ;RETURN FOR NEXT CHARACTER OCTI2: CAIN T1,11 ; CHARACTER MOVEI T1," " ;CLEAR THE CAIE T1," " ;CHECK FOR A BLANK JRST OCTI2A ;NOT A BLANK OR JUMPL T3,OCTFRE ;FREE FORMAT? MOVE T0,FLAGS(D) TXNN T0,D%BZ ;NO. BZ FORMAT ON? SOJA T3,OCTI1 ;NO. SKIP CHARACTER JRST OCTI1A ;YES. TREAT AS A ZERO OCTFRE: JUMPGE T2,OCTI1 ;DIGIT NOT SEEN IN FREE FORM OCTI2A: JUMPL T2,OCTI3 ;HAS A DIGIT BEEN SEEN CAIN T1,"-" ;CHECK FOR A MINUS SIGN TXOA T2,SGNFLG ;SET MINUS FLAG CAIN T1,"+" ;CHECK FOR A PLUS SIGH SOJA T3,OCTI1 ;YES, COUNT AND GET NEXT CHAR OCTI3: CAME T3,[-1] ;FIRST CHAR ILLEGAL JUMPL T3,OCTI5 ;NO ERROR ON VARIABLE FIELD INPUT $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" OCTI5: JUMPN T4,OCTI5A ;LEAVE ALONE IF NON-ZERO 1ST WORD EXCH T4,T5 ;ELSE SWAP THEM OCTI5A: TXNN T2,SGNFLG ;CHECK THE SIGN OF THE OUTPUT JRST OCTI6 ;POSITIVE DMOVN T4,T4 ;NEGATIVE (NEGATE THE RESULT) TLO T5,400000 ;DMOVN ZEROES SIGN BIT OF RIGHT ;WORD - VAL IS NEG SO TURN IT ON ALWAYS OCTI6: MOVEM T4,(P1) ;ASSUME SINGLE PREC CAIN P2,2 ;[735] IF DOUBLE PRECISION MOVEM T5,1(P1) ;[735] THEN RETURN BOTH HALVES POPJ P, ;RETURN TO FOROTS %GOCTO: %OCTO: PUSHJ P,%SAVE2 ;SAVE P1 & P2 PUSHJ P,OCTSET ;DO SETUP MOVSI T5,(POINT 3,(P1)) ;GET AN OCTAL BYTE POINTER JUMPN T3,OCTO1 ;CHECK FOR VARIABLE FIELD OUTPUT MOVEI T3,^D15 ;YES SET FILED WIDTH TO O15 CAIN P2,2 ;IF DOUBLE REAL MOVEI T3,^D25 ;THEN ITS O25 OCTO1: LDB T4,D.PNTR ;GET MINIMUM # DIGITS JUMPN T4,GOTMIN ;DONE IF NON-ZERO MOVEI T4,(T3) ;USE WIDTH IF 0 GOTMIN: SUBI T3,(T2) ;FIND THE EXCESS FIELD WIDTH JUMPLE T3,OCTO2 ;W<= MAX FIELD WIDTH MOVEI T1," " ;SET UP A BLANK FILLER PUSHJ P,%OBYTE ;OUTPUT THE FILLER SOJG T3,.-1 ;CONTINUE UNTIL W=0 (EXCESS) OCTO2: JUMPE T3,OCTO2B ;GO ON IF FITS ADD T2,T3 ;MODIFY # CHARS FOR OUTPUT OCTO2A: ILDB T1,T5 ;GET CHAR IFN FTAST,< JUMPN T1,OCTOVR ;OVERFLOW IF DIGIT NON-ZERO > AOJL T3,OCTO2A OCTO2B: ILDB T1,T5 ;GET A CHAR JUMPN T1,OCTO3A ;GO PRINT ALL IF NON-ZERO MOVEI T1,"0" ;MAYBE PRINT A ZERO CAILE T2,(T4) ;PRINT A SPACE IF ALLOWED TO MOVEI T1," " ;IF W.M WAS SPECIFIED PUSHJ P,%OBYTE ;OUTPUT ZERO OR SPACE SOJG T2,OCTO2B POPJ P, ;LEAVE IF DIGITS EXHAUSTED OCTO3: ILDB T1,T5 ;GET THE NEXT OCTAL DIGIT OCTO3A: ADDI T1,"0" ;CONVERT TO ASCII PUSHJ P,%OBYTE ;OUTPUT A DIGIT SOJG T2,OCTO3 ;BACK FOR MORE POPJ P, ;RETURN TO FOROTS OCTOVR: MOVEI T1,"*" ;OUTPUT ASTERISKS PUSHJ P,%OBYTE SOJG T2,.-1 PJRST %FTSER ;%Field width too small OCTSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE MOVEI T2,^D12 ;12 DIGITS ONLY MOVE P2,IO.TYP ;GET VARIABLE TYPE MOVE P2,%SIZTB(P2) ;GET ENTRY SIZE IMULI T2,(P2) ;GET CORRESPONDING # DIGITS LDB T3,W.PNTR ;GET THE FIELD WIDTH POPJ P, PURGE $SEG$ PRGEND TITLE HEXIO HEX INPUT/OUTPUT SUBTTL CHRIS SMITH/CKS 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION ;FROM OCTAL I/O SEGMENT CODE ENTRY %HEXI,%HEXO EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR,%SAVE2 EXTERN %SKIP,%SIZTB EXTERN IO.ADR,IO.TYP EXTERN %FTSER EXTERN %ABORT DGSEEN==400000,,0 ;MUST BE 400000, TEST WITH JUMPL SGNFLG==200000,,0 ;MINUS SIGN SEEN %HEXI: PUSHJ P,%SAVE2 ;SAVE P1 & P2 PUSHJ P,HEXSET ;DO SETUP SETZB T4,T5 ;CLEAR THE OUTPUT WORD JUMPG T3,HEXI1 ;FIELD SPECIFIED SETO T3, ;NO, SET VARIABLE FLAG PUSHJ P,%SKIP ;SKIP SPACES JRST HEXI5 ;NULL FIELD DELIMITED BY COMMA OR EOL JRST HEXI1B ;PROCESS FIELD HEXI1: JUMPE T3,HEXI5 ;CHECK FOR END OF FIELD PUSHJ P,%IBYTE ;GET AN INPUT CHARACTER HEXI1B: CAILE T1,140 ;LOWER CASE? SUBI T1,40 ;YES, CONVERT TO UPPER CAIL T1,"0" ;CHECK FOR A HEX CAILE T1,"F" ;DIGIT (0-F) JRST HEXI2 ;NOT A HEX DIGIT CAILE T1,"9" ;CHECK SOME MORE CAIL T1,"A" TXOA T2,DGSEEN ;DIGIT, SET DIGIT SEEN FLAG JRST HEXI2 ;NONDIGIT, LEAVE SUBI T1,"0" ;MAKE INTO DIGIT CAIL T1,"A"-"0" SUBI T1,"A"-"0"-^D10 HEXI1A: LSHC T4,4 ;POSITION OUTPUT WORD TRO T5,(T1) ;OR IN DIGIT SOJA T3,HEXI1 ;RETURN FOR NEXT CHARACTER HEXI2: CAIN T1,11 ; CHARACTER MOVEI T1," " ;CLEAR THE CAIE T1," " ;CHECK FOR A BLANK JRST HEXI2A ;NOT A BLANK OR JUMPL T3,HEXFRE ;FREE FORMAT? MOVE T0,FLAGS(D) TXNN T0,D%BZ ;NO. BZ FORMAT ON? SOJA T3,HEXI1 ;NO. SKIP CHARACTER SETZ T1, ;YES. TREAT AS A ZERO JRST HEXI1A ;GO INSERT IN OUTPUT NUMBER HEXFRE: JUMPGE T2,HEXI1 ;DIGIT NOT SEEN IN FREE FORM HEXI2A: JUMPL T2,HEXI3 ;HAS A DIGIT BEEN SEEN CAIN T1,"-" ;CHECK FOR A MINUS SIGN TXOA T2,SGNFLG ;SET MINUS FLAG CAIN T1,"+" ;CHECK FOR A PLUS SIGH SOJA T3,HEXI1 ;YES, COUNT AND GET NEXT CHAR HEXI3: CAME T3,[-1] ;FIRST CHAR ILLEGAL JUMPL T3,HEXI5 ;NO ERROR ON VARIABLE FIELD INPUT $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" HEXI5: JUMPN T4,HEXI5A ;LEAVE ALONE IF NON-ZERO 1ST WORD EXCH T4,T5 ;ELSE SWAP THEM HEXI5A: TXNN T2,SGNFLG ;CHECK THE SIGN OF THE OUTPUT JRST HEXI6 ;POSITIVE DMOVN T4,T4 ;NEGATIVE (NEGATE THE RESULT) TLO T5,400000 ;DMOVN ZEROES SIGN BIT OF RIGHT ;WORD - VAL IS NEG SO TURN IT ON ALWAYS HEXI6: MOVEM T4,(P1) ;ASSUME SINGLE PREC CAIN P2,2 ;[735] IF DOUBLE PRECISION MOVEM T5,1(P1) ;[735] THEN RETURN BOTH HALVES POPJ P, ;RETURN TO FOROTS %HEXO: PUSHJ P,%SAVE2 ;SAVE P1 & P2 PUSHJ P,HEXSET ;DO SETUP MOVSI T5,(POINT 4,(P1)) ;GET A HEX BYTE POINTER JUMPN T3,HEXO1 ;CHECK FOR VARIABLE FIELD OUTPUT MOVEI T3,^D15 ;YES SET FIELD WIDTH TO O15 CAIN P2,2 ;IF DOUBLE REAL MOVEI T3,^D25 ;THEN ITS O25 HEXO1: LDB T4,D.PNTR ;GET MINIMUM # DIGITS JUMPN T4,GOTMIN ;DONE IF NON-ZERO MOVEI T4,(T3) ;USE WIDTH IF 0 GOTMIN: SUBI T3,(T2) ;FIND THE EXCESS FIELD WIDTH JUMPLE T3,HEXO2 ;W<= MAX FIELD WIDTH MOVEI T1," " ;SET UP A BLANK FILLER PUSHJ P,%OBYTE ;OUTPUT THE FILLER SOJG T3,.-1 ;CONTINUE UNTIL W=0 (EXCESS) HEXO2: JUMPE T3,HEXO2B ;GO ON IF FITS ADD T2,T3 ;MODIFY # CHARS FOR OUTPUT HEXO2A: ILDB T1,T5 ;GET CHAR IFN FTAST,< JUMPN T1,HEXOVR ;OVERFLOW IF DIGIT NON-ZERO > AOJL T3,HEXO2A HEXO2B: ILDB T1,T5 ;GET A CHAR JUMPN T1,HEXO3A ;GO PRINT ALL IF NON-ZERO MOVEI T1,"0" ;MAYBE PRINT A ZERO CAILE T2,(T4) ;PRINT A SPACE IF ALLOWED TO MOVEI T1," " ;IF W.M WAS SPECIFIED PUSHJ P,%OBYTE ;OUTPUT ZERO OR SPACE SOJG T2,HEXO2B POPJ P, ;LEAVE IF DIGITS EXHAUSTED HEXO3: ILDB T1,T5 ;GET THE NEXT HEXAL DIGIT HEXO3A: ADDI T1,"0" ;CONVERT TO ASCII CAILE T1,"9" ;PAST 9? ADDI T1,"A"-"0"-^D10 ;YES, CONVERT TO RANGE A-F PUSHJ P,%OBYTE ;OUTPUT A DIGIT SOJG T2,HEXO3 ;BACK FOR MORE POPJ P, ;RETURN TO FOROTS HEXOVR: MOVEI T1,"*" ;OUTPUT ASTERISKS PUSHJ P,%OBYTE SOJG T2,.-1 PJRST %FTSER ;%Field width too small HEXSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE MOVEI T2,9 ;9 DIGITS ONLY MOVE P2,IO.TYP ;GET VARIABLE TYPE MOVE P2,%SIZTB(P2) ;GET ENTRY SIZE IMULI T2,(P2) ;GET CORRESPONDING # DIGITS LDB T3,W.PNTR ;GET THE FIELD WIDTH POPJ P, PURGE $SEG$ PRGEND TITLE DELIM ROUTINE TO HANDLE DELIMITER OF FREE FORMAT ; and other random junk SUBTTL M. DUHAMEL/MD 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION ;FROM LIB40 %4(372) SEGMENT CODE ENTRY %SKIP,%SIZTB ENTRY %FTSER ;Give %Field width too small error EXTERNAL %IBYTE EXTERN %TRACE,%APRCT,%APRLM,%APRSB EXTERN U.PDL,%CALU ;ROUTINE TO SAVE EVENTUAL DELIMITER ;CALLED BY PUSHJ ;ROUTINE TO SKIP SPACES ;NON SKIP RETURN IF CHAR IS COMMA OR EOL %SKIP: PUSHJ P,%IBYTE ;GET A CHAR CAIE T1," " ;BLANK CAIN T1," " ;OR TAB JRST SKIP0 ;YES SKIP CAIE T1,"," ;COMMA AOS (P) POPJ P, SKIP0: MOVE T0,FLAGS(D) TXNN T0,D%EOR ;FINI JRST %SKIP ;CONTINUE POPJ P, ;OUI-NON SKIP RETURN %FTSER: AOS T2,%APRCT+.ETOFW ;COUNT ERROR OCCURRENCE CAMLE T2,%APRLM+.ETOFW ;SKIP IF SHOULD TYPE THE ERROR JRST CHKU MOVE T1,U.PDL ;GET USER'S STACK PNTR MOVE T1,(T1) ;GET RETURN ADDRESS SUBI T1,1 ;GET CALLING ADDRESS $ECALL FTS CHKU: SKIPN T1,%APRSB+.ETOFW ;Any user subroutine? POPJ P, ;No, return CHKU1: MOVE T3,U.PDL ;Get original PDL ptr. MOVE T3,(T3) ;Get PC of the "PUSHJ 17,IOLST." XMOVEI T3,(T3) ; (Just PC address, pls) MOVEI T2,.ETOFW ;T2= err number PJRST %CALU ;Call user subroutine and return ;%SIZTB GIVES THE NUMBER OF WORDS ASSOCIATED WITH EACH TYPE OF ;VARIABLE. %SIZTB: 1 ;(0) UNDEFINED (INTEGER) 1 ;(1) LOGICAL 1 ;(2) INTEGER 1 ;(3) 1 ;(4) SINGLE REAL 1 ;(5) 1 ;(6) SINGLE OCTAL (INTEGER) 1 ;(7) LABEL 2 ;(10) DOUBLE REAL 2 ;(11) DOUBLE INTEGER 2 ;(12) DOUBLE OCTAL 2 ;(13) EXTENDED DOUBLE REAL 2 ;(14) COMPLEX 1 ;(15) COBOL BYTE STRING 1 ;(16) CHARACTER 1 ;(17) ASCIZ PURGE $SEG$ PRGEND TITLE POWTB D.P. INTEGER POWER OF TEN TABLE SUBTTL D. TODD /DRT/ 28-Oct-81 TOM EGGERS SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION SEGMENT CODE ENTRY %HITEN, %LOTEN, %EXP10, %PTLEN ENTRY %DEXP,%HIMAX,%BEXP ;POWER OF TEN TABLE IN DOUBLE PRECISION ;INTEGER FORMAT. EACH ENTRY CONSISTS OF TWO WORDS, ;EACH WITH 35 BITS OF FRACTION (SIGNS ARE EXCLUDED). ;THE BINARY POINT IS BETWEEN BITS 0 AND 1 OF THE ;HI ORDER WORD. THE EXPONENT FOR THE 70 BIT ;FRACTION IS STORED IN THE SHORT TABLE CALLED "EXPTEN". ;FOLLOWING THE STANDARD TABLE IS ATHE EXTENDED EXPONENT ;TABLE, WHICH IS A SPARSE POWER OF TEN TABLE RANGING FROM ;10**21 TO 10**326, FOR USE IN ENCODING AND DECODING G-FLOATING ;NUMBERS. ;THE NUMBERS IN BOTH TABLES ARE TRUNCATED, THAT IS, NO ;ROUNDING HAS BEEN DONE FROM THE (VIRTUAL) THIRD WORD OF ;PRECISION. THUS, ON AVERAGE, THE TABLES ARE BIASED 1/2 BIT ;DOWNWARDS. DEFINE .TAB. (A)< NUMBER -246,357347511265,056017357445 NUMBER -242,225520615661,074611525567 NUMBER -237,273044761235,213754053125 NUMBER -234,351656155504,356747065752 NUMBER -230,222114704413,025260341562 NUMBER -225,266540065515,332534432117 NUMBER -222,344270103041,121263540543 NUMBER -216,216563051724,322660234335 NUMBER -213,262317664312,007434303425 NUMBER -210,337003641374,211343364332 NUMBER -204,213302304735,325716130610 NUMBER -201,256162766125,113301556752 NUMBER -176,331617563552,236162112545 NUMBER -172,210071650242,242707256537 NUMBER -167,252110222313,113471132267 NUMBER -164,324532266776,036407360745 NUMBER -160,204730362276,323044526457 NUMBER -155,246116456756,207655654173 NUMBER -152,317542172552,051631227231 NUMBER -146,201635314542,132077636440 NUMBER -143,242204577672,360517606150 NUMBER -140,312645737651,254643547602 NUMBER -135,375417327624,030014501542 NUMBER -131,236351506674,217007711035 NUMBER -126,306044030453,262611673245 NUMBER -123,367455036566,237354252116 NUMBER -117,232574123152,043523552261 NUMBER -114,301333150004,254450504735 NUMBER -111,361622002005,327562626124 NUMBER -105,227073201203,246647575664 NUMBER -102,274712041444,220421535242 NUMBER -077,354074451755,264526064512 NUMBER -073,223445672164,220725640716 NUMBER -070,270357250621,265113211102 NUMBER -065,346453122766,042336053323 NUMBER -061,220072763671,325412633103 NUMBER -056,264111560650,112715401724 NUMBER -053,341134115022,135500702312 NUMBER -047,214571460113,172410431376 NUMBER -044,257727774136,131112537675 NUMBER -041,333715773165,357335267655 NUMBER -035,211340575011,265512262714 NUMBER -032,253630734214,043034737477 NUMBER -027,326577123257,053644127417 NUMBER -023,206157364055,173306466551 NUMBER -020,247613261070,332170204303 NUMBER -015,321556135307,020626245364 NUMBER -011,203044672274,152375747331 NUMBER -006,243656050753,205075341217 NUMBER -003,314631463146,146314631463 A: NUMBER 001,200000000000,000000000000 NUMBER 004,240000000000,000000000000 NUMBER 007,310000000000,000000000000 NUMBER 012,372000000000,000000000000 NUMBER 016,234200000000,000000000000 NUMBER 021,303240000000,000000000000 NUMBER 024,364110000000,000000000000 NUMBER 030,230455000000,000000000000 NUMBER 033,276570200000,000000000000 NUMBER 036,356326240000,000000000000 NUMBER 042,225005744000,000000000000 NUMBER 045,272207335000,000000000000 NUMBER 050,350651224200,000000000000 NUMBER 054,221411634520,000000000000 NUMBER 057,265714203644,000000000000 NUMBER 062,343277244615,000000000000 NUMBER 066,216067446770,040000000000 NUMBER 071,261505360566,050000000000 NUMBER 074,336026654723,262000000000 NUMBER 100,212616214044,117200000000 NUMBER 103,255361657055,143040000000 NUMBER 106,330656232670,273650000000 NUMBER 112,207414740623,165311000000 NUMBER 115,251320130770,122573200000 NUMBER 120,323604157166,147332040000 NUMBER 124,204262505412,000510224000 NUMBER 127,245337226714,200632271000 NUMBER 132,316627074477,241000747200 NUMBER 136,201176345707,304500460420 NUMBER 141,241436037271,265620574524 NUMBER 144,311745447150,043164733651 NUMBER 147,374336761002,054022122623 NUMBER 153,235613266501,133413263574 NUMBER 156,305156144221,262316140533 NUMBER 161,366411575266,037001570661 NUMBER 165,232046056261,323301053417 NUMBER 170,300457471736,110161266322 NUMBER 173,360573410325,332215544007 NUMBER 177,226355145205,250330436404 NUMBER 202,274050376447,022416546105 NUMBER 205,353062476160,327122277527 NUMBER 211,222737506706,206363367626 NUMBER 214,267527430470,050060265574 NUMBER 217,345455336606,062074343133 NUMBER 223,217374313163,337245615771 NUMBER 226,263273376020,327117161367 NUMBER 231,340152275425,014743015665 NUMBER 235,214102366355,050055710521 NUMBER 240,257123064050,162071272645 NUMBER 243,332747701062,216507551417 NUMBER 247,210660730537,231114641751 NUMBER 252,253035116667,177340012343 > DEFINE NUMBER (A,B,C) TENTAB: .TAB. %HITEN DEFINE NUMBER (A,B,C) .TAB. %LOTEN %PTLEN==%HITEN-TENTAB ;CALCULATE NUMBER OF TABLE ENTRIES BEFORE "TENS" DEFINE NUMBER (A,B,C) .TAB. %EXP10 DEFINE HITABL < %%EXP==0 HIEXP 21, 0106, 330656232670, 273650000000 HIEXP 31, 0147, 374336761002, 054022122623 HIEXP 42, 0214, 267527430470, 050060265574 HIEXP 52, 0255, 325644342445, 137230015034 HIEXP 63, 0322, 233446460731, 230310256730 HIEXP 73, 0363, 265072116565, 045110433532 HIEXP 84, 0430, 203616042160, 325266273336 HIEXP 94, 0471, 231321375525, 337205744037 HIEXP 105, 0535, 337172572336, 007545174113 HIEXP 115, 0577, 201742476560, 254305755623 HIEXP 126, 0643, 275056630405, 050037577755 HIEXP 136, 0704, 334103204270, 352046213535 HIEXP 147, 0751, 240125245530, 066753037574 HIEXP 158, 1015, 351045347212, 074316542736 HIEXP 168, 1057, 207525153773, 310102120644 HIEXP 179, 1123, 305327273020, 343641442602 HIEXP 189, 1164, 345647674501, 121102720143 HIEXP 200, 1231, 247161432765, 330455055455 HIEXP 210, 1272, 302527746114, 232735577632 HIEXP 221, 1337, 215510706516, 363467704427 HIEXP 231, 1400, 244711331533, 105545654076 HIEXP 242, 1444, 357747123347, 374251221667 HIEXP 252, 1506, 213527073575, 262011603206 HIEXP 263, 1552, 313176275662, 023427342311 HIEXP 273, 1613, 354470426352, 214122564267 HIEXP 284, 1660, 254120203313, 021677205125 HIEXP 295, 1724, 372412614644, 074374052054 HIEXP 305, 1766, 221645055640, 266335117623 HIEXP 316, 2032, 324146136354, 344313410127 HIEXP 326, 2073, 367020634251, 325055547056 > %HIMAX==^D326 DEFINE HIEXP (DEXP,BEXP,HIWRD,LOWRD) < XWD BEXP,^D EXP HIWRD EXP LOWRD %%EXP==%%EXP+1 > %DEXP: HITABL %BEXP==%DEXP+1 PURGE $SEG$ PRGEND TITLE NMLST NAMELIST I/O SUBTTL NAME LIST SEQUENTIAL ACCESS CALLING SEQUENCES - 28-Oct-81 SEARCH FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION COMMENT $ READ (u,name) READ (u,name,END=c,ERR=d) MOVEI 16,ARGBLK 0 89 12 14 1718 35 PUSHJ 17,NLI. ------------------------------------ ! 3 !TYP!I! X ! u -unit# ! ------------------------------------ ! 4 !TYP!I! ! END=c ! ------------------------------------ ! 5 !TYP!I! ! ERR=d ! ------------------------------------ ! 6 !TYP!I! X ! IOSTAT=i ! ------------------------------------ ! 10 !TYP!I! X ! NAMELIST addr ! ------------------------------------ WRITE (u,name) WRITE (u,name,END=c,ERR=d) MOVEI 16,ARGBLK 0 89 12 14 1718 35 PUSHJ 17,NLO. ------------------------------------ ! 3 !TYP!I! X ! u -unit# ! ------------------------------------ ! 4 !TYP!I! ! END=c ! ------------------------------------ ! 5 !TYP!I! ! ERR=d ! ------------------------------------ ! 6 !TYP!I! X ! IOSTAT=i ! ------------------------------------ ! 10 !TYP!I! X ! name list addr ! ------------------------------------ The NAMELIST table illustrated below is generated form the FORTRAN NAMELIST STATEMENT. The first word of the table is the NAMELIST name in sixbit format. Following that are a number of two-word entries for scalar variables, and a number of (N+3)-word entries for array variables, where N is the dimensionality of the array. The NAMELIST argument block has the following format. NAMELIST ADDR/ 0 89 12 14 1718 35 ------------------------------------ ! SIXBIT /NAMELIST NAME/ ! ------------------------------------ ! NAME LIST ENTRIES ! ------------------------------------ ! 0 ! ------------------------------------ SCALAR ENTRIES 012 89 12 14 1718 35 ------------------------------------ ! SIXBIT /SCALAR NAME/ ! ------------------------------------ !10! 0 ! T !I! X ! SCALAR ADDR ! ------------------------------------ ARRAY ENTRIES 012 89 12 14 1718 35 ------------------------------------ ! SIXBIT /ARRAY NAME/ ! ------------------------------------ !10!#DIM! T !I! X ! BASE ADDR ! ------------------------------------ ! SIZE ! OFFSET ! ------------------------------------ ! ! !I! X ! FACTOR 1 ! ------------------------------------ ! ! !I! X ! FACTOR 2 ! ------------------------------------ ! ! !I! X ! FACTOR 3 ! ------------------------------------ ! ! !I! X ! FACTOR N ! ------------------------------------ $ SUBTTL JON CAMPBELL /JLC/EDS/AHM ENTRY %NLI,%NLO,%LDI,%LDO EXTERNAL %IBYTE,%IBYTC,%OBYTE,%IREC,%ORECS,%%GETIO,%SAVE4,%IBACK EXTERNAL %RPOS,%SPOS,%GTBLK,%PUSHT,%POPT EXTERNAL IO.ADR,IO.INC,IO.NUM,IO.TYP,IO.INF,ENC.WD,A.NML,SCL.SV EXTERNAL FL.RFR,FL.RBX EXTERNAL %GRIN,%GROUT,%INTI,%INTO,%LINT,%LOUT,%OCTI,%OCTO,%SIZTB EXTERNAL %IOERR,%POPJ,%POPJ1,%ABORT SEGMENT DATA %ALASZ==10 ;SIZE OF ARRAYS FOR STRING INFO %ALISZ==100 ;INITIAL SIZE FOR STRING CORE ALLOCATION NLSGN.: 0 ;SIGN OF VALUE NLFLG.: 0 ;-1=END OF DATA, 0=NULL, 1=NON-NULL DLFLG.: 0 ;FLAG TO SCAN FOR END DATA DELIM NLRFR: BLOCK 2 ;RAW FRACTION FROM FLIRT NLRBX: 0 ;RAW BINARY EXPONENT TO MATCH NLINFO: 0 ;INFO ABOUT FLIRT NUMBER (REAL PART) NLVAL.: BLOCK 2 ;VALUE FOUND NLVL2.: BLOCK 2 ;2ND VALUE FOR COMPLEX NLRP.: 0 ;REPEAT COUNT NLDIM.: 0 ;# OF DIMENSIONS NLVAR.: 0 ;PNTR TO VARIABLE IN ARG LIST NLNAM.: 0 ;NAME OF NAMELIST/VARIABLE NLARG.: 0 ;ADDRESS OF ARG LIST NLCVL.: BLOCK 2 ;CONVERTED VALUE NLADD.: 0 ;ADDRESS OF USER'S VARIABLE NLINC.: 0 ;OFFSET BETWEEN USER'S ARRAY ENTRIES NLSIZ.: 0 ;SIZE OF USER'S ARRAY ENTRIES CNVTYP: 0 ;CONVERTED VALUE TYPE VALTYP: 0 ;ORIGINAL VALUE TYPE VARTYP: 0 ;VARIABLE TYPE TOTYPE: 0 ;TYPE TO CONVERT TO OSIZE: 0 ;SIZE OF SUBSEQUENT OUTPUT DATA ELEMENT NLLCOR: BLOCK %ALASZ ;CORE ALLOCATION PER STRING BUFFER NLLCNT: BLOCK %ALASZ ;INDIVIDUAL STRING COUNTS NLLPNT: BLOCK %ALASZ ;INDIVIDUAL STRING POINTERS NLLTOT: 0 ;TOTAL STRING COUNT (WORDS) NLTCNT: 0 ;TEMP INDIVIDUAL STRING COUNT NLTPNT: 0 ;TEMP INDIVIDUAL STRING PNTR NLTIDX: 0 ;TEMP STRING INDEX NLTTOT: 0 ;TEMP TOTAL STRING COUNT (WORDS) NLBUF: BLOCK 200 ;STRING BUFFER FINFLG: 0 ;FLAGS FOR END OF DATA LDLFLG: 0 ;FLAGS FOR LEGAL DELIMITERS NLNUM.: 0 ;# OF USER'S ARRAY ENTRIES TO FILL NLVFC.: 0 ;FLAGS ALLOWED FOR 1ST CHAR OF VARIABLE NLFV.: 0 ;VARIABLE ENTRY HAS BEEN FILLED ;CHARACTER FLAGS - SET BY ROUTINE GETCHR ;IN ORDER TO TEST FOR MULTIPLE CHARACTERS (OF A CERTAIN TYPE, FOR INSTANCE), ;EACH CHARACTER HAS BEEN GIVEN AN ASSOCIATED FLAG (PICKED UP IN TABLE ;NLCFLG). ALL SPECIAL CHARACTERS (E.G. "*","$") HAVE THEIR OWN FLAGS, AND ;ALL ALPHABETIC CHARACTERS ARE GIVEN THE FLAG "ALFLAG". THIS TECHNIQUE ;COMPRESSES THE TESTING REQUIRED FOR DELIMITERS, ETC., AND MAKES IT MORE ;GENERAL. EQUFLG==0 COLFLG==0 SEMFLG==0 LSBFLG==0 RSBFLG==0 RABFLG==0 LABFLG==0 ATFLAG==0 NSFLAG==0 EOLFLG==2 DIGFLG==10 COMFLG==20 SPCFLG==40 ALFLAG==100 LPRFLG==200 RPRFLG==400 PNTFLG==1000 SQFLAG==2000 DQFLAG==4000 SGNFLG==10000 MINFLG==10000 PLSFLG==10000 NLSFLG==20000 NLEFLG==40000 AMPFLG==40000 DOLFLG==40000 NULFLG==100000 SLHFLG==200000 LOGFLG==400000 ASTFLG==1,,0 SEGMENT CODE ;LIST-DIRECTED INPUT & OUTPUT ROUTINES ;USES COMMON SUBROUTINES IN THE NAMELIST CODE TO PICK UP ;VALUES. %LDI: PUSHJ P,%SAVE4 ;SAVE P1-P4 MOVX T1,SLHFLG ;SLASH OR ERROR ENDS DATA MOVEM T1,FINFLG MOVX T1,COMFLG+SPCFLG+SLHFLG+NULFLG+ASTFLG ;LEGAL DELIMITERS MOVEM T1,LDLFLG ;FOR CHECKING AFTER A SCAN SETZM NLVFC. ;NO VARIABLES ALLOWED PUSHJ P,NLINIT ;INIT NMLST PARAMS MOVX T0,D%LSD ;set for list-directed IORM T0,FLAGS(D) LDILP: SETZM IO.ADR ;CLEAR THE I/O ADDR PUSH P,P1 ;SAVE P1 PUSHJ P,%%GETIO ;GET A VARIABLE POP P,P1 ;Restore it SKIPN IO.ADR ;ANY I/O ADDR? POPJ P, ;NO PUSHJ P,LDSET ;SETUP VARIABLE PARAMS PUSHJ P,NLMAIN ;DO MAIN LOOP SKIPN NLRP. ;IF REPEAT COUNT GONE TDNN P1,FINFLG ;CHECK IF FINISHED JRST LDILP ;BACK FOR MORE LDIFIN: LDIFLP: SETZM IO.ADR ;CLEAR THE I/O ADDR PUSHJ P,%%GETIO ;CALL IOLST UNTIL IT SKIPE IO.ADR ;GIVES NO ADDR JRST LDIFLP POPJ P, ;LIST-DIRECTED OUTPUT ;GETS A VARIABLE ADDRESS AND TYPE AND OUTPUTS THE VALUE ;IN THE PROPER FORMAT. IN ORDER TO AVOID A TRAILING COMMA, ;THE COMMA IS OUTPUT FIRST, BUT ONLY AFTER THE 1ST VALUE HAS BEEN ;WRITTEN ;* Warning - smashes Perm acs * %LDO: PUSHJ P,NLINIT ;INITIALIZE STUFF MOVX T0,D%LSD ;Set for list-directed IORM T0,FLAGS(D) MOVEI T1,1 ;SET OUTPUT FOR 1PG MOVEM T1,SCL.SV PUSHJ P,CHKEND ;CHECK FOR COL 1 LDOLP: SETZM IO.ADR ;CLEAR I/O ADDR PUSHJ P,%%GETIO ;GET A VARIABLE SKIPN IO.ADR ;ANY I/O ADDR? POPJ P, ;NO. WE'RE DONE PUSHJ P,LDSET ;SETUP VARIABLE PARAMS PUSHJ P,NLMO ;OUTPUT IT JRST LDOLP ;BACK FOR MORE LDSET: MOVE T1,IO.ADR ;GET ADDRESS MOVEM T1,NLADD. ;SAVE IT HRRZ T1,IO.TYP ;GET VARIABLE TYPE MOVEM T1,VARTYP ;SAVE IT MOVE T1,%SIZTB(T1) ;GET SIZE OF ENTRY MOVEM T1,NLSIZ. ;SAVE IT MOVE T1,IO.INC ;GET INCR WORD MOVEM T1,NLINC. ;SAVE OFFSET MOVE T1,IO.NUM ;GET # LOCS MOVEM T1,NLNUM. ;SAVE POSITIVE POPJ P, ;NAMELIST INPUT - AFTER FINDING THE PROPER NAMELIST "BEGIN DATA" ;SEQUENCE ($ OR & IN COLUMN 2), THE NAMELIST NAME IN THE DATA IS ;MATCHED AGAINST THE NAMELIST REQUIRED BY THE USER'S PROGRAM. ;IF IT DOES NOT MATCH, THE INPUT IS SCANNED TO THE NEXT "BEGIN ;DATA" SEQUENCE AND MATCHED AGAIN. UPON A MATCH, WE GRAB A VARIABLE ;NAME FROM THE DATA, AND SEARCH FOR IT IN THE NAMELIST BLOCK TO GET ;THE VARIABLE PARAMETERS. THEN WE LOOK AT WHETHER THE USER HAS ;SPECIFIED ARRAY INDICES IN THE DATA. IF SO, WE CALCULATE ;THE ARRAY REFERENCE. IF THE VARIABLE IS AN ARRAY BUT NO ARRAY INDICES ARE ;GIVEN, THE NUMBER OF ELEMENTS IN THE ARRAY IS USED AS THE POSSIBLE ;NUMBER OF ENTRIES TO FILL, STARTING AT THE FIRST ARRAY ELEMENT. ;NOTE THAT BEFORE THE DATA LOOP WE CLEAR NLNAM., WHICH INDICATES ;TO SUBROUTINE VARNAM TO ACTUALLY GET A NEW VARIABLE NAME FROM THE DATA. ;UNDER CERTAIN CIRCUMSTANCES, WE CAN RETURN FROM NLMAIN WITH THE NEXT ;VARIABLE NAME LEFT IN NLNAM. %NLI: PUSHJ P,%SAVE4 ;SAVE P1-P4 PUSHJ P,NLINIT ;INIT NMLST PARAMS MOVE T0,FLAGS(D) TXZ T0,D%IO ;0=INPUT TXO T0,D%NML ;MEANS "=" & "(" ARE LOGIC DELIMS MOVEM T0,FLAGS(D) MOVX T1,NLEFLG ;END OF DATA FLAGS MOVEM T1,FINFLG MOVX T1,COMFLG+SPCFLG+ALFLAG+NLEFLG+NULFLG+ASTFLG ;LEGAL DELIMITERS MOVEM T1,LDLFLG ;FOR CHECKING AFTER A SCAN MOVX T1,ALFLAG ;ALPHA CHAR ONLY BEGINS VARIABLE MOVEM T1,NLVFC. ;SAVE FOR SCAN MOVE T1,NLARG. ;GET NMLST PNTR MOVE T1,(T1) ;GET NAMELIST NAME MOVEM T1,NLVAL. ;SAVE IT NLILP1: PUSHJ P,NLGETB ;GET BEG OF NAMELIST DATA PUSHJ P,SKPCHR ;SKIP BEGIN CHAR PUSHJ P,NLINAM ;GET NAMELIST NAME IN DATA MOVE T2,NLNAM. ;GET NAME FOUND BY NLINAM CAME T2,NLVAL. ;IS IT THE ONE WE WANT? JRST NLILP1 ;NO SETZM NLNAM. ;CLEAR VARIABLE NAME NLILP2: PUSHJ P,VARNAM ;GET A VARIABLE NAME TDNE P1,FINFLG ;END OF DATA? JRST NLEND ;YES. LEAVE SKIPN NLNAM. ;FIND ANYTHING? JRST DOLFND ;NO. IT WAS AN ERROR, UNDOUBTEDLY TDNE P1,FINFLG ;END OF DATA? JRST NLEND ;YES. GO FIND END-OF-LINE PUSHJ P,NLVSRH ;SEARCH IN NAMELIST TABLE MOVE T1,NLNAM. ;Get name incase error TXNN P1,NLSFLG ;FOUND? ; IOERR (VNN,799,309,?,Variable $S not in namelist,,%ABORT) $ECALL VNN,%ABORT ;?Variable $S is not in namelist PUSHJ P,CALARR ;YES. CALC ADDR & # ENTRIES SETZM NLRP. ;CLEAR REPEAT COUNT SETZM NLNAM. ;CLEAR VARIABLE NAME SETZM NLFV. ;STARTING NEW VARIABLE PUSHJ P,NLMAIN ;DO MAIN CODE TDNN P1,FINFLG ;END OF DATA? JRST NLILP2 ;NO JRST NLEND ;YES DOLFND: PUSHJ P,GTCHRL ;GET NEXT CHAR TDNN P1,FINFLG ;END OF DATA? JRST DOLFND ;NO. SCAN SOME MORE NLEND: PJRST NLEOL ;LOOK FOR END OF LINE AND RETURN TO CALLER ;INITIALIZATION OF NAMELIST/LDIO PARAMETERS NLINIT: MOVE T1,A.NML ;GET NAMELIST ADDR MOVEM T1,NLARG. ;SAVE ARG LIST ADDR SETZM NLLTOT ;CLEAR STRING TOTAL COUNT SETZ P1, ;CLEAR FLAG WORD SETZM NLRP. ;CLEAR REPEAT COUNT SETZM NLFLG. ;CLEAR FLAG SETZM ENC.WD ;FREE FORMAT SETZM NLFV. ;SET NO VARIABLES FILLED SETZM SCL.SV ;CLEAR SCALE FACTOR POPJ P, ;CALARR - CHECKS THE DIMENSIONALITY OF THE VARIABLE SPECIFIED ;IN THE DATA. IF IT IS AN ARRAY, IT CALLS CALADD, WHICH CHECKS FOR THE ;PRESENCE OF INDICES IN THE DATA. OTHERWISE IT JUST CHECKS FOR ;THE EQUAL-SIGN FOLLOWING THE VARIABLE NAME. ;SMASHES P2, P3, P4. CALARR: PUSHJ P,VARSET ;SETUP VARIABLE PARAMS PUSHJ P,NLNB ;SCAN FOR NON-BLANK SKIPE NLDIM. ;ARRAY? PUSHJ P,CALADD ;YES. PROCESS INDICES IF ANY TDNE P1,FINFLG ;LEAVE IF DONE POPJ P, CAIE T1,"=" ;DO WE HAVE =? ; IOERR (NEQ,799,513,?,Found "$C" when expecting "=",,%ABORT) $ECALL NEQ,%ABORT PJRST SKPCHR ;SKIP THE EQUAL SIGN ;VARSET - DOES ALL THE NECESSARY SETUP GIVEN THE POINTER ;INTO THE NAMELIST BLOCK FOR THE GIVEN VARIABLE (IN NLVAR.). VARSET: MOVEI T1,1 ;INITIALIZE # ENTRIES AT 1 MOVEM T1,NLNUM. MOVE T2,NLVAR. ;GET THE ARG PNTR MOVE T1,(T2) ;GET VARIABLE NAME MOVEM T1,NLNAM. ;SAVE IT XMOVEI T1,@1(T2) ;Get base addr MOVEM T1,NLADD. ;SAVE IT LDB T3,[POINT 4,1(T2),12] ;GET TYPE MOVEM T3,VARTYP ;SAVE TYPE MOVE T1,%SIZTB(T3) ;GET SIZE MOVEM T1,NLSIZ. ;SAVE SIZE MOVEM T1,NLINC. ;AND OFFSET LDB T1,[POINT 7,1(T2),8] ;GET # DIMS MOVEM T1,NLDIM. ;SAVE # DIMS JUMPE T1,NLSCAL ;IT'S A SCALAR HLRZ T1,2(T2) ;GET # ENTRIES IN ARRAY MOVEM T1,NLNUM. ;SAVE IT NLSCAL: POPJ P, ;CALADD - PROCESSES THE INDICES OF AN ARRAY REFERENCE. ;IF THERE ARE NO INDICES, IT GRABS THE ARRAY SIZE DIVIDED ;BY THE ENTRY SIZE TO GET THE # OF ENTRIES. IF THERE ARE INDICES, ;IT ADDS THE OFFSET CALCULATED TO NLADD. ;SMASHES P2,P3,P4 CALADD: MOVE P2,NLVAR. ;GET VARIABLE ENTRY PNTR CAIE T1,"(" ;LEFT PAREN? JRST SETARR ;NO. ENTIRE ARRAY MOVE P3,NLDIM. ;P3= # dims left to process XMOVEI P4,3(P2) ;P4 points to factors XMOVEI T1,NLVAL. ;POINT TO VALUE MOVEM T1,IO.ADR ;FOR %INTI ADDLP1: PUSHJ P,%INTI ;GET AN INTEGER MOVE T2,NLVAL. ;GET THE VALUE IMUL T2,(P4) ;MULTIPLY BY A FACTOR IMUL T2,NLSIZ. ;GET THE REAL OFFSET ADDM T2,NLADD. ;ADD TO ADDRESS PUSHJ P,NLSDEL ;GET THE NEXT DELIMITER SOJLE P3,ADDLPD ;Go until no more dims AOJA P4,ADDLP1 ;. . ADDLPD: PUSHJ P,GETDEL ;GET THE DELIM CAIE T1,")" ;END OF INDICES? ; IOERR (NRP,799,514,?,Missing right paren,,%ABORT) $ECALL NRP,%ABORT PUSHJ P,SKPCHR ;SKIP THE RIGHT PAREN ALPX: PUSHJ P,NLNB ;AND GO TO NEXT DELIM ;DON'T TOUCH T1 - CONTAINS DELIM HRRZ T2,2(P2) ;GET THE OFFSET MOVNI T2,(T2) ;MAKE NEGATIVE ADDB T2,NLADD. ;ADD INTO ADDR XMOVEI T3,@1(P2) ;GET ORIG BASE ADDR SUB T3,T2 ;GET NEG OFFSET TO DESIRED LOC JUMPLE T3,OFFOK ;OK IF NEG OR ZERO ; IOERR (ILS,799,516,?,Illegal subscript,,%ABORT) $ECALL ILS,%ABORT ;?Illegal subscript OFFOK: IDIV T3,NLSIZ. ;GET NEG # ENTRIES IN OFFSET HLRZ T2,2(P2) ;GET TOTAL # ENTRIES ADD T2,T3 ;GET # ENTRIES LEFT MOVEM T2,NLNUM. ;SAVE IT JUMPG T2,%POPJ ;OK IF .GT. ZERO $ECALL ILS,%ABORT ;ILLEGAL SUBSCRIPT IF NOT SETARR: HLRZ T2,2(P2) ;GET # ENTRIES MOVEM T2,NLNUM. ;SAVE IT POPJ P, ;VARNAM & NLINAM - ASSEMBLES A VARIABLE NAME OR NAMELIST ;NAME FROM THE DATA. IF A NAME ALREADY EXISTS IN NLNAM., JUST RETURNS VARNAM: SKIPE NLNAM. ;IF IT WAS NON-ZER POPJ P, ;IT WAS A BAD LOGIC VALUE NLINAM: SETZM NLNAM. ;CLEAR NAME SKIPE DLFLG. ;ARE WE AT END OF PREVIOUS DATA SCAN? PUSHJ P,NLSDEL ;YES. SCAN FOR THE DELIMITER PUSHJ P,NLNB ;GET NON-BLANK CHAR TDNE P1,FINFLG ;END OF DATA? POPJ P, ;YUP SKIPE NLFLG. ;ERROR IF NULL ENTRY (COMMA FOUND) TDNN P1,NLVFC. ;MUST BEGIN WITH ALPHA ; IOERR (ILN,799,515,?,Variable or namelist does not start with letter,,%ABORT) $ECALL ILN,%ABORT MOVEI P2,6 ;6 CHARS TOTAL SKIPA P3,[POINT 6,NLNAM.] ;SIXBIT PNTR, ALREADY GOT 1ST CHAR NLINL1: PUSHJ P,GTCHRL ;GET NEXT CHAR TXNN P1,ALFLAG+DIGFLG ;ALPHA OR DIGIT POPJ P, ;NO. RETURN CAIL T1,140 ;CONVERT TO SIXBIT SUBI T1,40 SUBI T1,40 IDPB T1,P3 ;SAVE IT SOJG P2,NLINL1 ;MAX 6 CHARS ; PJRST NLNA ;THEN SCAN FOR NON-ALPHAMERIC ;SCAN FOR NON-ALPHAMERIC NLNA: PUSHJ P,GTCHRL ;GET A CHAR TXNE P1,ALFLAG+DIGFLG ;ALPHA OR DIGIT? JRST NLNA ;YES. SKIP IT POPJ P, ;NO. RETURN ;NLVSRH - SEARCH FOR A VARIABLE NAME IN THE NAMELIST ;BLOCK. THE NUMBER OF ENTRIES TAKEN BY A VARIABLE IN THE NAMELIST ;BLOCK IS DEPENDENT ON ITS DIMENSIONALITY. NLVSRH: TXZ P1,NLSFLG ;CLEAR SEARCH FOUND FLAG MOVE T3,NLARG. ;GET THE ARG PNTR ADDI T3,1 ;POINT TO 1ST VARIABLE NLVLP1: SKIPE T1,(T3) ;GET VARIABLE NAME CAMN T1,FINCOD ;0 OR END CODE IS END POPJ P, ;RETURN IF END OF LIST CAMN T1,NLNAM. ;VARIABLE WE WANT? JRST NLVFND ;YES! LDB T2,[POINT 7,1(T3),8] ;NO, GET # DIMS ADDI T3,2 ;ASSUME SCALAR JUMPE T2,NLVLP1 ;BACK IF SCALAR ADDI T3,1(T2) ;MORE JUNK IF ARRAY JRST NLVLP1 NLVFND: TXO P1,NLSFLG ;SET FOUND FLAG MOVEM T3,NLVAR. ;SAVE PNTR POPJ P, ;NLMAIN - THIS IS THE MAIN NAMELIST AND LIST-DIRECTED I/O ;ROUTINE. USING THE VARIABLE PARAMETERS SET UP FOR IT ;(NLADD.,NLSIZ.,NLINC.,NLNUM.) IT SCANS FOR A VALUE AND ;REPEAT COUNT IF THE REPEAT COUNT IS ZERO, DOES THE ;APPROPRIATE VALUE CONVERSION, STORES THE VALUE FOUND ;INTO THE USER'S VARIABLE (OR ARRAY ENTRY), AND DOES ALL ;THE APPROPRIATE INCREMENTING AND DECREMENTING OF THE ;VARIABLE PARAMETERS AND REPEAT COUNT. NLMAIN: NLP: SKIPN NLRP. ;REPEAT COUNT? PUSHJ P,NLSCV ;NO. GET VALUE & REPEAT COUNT SKIPGE T1,NLFLG. ;DID WE GET A VALUE? POPJ P, ;NO. LEAVE JUMPE T1,NULVAL ;JUST DECR REPEAT COUNT IF NULL MOVE T1,VARTYP ;GET VARIABLE TYPE CAME T1,CNVTYP ;DID WE CONVERT YET? PUSHJ P,NLACNV ;NO. CONVERT TO DESIRED FORMAT DMOVE T1,NLCVL. ;LOAD THE VALUE MOVE T3,NLSIZ. ;MAKE SURE WE STORE IT RIGHT XCT NLSTOR(T3) NULVAL: SETOM NLFV. ;FILLED A VARIABLE PUSHJ P,NLRPI ;PROCESS VALUE PNTR/COUNTS MOVE T1,NLINC. ;INCR ARRAY POINTER ADDM T1,NLADD. SOSLE NLNUM. ;DECR COUNT JRST NLP ;LOOP IF MORE POPJ P, ;NLSTOR - A LITTLE TABLE USED TO STORE THE FINAL VALUES ;INTO THE USER'S VARIABLES. IT IS INDEXED BY THE ENTRY SIZE ;(EITHER 1 OR 2) EXTRACTED FROM %SIZTB. THIS WILL ABSOLUTELY ;NOT WORK FOR A KA-10!!! NLSTOR: JFCL MOVEM T1,@NLADD. DMOVEM T1,@NLADD. ;NLSCV - NAMELIST AND LDIO SCAN FOR A VALUE ; ;THIS ROUTINE SCANS FOR A VALUE AND REPEAT COUNT ;IT BEGINS ITS SCAN IN DOUBLE PRECISION, SO THAT NO ;PRECISION WILL BE LOST IF SOMEWHERE TOWARD THE END OF ;A LIST WE FIND A VARIABLE WHICH IS DOUBLE PRECISION ;WHICH IS STILL COVERED BY A DATA REPEAT COUNT. ;IF "*" FOUND AS DELIMITER, SET THE REPEAT COUNT, ;AND SCAN AGAIN IN DOUBLE PRECISION. ;IF "*" NOT FOUND, SET REPEAT COUNT TO 1 AND RETURN WITH ;VALUE=VALUE FOUND. NLSCV: SETZM NLRP. ;CLEAR THE REPEAT COUNT MOVEI T1,TP%DPR ;SCAN FIRST FOR D.P. MOVEM T1,TOTYPE MOVEI T1,1 ;SET REPEAT COUNT TO 1 MOVEM T1,NLRP. ;MIGHT FILL NLRP. IN SETNUL PUSHJ P,NLSCAN ;SCAN FOR VALUE SKIPG NLFLG. ;LEAVE IF END DATA OR NULL POPJ P, ;OH, WELL PUSHJ P,NLSDER ;NO. GET THE DELIMITER CAIE T1,"*" ;REPEAT COUNT? POPJ P, ;NO. LEAVE MOVE T1,VALTYP ;GET THE VALUE TYPE CAIN T1,TP%DPR ;DOUBLE REAL? SKIPE IO.INF ;YES. ANY "." OR EXPONENT JRST RPERR ;NOT REAL OR DOT/EXP FOUND MOVEI T1,TP%INT ;YES. CONVERT TO INTEGER MOVEM T1,TOTYPE PUSHJ P,NLCNV ;DO THE CONVERSION MOVE T1,NLCVL. ;GET THE CONVERTED VALUE JUMPL T1,RPERR ;ERROR IF NEGATIVE MOVMM T1,NLRP. ;SAVE THE REPEAT COUNT MOVEI T1,TP%DPR ;D.P. AGAIN MOVEM T1,TOTYPE PUSHJ P,SKPCHR ;SKIP THE * SETZM NLFV. ;DON'T SKIP A COMMA PJRST NLSCAN ;GO GET NEXT VALUE ;THE FOLLOWING CODE SHOULD BE SUBSTITUTED FOR ; PUSHJ P,SKPCHR ; PJRST NLSCAN ;ABOVE, IFTHE ANSI COMMITTEE DECIDES EVENTUALLY THAT 3*4 SHOULD ;BE READ AS 3*,4 (3 NULL VALUES, THEN A 4). AS OF NOW, THE ;COMMITTEE'S PRELIMINARY DECISION HAS BEEN TO ALLOW BOTH ;INTERPRETATIONS. MUCH OF THE INDUSTRY, AS WELL AS ;PDP-11 AND VAX FORTRAN-77, READ THE BLANK AS A VALUE SEPARATOR, ;AND, THEREFORE, AS 3*,4. REPEAT 0,< PUSHJ P,GETCHR ;GET THE NEXT CHAR PUSHJ P,CHKDLM ;CHECK FOR NON-BLANK CHAR PJRST NLSCAR ;AND GET THE VALUE >;END REPEAT 0 RPERR: ;IOERR (RPE,799,521,?,Illegal repeat count,,%ABORT) $ECALL RPE,%ABORT ;NLSCAN - SCAN FOR AN INDIVIDUAL VALUE ;CNVTYP IS SET FOR NO CONVERSION DONE YET, SO THAT THE TEST IN ;NLMAIN WILL FORCE A CONVERSION TO THE APPROPRIATE TYPE. ;THE FIRST CHARACTER OF DATA IS CHECKED FOR ITS VALIDITY ;BY MATCHING ITS ASSOCIATED FLAG (IN P1) AGAINST THE "VALID FIRST CHARACTER ;FLAG LIST" (NLFLST). IF THERE IS NO MATCH, IT IS EITHER A BAD CHARACTER ;IN DATA OR THE BEGINNING OF THE NEXT VARIABLE NAME (NAMELIST ONLY). ;THAT TEST IS DONE BY SETNUL. NLSCAN: SKIPE DLFLG. ;ARE WE AT END OF PREVIOUS DATA SCAN? PUSHJ P,NLSDEL ;YES. SCAN FOR THE DELIMITER PUSHJ P,NLNB ;GET NEXT NON-BLANK CHAR NLSCAR: SETOM CNVTYP ;SET NO CONVERSION DONE YET SKIPG NLFLG. ;NON-NULL VALUE FOUND? POPJ P, ;NO. LEAVE PUSHJ P,SGNTST ;TEST FOR SIGN MOVEI T2,NLFLST ;GET FLAG LIST FOR SCAN PUSHJ P,NLFSRH ;SCAN THE LIST TXNN P1,NLSFLG ;FOUND? JRST SETNUL ;NO. TRY FOR NEW VARIABLE MOVEI P2,(T2) ;COPY INDEX TO TABLES PUSHJ P,%IBACK ;MOVE PNTR BACK TO 1ST CHAR DSETZM NLVAL. ;INIT LOW VALUE WORDS SETOM DLFLG. ;SET FLAG TO SCAN FOR DELIM XMOVEI T1,NLVAL. ;GET ADDR TO STORE RESULT MOVEM T1,IO.ADR ;SAVE IT MOVE T3,TOTYPE ;GET TYPE OF VARIABLE MOVE T1,NLTYPE(P2) ;GET TYPE MOVEM T1,VALTYP ;SAVE IT MOVEM T1,IO.TYP ;SAVE TYPE FOR I/O ROUTINE MOVE T1,NLSUB(P2) ;GET PROPER SUBR ADDR PUSHJ P,(T1) ;DO READ PUSHJ P,GETDEL ;GET THE DELIMITER, SET FLAGS TDNE P1,LDLFLG ;LEGAL DELIMITER AT END OF SCAN? POPJ P, ;YES $ECALL ILC,%ABORT ;NO. ILLEGAL CHAR ;CHECK FOR THE VALIDITY OF THE PRESENCE OF A VARIABLE NAME. ;THIS IS THE ONLY PLACE IN THE CODE WHERE WE HAVE TO CHECK EXPLICITLY ;WHETHER WE ARE DOING NAMELIST OR LIST-DIRECTED I/O. A VARIABLE NAME ;IN THE DATA IS CLEARLY ILLEGAL IN LIST-DIRECTED I/O, AND IS ILLEGAL ;IF IT FOLLOWS DIRECTLY AFTER THE LAST "VARIABLE=" SEQUENCE, THAT IS, ;BEFORE A VARIBLE HAS BEEN FILLED WITH ANY DATA. ;WE USE A SPECIAL LOCATION - NLVFC. (NAMELIST VARIABLE 1ST CHAR) ;WHICH HAS THE FLAGS ALLOWED FOR THE FIRST CHARACTER OF A VARIABLE. ;FOR NAMELIST, THIS IS SET TO "ALFLAG" TO INDICATE THAT VARIABLE ;NAMES MUST START WITH ALPHABETIC CHARACTERS. IT IS SET TO ;ZERO FOR LIST-DIRECTED I/O TO INDICATE THAT VARIABLE NAMES ARE ;NOT ALLOWED FOR LIST-DIRECTED I/O. ;IF EVERYTHING IS LEGAL, THE REST OF THE DATA IS SET TO NULL, ;THAT IS, THE DATA FLAG IS SET TO ZERO (INDICATING A NULL) AND THE ;DATA REPEAT COUNT IS SET TO THE LEFTOVER ARRAY ENTRY COUNT. SETNUL: TDNE P1,NLVFC. ;THIS CHARACTER ALLOWED? SETNL1: SKIPN NLFV. ;VARIABLE FILLED YET? $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" SETZM NLFLG. ;SET FLAG FOR NULL VALUE MOVE T1,NLNUM. ;GET # ELEMENTS LEFT MOVEM T1,NLRP. ;SET FOR REST OF ARRAY POPJ P, ;SIGN TEST - ACCUMULATES THE SIGN IN FRONT OF A DATA ELEMENT ;AND STUFFS IT AWAY IN NLSGN. ALTHOUGH THE ANSI STANDARD DOESN'T ;ALLOW IT, WE HERE ALLOW MULTIPLE SIGNS (AND DO THE "APPROPRIATE" ;THING, SO THAT --++--- COMES OUT JUST A SINGLE MINUS). ;HOWEVER, IS IS QUITE IMPORTANT THAT A TEST BE PERFORMED AFTER ;A SIGN IS FOUND - THAT A VALID CHARACTER IS FOUND AFTER IT ;FOR THE FIRST CHARACTER OF DATA. SO WE CALL NLFSRH WITH ;THE VALID CHARACTER FLAG LIST, AND GIVE AN ERROR IF THERE IS ;NO CHARACTER FLAG MATCH. SGNTST: MOVEI T2,1 ;+=1, -=-1 MOVEM T2,NLSGN. TXNN P1,SGNFLG ;IS THE CHAR A SIGN? JRST SGNEND ;NO. MOVE BACK PNTR SGNLP: CAIN T1,"-" ;IS IT A MINUS? MOVNS NLSGN. ;YES. NEGATE THE SIGN PUSHJ P,GETCHR ;SKIP THE CHAR PUSHJ P,NLNBER ;GET THE NEXT NON-BLANK SKIPG NLFLG. ;NULL VALUE? ; IOERR (SNV,799,522,?,Sign with null value,,%ABORT) $ECALL SNV,%ABORT TXNE P1,SGNFLG ;ANOTHER SIGN? JRST SGNLP ;YES. GO TEST IT MOVEI T2,NLFLST ;NO. CHECK IN VALID DATA LIST PUSHJ P,NLFSRH TXNN P1,NLSFLG ;MATCH? $ECALL SNV,%ABORT ;Sign with null value SGNEND: POPJ P, ;NLFSRH - FLAG MATCH SEARCH - THIS SEARCHES A LIST OF ;FLAGS (ADDR SPECIFIED IN T2) FOR A MATCH (LOGICAL ;INTERSECTION) WITH THE FLAGS IN P1, AND PROVIDES THE MATCHING ;INDEX. NLFSRH: MOVEI T3,(T2) ;SAVE THE LIST PNTR NLFLP: SKIPN (T2) ;DONE WITH LIST? JRST NLNFND ;YES. LEAVE TDNN P1,(T2) ;NO. FLAG MATCH? AOJA T2,NLFLP ;NO. TRY AGAIN TXO P1,NLSFLG ;YES. SET FOUND FLAG NLNFND: SUBI T2,(T3) ;GET RELATIVE INDEX POPJ P, ;NLCNV - VALUE CONVERSION ROUTINE ;DECIDES WHICH CONVERSION TO DO BY RETRIEVING A CONVERSION ;TABLE ADDR INDEXED BY THE VALUE TYPE, THEN SEARCHES IN THE ;TABLE FOR THE VARIABLE TYPE, AND CALLS THE CORRESPONDING ;CONVERSION ROUTINE. ;NOTE THAT FOR MOST OF THE VALUE/VARIABLE TYPES, WE SIGNAL ;THAT THE CONVERSION HAS BEEN DONE BY PLACING THE CONVERTED TYPE ;IN CNVTYP. FOR ALPHAMERIC CONSTANTS, THIS CANNOT BE DONE, SINCE ;STRING DATA HAS A DIFFERENT SOURCE/REPEAT COUNT MECHANISM THAN ;THE THE OTHER DATA TYPES. NLACNV: SKIPN T1,VARTYP ;RECORD VARIABLE TYPE MOVEI T1,TP%INT ;DEFAULT IS INTEGER MOVEM T1,TOTYPE NLCNV: MOVE T2,TOTYPE ;GET TYPE DESIRED CAMN T2,CNVTYP ;SAME AS LAST CONV? POPJ P, ;YES. FORGET IT DSETZM NLCVL. ;INIT CONVERTED VALUES MOVE T3,VALTYP ;GET VALUE TYPE CAIE T3,TP%LIT ;DON'T SIGNAL CONV IF ALPHA MOVEM T2,CNVTYP ;BUT DO IF ANYTHING ELSE MOVE T1,CNVLST(T3) ;GET CONVERSION LIST ADDR/COUNT JUMPGE T1,BADCNV ;NO CONVERSION! CNVLP: HLRE T2,(T1) ;GET A "TO" TYPE JUMPL T2,GOTCNV ;A MATCH IF NEGATIVE CAME T2,TOTYPE ;DESIRED TYPE? AOBJN T1,CNVLP ;NO. TRY AGAIN JUMPGE T1,BADCNV ;A LOSER IF TABLE GONE GOTCNV: HRRZ T1,(T1) ;GET THE CONV ADDR PUSHJ P,(T1) ;DO THE CONVERSION SKIPL NLSGN. ;WAS IT MINUS? POPJ P, ;NO DMOVN T1,NLCVL. DMOVEM T1,NLCVL. ;YES. SAVE IT NEGATIVE POPJ P, ;NLNB - SCAN FOR NON-BLANK ;SKIPS BLANK-TYPE CHARS, RETURNS ON ANY OTHER CHARACTER ;(EXCEPT SKIPS END-OF-LINE ALTOGETHER) ;RETURNS -1 IF END OF DATA, 0 IF NULL, & 1 IF ;NON-NULL NLNB: PUSHJ P,GETDEL ;GET CURRENT CHAR SKIPE NLFV. ;DON'T SKIP FIRST COMMA TXNN P1,COMFLG ;COMMA TO SKIP? TXNE P1,EOLFLG ;ARE WE AT EOL? PUSHJ P,SKPCHR ;YES. SKIP IT SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG SETOM NLFLG. ;SET FLAG FOR EOF JRST NLNB1 ;Go to loop, got first character NLNB0: PUSHJ P,GTCHRL ;Get next char, skip eor NLNB1: PUSHJ P,BERSCN ;Process character POPJ P, ;Done, return JRST NLNB0 ;Loop until done. ;NLNBER - SPECIAL SCAN FOR USE WITH THE REPEAT COUNT. ;THIS SCAN IS LIKE NLNB, BUT IT STOPS ;AT END OF RECORD (THAT IS, IT USES GETCHR INSTEAD OF GTCHRL). NLNBER: SETZM DLFLG. ;CLEAR THE SCAN FOR DELIM FLAG SETOM NLFLG. ;SET FLAG FOR EOF PUSHJ P,GETDEL ;GET LAST DELIM JRST NLNBR1 ;Already got first char. NLNBR0: PUSHJ P,GETCHR ;Get character, possibly EOL NLNBR1: PUSHJ P,BERSCN ;Process character POPJ P, ;Done, return JRST NLNBR0 ;Loop ;Return .+1 if done, .+2 if need more characters. BERSCN: TDNE P1,FINFLG ;EOF OR END OF DATA? POPJ P, ;YES. LEAVE TXNN P1,COMFLG+EOLFLG ;COMMA OR EOL? JRST NOTCEL ;NO SETZM NLFLG. ;SET FOR COMMA OR EOR POPJ P, NOTCEL: TXNE P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL? JRST %POPJ1 ;Yes, skip them MOVEI T2,1 ;NO. SET FLAG FOR DATA MOVEM T2,NLFLG. POPJ P, ;NLEOL - SCAN FOR END OF RECORD (OR END OF FILE) NLEOL: PUSHJ P,GETCHR ;GET A CHAR TXNN P1,EOLFLG ;GO UNTIL EOL JRST NLEOL POPJ P, ;CHKDLM - CHECKS THE DELIMITER WE ARE CURRENTLY LOOKING AT ;AND TREATS IT LIKE WE WERE DOING A FULL SCAN, SETTING NLFLG. ;TO -1 IF END DATA, ZERO IF NULL, SPACE, EOL, OR COMMA, AND ;+1 IF OTHER CHAR CHKDLM: SETOM NLFLG. ;INIT FOR END OF DATA TDNE P1,FINFLG ;END OF DATA? POPJ P, ;YES. LEAVE SETZM NLFLG. ;NO. PREPARE FOR NULL ITEM TXNN P1,COMFLG+SPCFLG+NULFLG ;NULL ITEM? AOS NLFLG. ;NO. SET FOR NON-NULL POPJ P, ;NLSDEL - SCAN FOR A DELIMITER ;STARTS SCANNING WITH THE CURRENT CHAR (VIA GETDEL). NLSDEL: PUSHJ P,GETDEL ;GET CURRENT CHAR TXNE P1,EOLFLG ;ARE WE AT EOL? PUSHJ P,SKPCHR ;YES. SKIP TO NEXT LINE SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG JRST NLSDL1 ;Go start loop NLSDL0: PUSHJ P,GTCHRL ;Get a character NLSDL1: TDNN P1,FINFLG ;EOF OR END OF DATA? TXNE P1,COMFLG ;OR COMMA POPJ P, ;YES. LEAVE TXNE P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL? JRST NLSDL0 ;YES. SKIP IT POPJ P, ;NLSDER - SCANS FOR A DELIMITER, BUT STOPS AT END OF RECORD NLSDER: PUSHJ P,GETDEL ;GET THE LAST DELIM NLSDRL: TDNN P1,FINFLG ;EOF OR END OF DATA? TXNE P1,EOLFLG ;END OF RECORD? POPJ P, ;YES. LEAVE TXNE P1,COMFLG+EOLFLG ;OR, COMMA OR EOL? JRST DELOFF ;YES. GOT DELIM TXNN P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL? JRST DELOFF ;NO. GOT DELIM PUSHJ P,GETCHR ;Get character, (could get eol) JRST NLSDRL ;Loop DELOFF: SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG POPJ P, ;NLGETB - GET THE BEGINNING OF THE NAMELIST - ALL ;NAMELIST DATA SHOULD BEGIN WITH A "$" OR "&" IN COLUMN 2 ;OF THE "CARD" (IBM STRIKES AGAIN!). NLGETB: PUSHJ P,%RPOS ;GET CURRENT POSITION CAILE T1,2 ;WILL NEXT CHAR BE COL 2 OR LESS? JRST GTNREC ;NO. GET NEXT RECORD MOVEI T1,2 ;GET FROM POSITION 2 PUSHJ P,%SPOS ;SET IT PUSHJ P,GETCHR ;GET IT TXNE P1,NLEFLG ;NAMELIST BEG/END FLAG? POPJ P, ; YUP GTNREC: PUSHJ P,%IREC ;NO. GO TO NEXT LINE JRST NLGETB ;NO ;GETDEL - GETS THE CURRENT CHARACTER AND GOES TO SET THE FLAGS ;ASSOCIATED WITH THAT CHARACTER. ; ;GETCHR - GETS THE NEXT CHARACTER AND GOES TO SET FLAGS. GETDEL: PUSHJ P,%IBYTC ;GET CURRENT CHAR JRST NLTST ;GO TEST IT GETCHR: IFN FTNLC1,< MOVE T0,FLAGS(D) TXNN T0,D%NML ;THIS TEST ONLY IF NMLST JRST GTCLSD ;NOT PUSHJ P,%RPOS ;GET CHAR POS CAIGE T1,2 ;SKIP IF .GE. 2 PUSHJ P,%IBYTE ;GET A CHAR > ;END FTNLC1 GTCLSD: PUSHJ P,%IBYTE ;GET A CHAR NLTST: SETZ P1, ;CLEAR FLAGS MOVE T0,FLAGS(D) TXNE T0,D%EOR ;END OF LINE? TXO P1,EOLFLG ;YES. SET FLAG NLNEOF: JUMPE T1,NULFST ;SET NULL FLAG IF NULL CAIN T1,11 ;TAB CHAR? TXO P1,SPCFLG ;YES. SET SPACE FLAG CAIGE T1,40 ;CONTROL CHAR? POPJ P, ;YES. LEAVE CAIG T1,100 ;COULD IT BE ALPHA? JRST NOTALP ;NO CAIG T1,"z" ;UPPER OR LOWER ALPHA? CAIGE T1,"a" CAIG T1,"Z" CAIGE T1,"A" POPJ P, ;NO TXO P1,ALFLAG ;YES. SET FLAG CAIE T1,"T" ;T OR F SETS LOGFLG CAIN T1,"t" TXO P1,LOGFLG CAIE T1,"F" CAIN T1,"f" TXO P1,LOGFLG POPJ P, NOTALP: TDOA P1,NLCFLG-40(T1) ;SET CHAR FLAG NULFST: TXO P1,NULFLG ;SET NULL FLAG POPJ P, ;GTCHRL - GETS THE NEXT CHARACTER, AUTOMATICALLY GOING ON ;TO THE NEXT RECORD IF END-OF-RECORD IS REACHED. ; ;SKPCHR - IDENTICAL ENTRY TO GTCHRL, USED FOR ITS MNEMONIC VALUE SKPCHR: GTCHRL: MOVE T0,FLAGS(D) TXNN T0,D%EOR ;END OF RECORD ALREADY? JRST GTCHR1 PUSHJ P,%IREC ;YES. GET NEXT LINE GTCHR1: PUSHJ P,GETCHR ;GET A CHAR TESTL: TDNE P1,FINFLG ;END OF DATA? POPJ P, ;YES. LEAVE TXNE P1,EOLFLG ;END OF LINE? JRST NULCHR ;Yes, return a null char JUMPE T1,GTCHRL ;SKIP IT IF NULL POPJ P, NULCHR: SETZ P1, ;CLEAR FLAGS TXO P1,NULFLG ;CREATE A NULL SETZ T1, ;RETURN A NULL POPJ P, ;NLRPI - REPEAT COUNT INCREMENT ROUTINE ;IF THE DATA IS AN ASCII STRING, THERE IS A COUNT AND PNTR ARRAY ;ASSOCIATED WITH THAT STRING. ;IF THERE IS A REPEAT COUNT IN ADDITION, WE ONLY DECREMENT IT ;WHEN THE STRING IS EXHAUSTED, THAT IS, WHEN THE COUNT IS 0. NLRPI: SKIPN NLLTOT ;DO WE HAVE A STRING COUNT? JRST DECRP ;NO. JUST DECR REPEAT COUNT PUSHJ P,NLINAD ;GO INCR STRING PNTR MOVE T1,NLSIZ. ;ADD THE VARIABLE SIZE ADDB T1,NLTTOT ;TO THE TEMP COUNT CAMGE T1,NLLTOT ;STRING EXHAUSTED? POPJ P, ;NO SETZM NLTTOT ;CLEAR TEMP COUNT SETZM NLTIDX ;RESET INDEX MOVE T1,NLLPNT ;GET PNTR TO 1ST ENTRY MOVEM T1,NLTPNT ;SAVE IT MOVE T1,NLLCNT ;SAME WITH COUNT MOVEM T1,NLTCNT DECRP: SOSG NLRP. ;DECR REPEAT COUNT SETZM NLLTOT ;CLEAR STRING COUNT IF 0 POPJ P, NLINAD: MOVE T1,NLSIZ. ;GET SIZE OF VARIABLE NLINLP: CAMG T1,NLTCNT ;.GT. CURRENT WORD COUNT? JRST NLINOK ;NO SUB T1,NLTCNT ;GET # WORDS LEFT AOS T3,NLTIDX ;INCR INDEX TO PNTRS SKIPN T2,NLLPNT(T3) ;ANY MORE STRING POPJ P, ;NO MOVEM T2,NLTPNT ;UPDATE THE TEMP PNTR MOVE T2,NLLCNT(T3) ;AND THE COUNT MOVEM T2,NLTCNT JRST NLINLP ;AND TRY AGAIN NLINOK: ADDM T1,NLTPNT ;UPDATE THE TEMP PNTR MOVNI T1,(T1) ;MAKE NEGATIVE ADDM T1,NLTCNT ;AND ADD TO COUNT POPJ P, ;NLFLST IS THE LIST OF FLAGS ASSOCIATED WITH THE CHARACTERS ;WHICH ARE LEGAL FOR THE FIRST CHARACTER OF A DATA STRING. ;THE SUBROUTINE NLFSRH CHECKS THE FLAGS ASSOCIATED WITH ;THE FIRST CHARACTER OF A DATA STRING AND MATCHES THEM ;AGAINST THE FLAGS IN THIS LIST. THE MATCH LOCATION PROVIDES ;AN INDEX INTO NLTYPE, WHICH PROVIDES A TYPE SPECIFICATION ;(AT LEAST A GUESS...) FOR THE DATA STRING, AND INTO ;NLSUB, WHICH PROVIDES THE SUBROUTINE ADDRESS FOR PROCESSING ;THE DATA STRING. TWO OF THE SUBROUTINES (TDBL AND LOGI) ARE ;ACTUALLY "TRIAL" SUBROUTINES - THEY TRY TO DO THE ACTION ;INDICATED BY THE CHARACTER, BUT MAY END UP DOING SOMETHING ;VERY DIFFERENT INDEED. (FOR GREATER DETAIL, SEE COMMENTS ATTACHED ;TO THOSE SUBROUTINES). NLFLST: DIGFLG ;DIGIT PNTFLG ;PERIOD LOGFLG ;LOGICAL CHAR (T OR F) SQFLAG ;SINGLE QUOTE DQFLAG ;DOUBLE QUOTE LPRFLG ;LEFT PAREN 0 NLTYPE: TP%DPR TP%DPR ;INITIALLY ASSUME PERIOD IS D.P. TP%LOG ;INITIALLY ASSUME T OR F IS LOGICAL TP%LIT TP%DPO TP%CPX NLSUB: %GRIN TDBL LOGI ALPHI OCTI CPXI ;THIS IS THE CONVERSION TABLE LIST. ;THE ENTRY POSITION IS DETERMINED BY THE VALUE TYPE. THE LEFT HALF GIVES THE ;NEGATIVE # OF ENTRIES IN THE APPROPRIATE CONVERSION TABLE ;AND THE RIGHT HALF CONTAINS THE ADDRESS OF THE CONVERSION TABLE CNVLST: 0 ;0 - NO TYPE LOGCNV-LOGEND,,LOGCNV ;1 - LOGICAL 0 ;2 - INTEGER 0 ;3 - 0 ;4 - SINGLE REAL 0 ;5 - OCTCNV-OCTEND,,OCTCNV ;6 - SINGLE OCTAL 0 ;7 - LABEL DRCNV-DREND,,DRCNV ;10 - DOUBLE REAL 0 ;11 - DOUBLE INTEGER OCTCNV-OCTEND,,OCTCNV ;12 - DOUBLE OCTAL 0 ;13 - EXTENDED DOUBLE REAL CPXCNV-CPXEND,,CPXCNV ;14 - COMPLEX 0 ;15 - COBOL BYTE STRING 0 ;16 - CHARACTER ALPCNV-ALPEND,,ALPCNV ;17 - ASCIZ ;NLCFLG IS THE TABLE OF CHARACTER FLAGS. IF A CHARACTER IS WITHIN ;THE RANGE 40-100, THE CHARACTER TESTING ROUTINE NLTST GETS ;THE FLAG ASSOCIATED WITH THAT CHARACTER BY USING THE CHARACTER AS ;AN INDEX INTO THIS TABLE. NLCFLG: SPCFLG ;SPACE:40 0 ;!:41 DQFLAG ;":42 NSFLAG ;#:43 DOLFLG ;$:44 0 ;%:45 AMPFLG ;&:46 SQFLAG ;':47 LPRFLG ;(:50 RPRFLG ;):51 ASTFLG ;*:52 PLSFLG ;+:53 COMFLG ;COMMA:54 MINFLG ;-:55 PNTFLG ;PERIOD:56 SLHFLG ;/:57 DIGFLG ;0:60 DIGFLG ;1:61 DIGFLG ;2:62 DIGFLG ;3:63 DIGFLG ;4:64 DIGFLG ;5:65 DIGFLG ;6:66 DIGFLG ;7:67 DIGFLG ;8:70 DIGFLG ;9:71 COLFLG ;COLON:72 SEMFLG ;SEMI:73 LABFLG ;<:74 EQUFLG ;=:75 RABFLG ;>:76 0 ;?:77 ATFLAG ;@:100 ;THESE ARE THE CONVERSION TABLES. FOR EACH TYPE OF VALUE ;(OCT, LOG, DR, CPX, ALP) THERE IS AN ASSOCIATED TABLE WHICH ;GIVES, FOR EACH TYPE OF VARIABLE, THE APPROPRIATE CONVERSION ;ROUTINE ADDRESS. IN EACH TABLE THE VARIABLE TYPE IS IN THE LEFT ;HALF OF THE WORD AND THE APPROPRIATE CONVERSION ROUTINE ADDRESS ;IS IN THE RIGHT HALF. -1 IN THE LEFT HALF MEANS THAT THE ADDRESS ;IN THE RIGHT HALF IS THE ONE FOR THE ;CONVERSION ROUTINE FOR ALL VARIABLE TYPES (THIS IS TRUE FOR OCTAL ;AND LOGICAL DATA, FOR WHICH THERE IS REALLY NO CONVERSION). LOGCNV: -1,,DRDR LOGEND==. DRCNV: TP%LOG,,DRLOG TP%INT,,DRINT TP%SPR,,DRSR TP%DPR,,DRDR TP%DPX,,DRDPX TP%CPX,,DRCPX DREND==. CPXCNV: TP%LOG,,CPXLOG TP%INT,,CPXINT TP%SPR,,CPXSR TP%DPR,,CPXDR TP%DPX,,CPXDPX TP%CPX,,CPXCPX CPXEND==. ALPCNV: TP%LOG,,ALPLOG TP%INT,,ALPINT TP%SPR,,ALPSR TP%DPR,,ALPDR TP%DPX,,ALPDR TP%CPX,,ALPCPX ALPEND==. OCTCNV: TP%LOG,,DRDR TP%INT,,DRDR TP%SPR,,DRSR TP%DPR,,DRDR TP%DPX,,DRDR TP%CPX,,DRDR OCTEND==. ;THESE ARE THE ACTUAL DATA CONVERSION ROUTINES (BINARY TO ;BINARY FORM). NOTE THAT A "CONVERSION" NEVER DESTROYS ;THE ORIGINAL DATA OR ITS TYPE, BUT MERELY PUTS THE CONVERTED ;VALUE INTO NLCVL. THESE ROUTINES ASSUME THAT ;NLCVL/NLCVL.+1 HAVE BEEN INITIALIZED TO 0 AND THAT NLVAL./NLVAL.+1 ;WERE INITIALIZED TO 0 BEFORE DATA WAS READ, SO THAT SINGLE ;PRECISION DATA (LOGIC) WILL YIELD 0 IN NLVAL.+1. CPXDR: DRDR: DMOVE T1,NLVAL. DMOVEM T1,NLCVL. POPJ P, CPXLOG: SKIPN NLINFO ;INFO FROM REAL PART NON-ZERO? JRST CPXINT ;YES. CONVERT TO INTEGER ;ELSE DROP INTO DRSR CPXSR: DRCPX: DRSR: DMOVE T1,NLVAL. ;GET VALUE FOUND PUSHJ P,DSING MOVEM T1,NLCVL. POPJ P, CPXINT: DMOVE T2,NLRFR ;GET SAVED RAW FRACTION MOVE T4,NLRBX ;AND BINARY EXPONENT JRST XINT ;JOIN DRINT CODE DRINT: DMOVE T2,FL.RFR ;GET LEFT-JUSTIFIED FRACTION MOVE T4,FL.RBX ;GET BINARY EXPONENT JUMPLE T4,NOINT ;ZERO IF EXP .LE. 0 XINT: SETZ T1, ;CLEAR INTEGER CAILE T4,^D35 ;WILL WE SHIFT TO OBLIVION? JRST INTOVL ;YES. RETURN OVERFLOW TLNN T3,(1B1) ;HI BIT IN LOW WORD ON? JRST NORND ;NO CAME T2,[377777,,777777] ;ABOUT TO OVERFLOW? AOJA T2,NORND ;NO, ROUND UP MOVSI T2,200000 ;YES. LOAD A HIGH BIT AOJA T4,NORND ;AND INCR BIN EXP NORND: LSHC T1,1(T4) ;SHIFT INTO INTEGER JUMPL T1,STOINT ;NO NEGATE IF BIT 0 SET SKIPGE NLVAL. ;NEGATIVE? MOVN T1,T1 ;YES. NEGATE IT STOINT: MOVEM T1,NLCVL. ;STORE IT NOINT: POPJ P, INTOVL: HRLOI T1,377777 ;RETURN LARGEST NUMBER MOVEM T1,NLCVL. $ECALL IOV ;%integer overflow POPJ P, DRLOG: SKIPN IO.INF ;ANY DOT OR EXPONENT? JRST DRINT ;NO. CONVERT TO INTEGER VALUE JRST DRSR ;YES. CONVERT TO SINGLE CPXCPX: DMOVE T1,NLVAL. ;GET VALUE FOUND PUSHJ P,DSING ;CONVERT TO SR MOVEM T1,NLCVL. ;SAVE FOR REAL PART DMOVE T1,NLVL2. ;GET 2ND VALUE FOUND PUSHJ P,DSING ;CONVERT TO SR MOVEM T1,NLCVL.+1 ;SAVE FOR IMAGINARY PART POPJ P, ALPINT: ALPLOG: ALPSR: MOVE T1,SPACES ;MAYBE NULL STRING SKIPE NLTCNT ;IS IT? MOVE T1,@NLTPNT ;NO. GET A WORD MOVEM T1,NLCVL. ;SAVE AS VALUE POPJ P, CPXDPX: DMOVE T1,NLRFR ;GET RAW FRACTION MOVE T3,NLRBX ;AND BINARY EXPONENT JRST CPDD ;JOIN DRDPX CODE DRDPX: DMOVE T1,FL.RFR ;GET RAW FRACTION JUMPE T1,DPXZER ;DO NOTHING WITH ZERO MOVE T3,FL.RBX ;AND BINARY EXPONENT CPDD: TLO T1,(1B0) ;PREVENT OVERFLOW TLO T2,(1B0) ;IN BOTH WORDS ADDI T2,2000 ;ROUND THE LOW WORD TLZN T2,(1B0) ;DID WE OVERFLOW? ADDI T1,1 ;YES. ADD 1 TO HIGH TLZE T1,(1B0) ;OVERFLOW AGAIN? JRST DPXNOV ;NO ASHC T1,-1 ;YES. MOVE RIGHT ADDI T3,1 ;AND MODIFY THE EXPONENT TLO T1,(1B1) ;AND TURN ON THE HIGH BIT DPXNOV: CAIGE T3,2000 ;EXPONENT IN RANGE CAMG T3,[-2000] JRST BADEXP ;NO. RETURN OVER OR UNDER ASHC T1,-^D11 ;MAKE ROOM FOR EXPONENT ADDI T3,2000 ;MAKE IT EXCESS 2000 DPB T3,[POINT 12,T1,11] ;DEPOSIT THE EXPONENT SKIPGE NLVAL. ;IS VALUE NEGATIVE? DMOVN T1,T1 ;YES. GET NEGATIVE DMOVEM T1,NLCVL. ;SAVE IN CONVERTED FORM DPXZER: POPJ P, BADEXP: HRLOI T1,377777 ;LOAD OVERFLOW HIGH HRLOI T2,377777 JUMPG T3,BADDEP ;DONE IF POS EXP SETZB T1,T2 ;ZERO IF EXP NEG BADDEP: DMOVEM T1,NLCVL. ;STORE IN CONVERTED VALUE POPJ P, ALPDR: ALPCPX: DMOVE T1,SPACES ;MAYBE NULL STRING SKIPE NLTCNT ;IS IT? DMOVE T1,@NLTPNT ;NO. GET 2 WORDS DMOVEM T1,NLCVL. ;SAVE IT MOVE T1,NLTCNT ;GET THE COUNT CAILE T1,1 ;ONLY 1 LEFT? POPJ P, ;NO. WE'RE FINE MOVE T2,NLTIDX ;YES. GET CURRENT INDEX ADDI T2,1 ;POINT TO NEXT STRING MOVE T1,SPACES ;IN CASE IT'S NULL SKIPE NLLCNT(T2) ;IS IT NULL? MOVE T1,@NLLPNT(T2) ;NO. GET A WORD MOVEM T1,NLCVL.+1 ;SAVE IT POPJ P, SPACES: ASCII / / BADCNV: ;IOERR (CCC,799,519,?,Can't convert constant to correct type,,%ABORT) $ECALL CCC,%ABORT DSING: CAMN T1,[377777,,777777] ;TOO BIG ALREADY? JRST DSZERO ;YES. DON'T MAKE IT WORSE JUMPL T1,DSNEG ;JUMP IF NEGATIVE TLNE T2,(1B1) ;POSITIVE, ROUNDING REQUIRED? TRON T1,1 ;YES, TRY TO ROUND BY SETTING LSB JRST DSZERO ;IT WORKED, DONE MOVE T2,T1 ;COPY HIGH WORD AND T1,[777000,,1] ;MAKE UNNORMALIZED LSB WITH SAME EXP FADR T1,T2 ;ROUND AND NORMALIZE JRST DSZERO ;DONE DSNEG: DMOVN T1,T1 ;MAKE POSITIVE TLNE T2,(1B1) ;NEED ROUNDING? TRON T1,1 ;YES, TRY TO SET LSB JRST DSNRET ;IT WORKED, DONE MOVE T2,T1 ;COPY HIGH WORD AND T1,[777000,,1] ;MAKE UNNORMALIZED LSB WITH SAME EXP FADR T1,T2 ;ROUND AND NORMALIZE DSNRET: MOVN T1,T1 ;PUT SIGN BACK DSZERO: POPJ P, ;RETURN ;NAMELIST/LDIO MUST HAVE ITS OWN ALPHAMERIC INPUT ROUTINE ;BECAUSE OF THE PROBLEM WITH AN ASSOCIATED REPEAT COUNT, SINCE ;A REPEAT COUNT FORCES US TO KEEP THE ENTIRE STRING AROUND UNTIL ;THE REPEAT COUNT IS EXHAUSTED. THIS ALPHABETIC INPUT ROUTINE ;HAS PROVISION FOR ADDING DYNAMICALLY ALLOCATED MEMORY BEYOND ;THE INITIAL 128 LOCATIONS. SINCE A LIMITED NUMBER OF ;POINTER AND COUNT WORDS ARE AVAILABLE TO KEEP TRACK OF THE ;ALLOCATED CORE, AN INCREASING NUMBER OF ;LOCATIONS ARE REQUESTED EACH TIME WE RUN OUT OF ;CORE (FACTOR OF 2 INCREASE EACH TIME!). SO BY THE TIME ;WE RUN OUT OF POINTER WORDS, 128K HAS BEEN ALLOCATED FOR ;THE ALPHA STRING, WHICH ONE HOPES WOULD BE ENOUGH. ALPHI: SETZ P2, ;INIT STRING ARRAY INDEX SETZM NLLTOT ;CLEAR TOTAL PUSHJ P,SKPCHR ;SKIP THE INITIAL QUOTE ALPHI0: SKIPE NLLCOR(P2) ;ANY CORE ALLOCATED FOR THIS BUFFER? JRST ALPHI1 ;YES MOVEI T1,%ALISZ ;GET INITIAL SIZE LSH T1,(P2) ;* INDEX**2 MOVEM T1,NLLCOR(P2) ;SAVE THE ALLOCATION PUSHJ P,%GTBLK ;ALLOCATE THE CORE MOVEM T1,NLLPNT(P2) ;SAVE THE ADDRESS ALPHI1: MOVE T1,NLLPNT(P2) ;GET THE ADDRESS $BLDBP T1 ;Make it a pntr MOVEM T1,NLTPNT ;SAVE FOR INPUT OF CHARS MOVE T1,NLLCOR(P2) ;GET THE CORE SIZE IMULI T1,5 ;GET # CHARS MOVEM T1,NLTCNT ;AND SAVE IT ALPLP1: PUSHJ P,GTCHRL ;GET A CHAR JUMPE T1,ALPLP1 ;IGNORE NULLS CAIE T1,"'" ;SINGLE QUOTE? JRST NOTQUO ;NO PUSHJ P,GTCHRL ;YES. GET ANOTHER CAIE T1,"'" ;2ND QUOTE? JRST ENDQUO ;NO NOTQUO: IDPB T1,NLTPNT ;SAVE THE CHAR AOS NLLTOT ;INCR PERM TOTAL SOSLE NLTCNT ;DECR TEMP COUNT JRST ALPLP1 ;BACK FOR MORE MOVE T1,NLLCOR(P2) ;THIS BUFFER IS FILLED MOVEM T1,NLLCNT(P2) CAIGE P2,%ALASZ ;MORE ARRAY ROOM? AOJA P2,ALPHI0 ;YES. ; IOERR (STL,799,520,?,Alpha string too long,,%ABORT) $ECALL STL,%ABORT ENDQUO: ALPFIN: MOVE T1,NLLCOR(P2) ;GET ORIG # CHARS IMULI T1,5 SUB T1,NLTCNT ;GET # CHARS WE GOT IDIVI T1,5 ;GET REMAINDER IN T2 MOVEM T1,NLLCNT(P2) ;SAVE # WORDS JUMPE T2,NLNFIL ;NO FILL IF 0 AOS NLLCNT(P2) ;1 MORE WORD IF REMAINDER SUBI T2,5 ;GET NEG # FILL CHARS MOVEI T1," " ;FILL WITH BLANKS ENDLP: IDPB T1,NLTPNT ;DEPOSIT THE FILL CHAR AOJL T2,ENDLP NLNFIL: MOVE T1,NLLTOT ;GET # CHARS TOTAL ADDI T1,4 ;ROUND UP IDIVI T1,5 ;GET # WORDS MOVEM T1,NLLTOT ;AND SAVE MOVE T1,NLLPNT ;GET 1ST PNTR MOVEM T1,NLTPNT ;SAVE FOR INCR ROUTINE MOVE T1,NLLCNT ;USE 1ST WORD COUNT MOVEM T1,NLTCNT ;AS TEMP INIT SETZM NLLCNT+1(P2) ;NO CHARS IN NEXT BUFFER SETZM NLTIDX ;CLEAR TEMP INDEX SETZM NLTTOT ;AND TEMP TOTAL POPJ P, ;SINCE THERE IS OFFICIALLY NO DIRECT WAY TO READ COMPLEX DATA, ;IT HAS TO BE INVENTED HERE. COMPLEX DATA FOR LIST-DIRECTED I/O ;AND NAMELIST I/O IS DEFINED AS A PARENTHESIZED EXPRESSION ;CONTAINING 2 REAL CONSTANTS, DELIMITED BY A SINGLE COMMA. CPXI: PUSHJ P,SKPCHR ;THROW AWAY "(" PUSHJ P,GTCHRL ;GET NEXT CHAR TXNE P1,DQFLAG ;DOUBLE QUOTE? JRST OCTONE ;YES. GET OCTAL REAL PART PUSHJ P,%IBACK ;THE CHAR BELONGS TO NUMBER PUSHJ P,%GRIN ;GET ONE REAL NUMBER JRST CPXI1 OCTONE: PUSHJ P,OCPXI ;GET OCTAL NUMBER CPXI1: DMOVE T1,FL.RFR ;SAVE RAW FRACTION MOVEM T1,NLRFR MOVE T1,FL.RBX ;AND RAW BINARY EXPONENT MOVEM T1,NLRBX PUSHJ P,NLSDEL ;SCAN FOR DELIM CAIE T1,"," ;WAS IT A COMMA? $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" SETOM NLFV. ;SET TO IGNORE THE COMMA XMOVEI T1,NLVL2. ;GET 2ND DEPOSIT ADDR MOVEM T1,IO.ADR ;SAVE IT PUSHJ P,NLNB ;SCAN FOR NEXT DELIM TXNE P1,DQFLAG ;WAS DELIM DOUBLE QUOTE? JRST OCTTWO ;YES. GET OCTAL IMAG PART PUSHJ P,%IBACK ;NO. BACK UP PNTR FOR GRIN PUSHJ P,%GRIN ;GET 2ND REAL # JRST CPXI2 OCTTWO: PUSHJ P,OCPXI ;GET OCTAL NUMBER CPXI2: PUSHJ P,NLSDEL ;GET 2ND DELIM CAIE T1,")" ;MUST BE A RIGHT PAREN $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA" PJRST SKPCHR ;THROW AWAY ")" OCPXI: PUSHJ P,%OCTI ;GET OCTAL NUMBER MOVE T1,IO.ADR ;GET I/O ADDR DMOVE T1,(T1) ;GET VALUE JUMPGE T1,CPXNN ;NEGATE IF NEGATIVE DMOVN T1,T1 CPXNN: LDB T3,[POINT 9,T1,8] ;GET BINARY EXPONENT MOVEM T3,FL.RBX ;SAVE AS RAW VALUE TLZ T1,777000 ;WIPE OUT EXPONENT ASHC T1,8 ;LEFT-JUSTIFY FRACTION DMOVEM T1,FL.RFR ;SAVE AS RAW FRACTION POPJ P, ;LOGI - LOCAL LOGIC INPUT ROUTINE. ;FOR NAMELIST INPUT, IF THE FIRST CHARACTER OF DATA IS A "T" ;OR "F", WE CANNOT BE SURE IF IT IS DATA OR THE ;NAME OF A NEW VARIABLE OR ARRAY TO FILL. SO WE CALL THE LOGIC ;SCANNER AND GET THE DELIMITER FOUND. IF THE DELIMITER IS ;A "=" OR "(" (WHICH ARE CONSIDERED DELIMITERS ONLY FOR NAMELIST, ;NOT FOR LIST-DIRECTED INPUT, IN THE LOGIC SCANNER), WE CALL ;SETNUL, WHICH CHECKS IF SUCH A SITUATION IS LEGAL AND SETS THE ;REST OF THE DATA DESIRED IN THE CURRENT ARRAY TO NULL ITEMS. ;THEN WE STORE THE 1ST SIX CHARACTERS FOUND BY THE LOGIC SCANNER ;FOR USE AS THE NEXT VARIABLE NAME IN THE NAMELIST. LOGI: PUSHJ P,%LINT ;GET LOGICAL DATA MOVE T0,FLAGS(D) TXNE T0,D%LSD ;LIST-DIRECTED INPUT? POPJ P, ;NO. DON'T SCAN FOR DELIM PUSHJ P,NLSDEL ;GET THE DELIM CAIE T1,"(" ;LEFT PAREN OR CAIN T1,"=" ;EQUAL SIGN? JRST NOTLOG ;OOPS - IT WAS A NEW VARIABLE POPJ P, ;NO. IT REALLY WAS LOGIC NOTLOG: PUSHJ P,SETNL1 ;SET REST OF DATA NULL MOVE T1,IO.INF ;GET DATA ACCUMULATED MOVEM T1,NLNAM. ;USE FOR NEW VARIABLE NAME POPJ P, ;OCTAL INPUT HAS TO THROW AWAY THE INITIAL DOUBLE QUOTE BEFORE ;CALLING THE STANDARD %OCTI ROUTINE OCTI: PUSHJ P,SKPCHR ;SKIP THE QUOTE PJRST %OCTI ;AND GO TO STANDARD ROUTINE ;TDBL - TEST FOR DOUBLE REAL - THIS IS CALLED WHEN WE ENCOUNTER ;A PERIOD AS THE FIRST CHARACTER IN THE DATA. SINCE THE DATA ;FOLLOWING CAN BE EITHER REAL (WE ASSUME DOUBLE REAL) OR LOGIC ;(.TRUE., ETC.), WE TRY CALLING %GRIN. IF THE INFORMATION WORD ;REVEALS THAT THERE WERE NO DIGITS AFTER THE PERIOD (IT WILL STOP ;ON THE NEXT CHARACTER IF IT IS NOT A DIGIT), WE MUST ASSUME THAT ;IT IS LOGIC DATA INSTEAD. THEREFORE WE SET THE DATA TYPE TO LOGIC ;AND CALL THE LOGIC INPUT ROUTINE, WHICH WILL BARF APPROPRIATELY ;IF GARBAGE IS FOUND. TDBL: PUSHJ P,%GRIN ;GET A REAL NUMBER HRRZ T1,IO.INF ;ANY DIGITS AFTER DOT? JUMPG T1,%POPJ ;OK IF YES DSETZM NLVAL. ;NO. RESET VALUE REG PUSHJ P,%IBACK ;MOVE PNTR TO AFTER DOT MOVEI T1,TP%LOG ;AND ASSUME IT'S LOGICAL MOVEM T1,VALTYP PJRST %LINT ;NAMELIST OUTPUT - OUTPUTS ALL VARIABLES AND ARRAYS IN THE ;NAMELIST IN THE ORDER IN WHICH THEY APPEAR IN THE NAMELIST. ;BOTH VARIABLES AND NAMELIST NAMES ARE DELIMITED WITH ;COMMAS. THERE IS NO TRAILING COMMA! %NLO: PUSHJ P,NLINIT ;INITIALIZE STUFF MOVX T0,D%IO+D%NML ;SET FOR NMLST OUTPUT IORM T0,FLAGS(D) MOVEI T1,1 ;SET FOR 1PG OUTPUT MOVEM T1,SCL.SV PUSHJ P,CHKEND ;MAKE SURE COL 1 PUSHJ P,SPCOUT ;ADVANCE TO COL 2 MOVEI T1,"$" ;OUTPUT $ PUSHJ P,PUTCHR MOVE T1,NLARG. ;GET NMLST ADDR MOVEM T1,NLVAR. ;SAVE IT MOVE T1,(T1) ;GET NAMELIST NAME MOVEM T1,NLNAM. ;SAVE FOR OUTPUT PUSHJ P,NLONAM ;OUTPUT IT PUSHJ P,%ORECS ;EOL MOVEI T1,1 ;ADD 1 TO NMLST ADDR ADDM T1,NLVAR. ;TO GET 1ST VARIABLE PNTR NLOLP: SKIPE T1,@NLVAR. ;ANY MORE VARS? CAMN T1,FINCOD ;OR END CODE? JRST NLOEND ;END OF LIST PUSHJ P,VARSET ;SETUP VARIABLE PARAMS MOVEI T1,^D8 ;MAKE ROOM FOR NAME AND "=" MOVEM T1,OSIZE PUSHJ P,PUTCOM ;OUTPUT COMMA, CHECK LINE PUSHJ P,NLONAM ;OUTPUT VARIABLE NAME MOVEI T1,"=" ;OUTPUT = PUSHJ P,PUTCHR SETZM NLFLG. ;AVOID COMMA BEFORE 1ST DATA PUSHJ P,NLMO ;MAIN OUTPUT ROUTINE SETOM NLFLG. ;SET FLAG FOR OUTPUT STARTED MOVEI T1,2 ;ASSUME SCALAR ADDM T1,NLVAR. ;FOR INCR TO NEXT VARIABLE MOVE T1,NLDIM. ;GET # DIMS JUMPE T1,NLOLP ;CORRECT IF SCALAR ADDI T1,1 ;ADD # DIMS +1 IF ARRAY ADDM T1,NLVAR. JRST NLOLP ;BACK FOR MORE NLOEND: PUSHJ P,CHKEND ;EOL PUSHJ P,SPCOUT ;OUTPUT SPACE MOVEI T1,"$" ;OUTPUT $ PUSHJ P,PUTCHR MOVEI T1,"E" ;OUTPUT E PUSHJ P,PUTCHR MOVEI T1,"N" ;OUTPUT N PUSHJ P,PUTCHR MOVEI T1,"D" ;OUTPUT D PUSHJ P,PUTCHR PJRST %ORECS ;EOL AGAIN FINCOD: 4000,,0 ;NAMELIST END CODE ;FOR F10 VERSION 2 AND UP ;NLMO - NAMELIST AND LIST-DIRECTED MAIN OUTPUT ROUTINE. ;OUTPUTS A VARIABLE BY ITS TYPE; CHECKS FOR A REPEATED VALUE; ;IF THE REPEAT COUNT IS 1 IT IS NOT PRINTED. IF THE REMAINING ;NLNUM. IS NON-ZERO, A COMMA IS PRINTED AND THE PROCESS IS ;REPEATED. NLMO: SKIPN NLNUM. ;MAKE SURE THERE'S DATA POPJ P, ;LEAVE IF NONE NLMOLP: MOVE T1,VARTYP ;GET VARIABLE TYPE MOVE T1,OSIZTB(T1) ;GET SIZE OF DATA MOVEM T1,OSIZE ;MAKE ROOM FOR IT PUSHJ P,PUTCOM ;CHECKS CUR POS AND DATA SIZE PUSHJ P,NLCRP ;CHECK FOR A REPEATED VALUE MOVE T1,NLRP. ;GET THE REPEAT COUNT CAILE T1,1 ;IS IT 1? PUSHJ P,NLORP ;.GT.1. OUTPUT WITH * XMOVEI T1,NLVAL. ;POINT TO VALUE MOVEM T1,IO.ADR ;SAVE ADDR MOVE T1,VARTYP ;GET VARIABLE TYPE MOVEM T1,IO.TYP ;SAVE IT PUSHJ P,@OUTSUB(T1) ;OUTPUT THE VALUE SETOM NLFLG. ;SET DATA OUTPUT DONE SKIPE NLNUM. ;ANY MORE? JRST NLMOLP ;YES. BACK FOR MORE POPJ P, ;NO ;NLCRP - ROUTINE TO CHECK FOR A REPEATED VALUE ;PLACES THE (SINGLE OR DOUBLE WORD) VALUE POINTED TO BY ;NLVAL. AND THEN INCREMENTS A LOCAL POINTER AND CHECKS ;THE NEXT ENTRY FOR AN IDENTICAL VALUE; THIS PROCESS IS ;CONTINUED UNTIL A NON-MATCH IS FOUND. THE ADDRESS OF THE ;NON-MATCHING ENTRY IS SAVED IN NLADD., THE NUMBER OF ;REPEATED VALUES IS PLACED IN NLRP., AND NLNUM. IS ;DECREMENTED APPROPRIATELY. ;NOTE THAT THERE IS NO WAY FOR THIS ROUTINE TO CHECK FOR ;VALUES THAT DIFFER BEYOND THE OUTPUT ACCURACY (AND THEREFORE ;PRINT THE SAME), NOR DOES THIS ROUTINE CHECK FOR IDENTICAL ;VALUES ACROSS DIFFERENT VARIABLES. NLCRP: MOVEI T1,1 ;ASSUME REPEAT COUNT OF 1 MOVEM T1,NLRP. SETZ T2, ;CLEAR 2ND VALUE WORD MOVE T3,NLSIZ. ;GET SIZE XCT NLGET(T3) ;GET THE VALUE DMOVEM T1,NLVAL. ;SAVE IT NLCLP: MOVE T1,NLINC. ;INCR ADDR ADDM T1,NLADD. SOSG NLNUM. ;ANY MORE ENTRIES? POPJ P, ;NO. LEAVE SETZ T2, ;CLEAR 2ND VALUE WORD XCT NLGET(T3) ;GET NEXT ENTRY CAMN T1,NLVAL. ;COMPARE CAME T2,NLVAL.+1 POPJ P, ;THEY DIDN'T MATCH AOS NLRP. ;THEY DID. INCR RPT COUNT JRST NLCLP ;AND TRY AGAIN ;NLONAM - OUTPUT A SIXBIT NAME NLONAM: MOVE T1,[POINT 6,NLNAM.] ;GET PNTR MOVEM T1,NLVAL. ;SAVE IT MOVEI T1,6 ;MAX COUNT MOVEM T1,NLRP. ;SAVE IT NLONLP: ILDB T1,NLVAL. ;GET CHAR JUMPE T1,NLONF ;DONE IS 0 ADDI T1,40 ;CONVERT TO ASCII PUSHJ P,PUTCHR ;OUTPUT IT SOSLE NLRP. ;DECR COUNT JRST NLONLP ;BACK FOR MORE NLONF: POPJ P, ;NLORP - OUTPUT REPEAT COUNT AND * NLORP: XMOVEI T1,NLRP. ;GET REPEAT COUNT ADDR MOVEM T1,IO.ADR ;SAVE IT PUSHJ P,%INTO ;OUTPUT IT MOVEI T1,"*" ;OUTPUT * PJRST PUTCHR ;PUTCHK - CHECK LINE - USED FOR DELIMITING DATA ITEMS ;AND VARIABLE NAMES IN THE OUTPUT STREAM. IF THE LINE OF OUTPUT ;IS ABOUT TO BE "TOO LONG" (DEFINED BY TTYW MINUS DATA SIZE ;FOR THE NEXT ITEM) A NEW LINE IS STARTED. PUTCHK: PUSHJ P,%RPOS ;GET CURRENT POSITION ADD T1,OSIZE ;ALLOW ROOM FOR VALUE LOAD T2,TTYW(D) ;GET WIDTH CAIG T1,(T2) ;WOULD IT OVERFLOW WIDTH? AOS (P) ;NO. SKIP RETURN POPJ P, ;PUTCOM - OUTPUT COMMA IF PREV OUTPUT, CHECK FOR LINE-TOO-LONG, AND ;OUTPUT SPACE. PUTCOM: MOVEI T1,"," ;OUTPUT COMMA SKIPE NLFLG. ;ONLY IF PREVIOUS DATA PUSHJ P,PUTCHR PUSHJ P,PUTCHK ;WILL WE OVERFLOW LINE? SPCEOL: PUSHJ P,%ORECS ;YES. OUTPUT EOL SPCOUT: MOVEI T1," " ;PLUS A SPACE PJRST PUTCHR ;CHKEND - TO MAKE SURE THAT WE ARE AT THE BEGINNING OF THE LINE ;WHEN WE OUTPUT THE NAMELIST "BEGIN STRING" - A SPACE ;AND DOLLAR SIGN. ;PUTEND - FORCES OUTPUT OF LAST RECORD AND STARTS NEW LINE CHKEND: PUSHJ P,%RPOS ;GET CURRENT POSITION CAIN T1,1 ;NEW LINE? POPJ P, ; YES, QUIT PJRST %ORECS ;NO, FORCE EOL ;WE HAVE FUNNELED ALL OUTPUT CHARACTER CALLS THROUGH HERE, SO THAT IF SOMEDAY ;SOMEONE WANTS SOMETHING SPECIAL DONE WHICH IS NOT PART OF %OBYTE, IT