SEARCH MTHPRM,FORPRM TV FORNML NAMELIST AND LIST-DIRECTED I/O 11(5012) SUBTTL NAME LIST SEQUENTIAL ACCESS CALLING SEQUENCES - 28-Oct-81 ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987 ;ALL RIGHTS RESERVED. ; ;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. COMMENT \ ***** Begin Revision History ***** 3056 JLC 23-Mar-82 Created from FORCNV.MAC. Changed some global refs. 3057 JLC 25-Mar-82 List-directed and namelist output must clear both encoded words to get free format. 3063 BL 26-Mar-82 Insert NAMELIST character I/O code. 3074 BL 31-Mar-82 Cleanup NAMELIST character I/O stuff[3063]. 3106 BL 12-Apr-82 Enable us to handle substrings of character scalars. 3112 BL 15-Apr-82 Change SKIPN to SKIPE. 3120 BL 19-May-82 Ensure no delimiters after LD character output. 3131 JLC 11-Jun-82 Make more delimiters, namely "=" and "(", legal for NAMELIST I/O, since they can be obtained by abortive call to %LINT (e.g. A(1)=3,TRUE=3). 3133 BL 16-Jun-82 Code review changes for LD/NM character stuff. 3136 JLC 26-Jun-82 Fix G-float bug - namelist and list-directed I/O were requesting input of a value of type DP%DPR, so got overflow when outside the normal range but legal for GFLOAT. 3150 JLC 13-Jul-82 Fix output of integer 0, was calling %INTO, should have been calling %GINTO. 3154 JLC 20-Jul-82 Fix G-floating list-directed input. 3164 BL 27-Aug-82 NAMELIST bug...DECRP was not resetting input string count (NLSWRD). Sometimes resulted in incorrect input string byte pointers (NLSPTR/NLCPTR). 3250 JLC 7-Jan-83 Support list-directed output of Hollerith literals. ***** End V7 Development ***** 3272 BL 17-Feb-83 Change SOSGE to SOSG at NLCSTR. we were checking for one-too-many character strings in NAMELIST output. sometimes caused infinite looping. 3307 TGS 15-Apr-83 SPR:20-19101 LDELEM must check for line overflow before calling %OMBYT. Other- wise the count of free bytes may go negative, causing MOVSLJ to die with an ?Illegal instruction, or the output may be prematurely truncated. Also save a few more ACs around LDCHLP's call to SPCEOL. ***** Begin Version 10 ***** 4005 JLC 25-Feb-83 Remove references to D%IO. 4010 JLC 19-Apr-83 Clear temp flags for formatted I/O here instead of in FORIO. 4033 JLC 18-Jul-83 Clear %SPFLG here so that we won't get plus signs in front of positive numbers after SP format has been used. 4044 JLC 27-Sep-83 Changed code for setting default (free-format) parameters for routines now in MTHLIB. 4052 JLC 12-Oct-83 Code changes necessary for minor performance enhancements to formatted I/O. 4054 JLC 25-Oct-83 Save TP%INT as data type before output of repeat count, as integer output now deciphers the data type. 4111 JLC 16-Mar-84 Modify the calling sequence for error calls. 4131 JLC 12-Jun-84 Give %GTBLK calls a non-skip error return to properly report memory full diagnostics. 4153 JLC 27-Sep-84 Modify the error message given if the character at the start of a data element is totally illegal if the target variable is of type character, from "illegal character in data" to "must be in single quotes". ***** End V10 Development ***** ***** Begin Version 11 ***** 5011 MRB 1-APR-86 Add support for long namelist names and for long variable names. {Routines: CHKEM,%NLI,NLINAM,NLVSRH} 5012 MRB 6-MAY-86 Fix namelist when using long strings. There are 37(octal) characters in a name not 31. ***** End V11 Development ***** ***** End Revision History ***** \ 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 (for V10 & earlier). *BUT* can be either a sixbit word or an address os a SIXBITZ string in version 11. 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 formats. Note that is the namelist name is a pointer to a SIXBITZ string then all scalar and array variable names will also be pointed to by a 30 bit address in the arg block. NAMELIST ADDR/ 0 89 12 14 1718 35 ------------------------------------ ! SIXBIT /NAMELIST NAME/ ! ! or ! !a 30 bit addr of the namelist name! ------------------------------------ ! NAME LIST ENTRIES ! ------------------------------------ ! 0 ! ------------------------------------ SCALAR ENTRIES 012 89 12 14 1718 35 ------------------------------------ ! SIXBIT /SCALAR NAME/ or pointer ! ------------------------------------ !10! 0 ! T !I! X ! SCALAR ADDR ! ------------------------------------ ARRAY ENTRIES differ in that blocks generated by V6 and earlier compilers have ARRAY SIZE and OFFSET as halfwords in the third word of the block. This is signaled by the first bit of word 2 being zero. V7 and later versions will set the first bit in word 2 and place ARRAY SIZE in word 3 and ARRAY OFFSET in word 4 of the block. V6 and earlier: 012 89 12 14 1718 35 ------------------------------------ ! SIXBIT /ARRAY NAME/ ! ------------------------------------ !00!#DIM! T !I! X ! BASE ADDR ! ------------------------------------ ! SIZE ! OFFSET ! ------------------------------------ ! ! !I! X ! FACTOR 1 ! ------------------------------------ ! ! !I! X ! FACTOR 2 ! ------------------------------------ ! ! !I! X ! FACTOR 3 ! ------------------------------------ ! ! !I! X ! FACTOR N ! ------------------------------------ V7 and later 012 89 12 14 1718 35 ------------------------------------ ! SIXBIT /SCALAR NAME/ or pointer ! ------------------------------------ !10!#DIM! T !I! X ! BASE ADDR ! ------------------------------------ ! NUMBER OF ENTRIES ! ------------------------------------ ! OFFSET ! ------------------------------------ ! ! !I! X ! FACTOR 1 ! ------------------------------------ ! ! !I! X ! FACTOR 2 ! ------------------------------------ ! ! !I! X ! FACTOR 3 ! ------------------------------------ ! ! !I! X ! FACTOR N ! ------------------------------------ $ SUBTTL JON CAMPBELL /JLC/EDS/AHM/mrb ENTRY %NLI,%NLO,%LDI,%LDO,%LDIST,%LDOST EXTERN %IBYTE,%IBYTC,%OBYTE,%IRECS,%ORECS,%SAVE4,%IBACK EXTERN %RIPOS,%SIPOS,%ROPOS,%SOPOS,%GTBLK,%PUSHT,%POPT EXTERN IO.ADR,IO.INC,IO.NUM,IO.TYP,%FLINF,A.NML,%SCLFC,IO.SIZ EXTERN %FLRFR,%FLRBX,%FLFSG,%FTSLB,%SPFLG EXTERN %FLSPR,%FLDPR,%FLGPR EXTERN %FWVAL,%DWVAL,%XPVAL EXTERN %GRIN,%GROUT,%INTI,%GINTO,%LINT,%LOUT,%OCTI,%OCTO,%SIZTB EXTERN %IOERR,%POPJ,%POPJ1,%SETAV,%UDBAD,%MVBLK,%OMBYT,%JPOPT SEGMENT DATA %ALASZ==10 ;SIZE OF ARRAYS FOR STRING INFO %ALISZ==100 ;INITIAL SIZE FOR STRING CORE ALLOCATION NLSGN1: BLOCK 1 ;LOCAL REAL PART SIGN NLSGN2: BLOCK 1 ;LOCAL IMAGINARY PART SIGN NLSGN.: BLOCK 1 ;SIGN OF ENTIRE VALUE NLFLG.: BLOCK 1 ;-1=END OF DATA, 0=NULL, 1=NON-NULL CHRLST: BLOCK 1 ;Last LD output was character (no delimiters) DLFLG.: BLOCK 1 ;FLAG TO SCAN FOR END DATA DELIM NLRFR: BLOCK 2 ;RAW FRACTION FROM FLIRT NLRBX: BLOCK 1 ;RAW BINARY EXPONENT TO MATCH NLRFR2: BLOCK 2 ;RAW FRACTION OF IMAGINARY PART NLRBX2: BLOCK 1 ;RAW BINARY EXPONENT OF IMAGINARY PART NLINFO: BLOCK 1 ;INFO ABOUT FLIRT NUMBER (REAL PART) NLVAL.: BLOCK 2 ;VALUE FOUND NLVL2.: BLOCK 2 ;2ND VALUE FOR COMPLEX NLRP.: BLOCK 1 ;REPEAT COUNT NLDIM.: BLOCK 1 ;# OF DIMENSIONS NLVAR.: BLOCK 1 ;PNTR TO VARIABLE IN ARG LIST NLNAM.: BLOCK 6 ;[5011]SIXBITZ NAME STRING OF NAMELIST/VARIABLE NLARG.: BLOCK 1 ;ADDRESS OF ARG LIST NLCVL.: BLOCK 2 ;CONVERTED VALUE NLADD.: BLOCK 1 ;ADDRESS OF USER'S VARIABLE NLINC.: BLOCK 1 ;OFFSET BETWEEN USER'S ARRAY ENTRIES NLSIZ.: BLOCK 1 ;SIZE OF USER'S ARRAY ENTRIES NLOFF.: BLOCK 1 ;Offset for calculation of element address NLFCT.: BLOCK 1 ;Address of array's first factor NLEMS.: BLOCK 1 ;Elements in array CNVTYP: BLOCK 1 ;CONVERTED VALUE TYPE VALTYP: BLOCK 1 ;ORIGINAL VALUE TYPE VARTYP: BLOCK 1 ;VARIABLE TYPE TOTYPE: BLOCK 1 ;TYPE TO CONVERT TO OSIZE: BLOCK 1 ;SIZE OF SUBSEQUENT OUTPUT DATA ELEMENT NLBFLN: BLOCK 1 ;Byte size of LD/NL input string buffer NLSBYT: BLOCK 1 ;Byte count of LD/NL input string NLSWRD: BLOCK 1 ;Word count of LD/NL input string NLCWRD: BLOCK 1 ;Current word count of LD/NL input string NLSPTR: BLOCK 1 ;Pointer to beginning of LD/NL string buffer NLCPTR: BLOCK 1 ;Current pointer to LD/NL input string FINFLG: BLOCK 1 ;FLAGS FOR END OF DATA LDLFLG: BLOCK 1 ;FLAGS FOR LEGAL DELIMITERS NLNUM.: BLOCK 1 ;# OF USER'S ARRAY ENTRIES TO FILL NLVFC.: BLOCK 1 ;FLAGS ALLOWED FOR 1ST CHAR OF VARIABLE NLFV.: BLOCK 1 ;VARIABLE ENTRY HAS BEEN FILLED TMPFLG: BLOCK 1 ; TEMP STORAGE FOR NAMELIST FLAG (P1) ;+ ;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. ;- COLFLG==0 SEMFLG==0 LSBFLG==0 RSBFLG==0 RABFLG==0 LABFLG==0 ATFLAG==0 NSFLAG==0 EOLFLG==2 US$Flg==4 ;[5011]Dollar sign or underscore flag 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 EQUFLG==2,,0 SEGMENT CODE ;LIST-DIRECTED INPUT & OUTPUT ROUTINES ;USES COMMON SUBROUTINES IN THE NAMELIST CODE TO PICK UP ;VALUES. %LDIST: MOVX T1,SLHFLG ;SLASH OR ERROR ENDS DATA MOVEM T1,FINFLG MOVX T1,COMFLG+SPCFLG+SLHFLG+NULFLG+ASTFLG+EOLFLG ;LEGAL DELIMITERS [3063] 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) MOVEM P1,TMPFLG ; SAVE NAMELIST FLAG AC POPJ P, ; %LDI: MOVE P1,TMPFLG ; GET NAMELIST FLAG AC PUSHJ P,LDSET ; SETUP VARIABLE PARAMS PUSHJ P,NLMAIN ; DO MAIN LOOP MOVEM P1,TMPFLG ; SAVE NAMELIST FLAG AC SKIPN NLRP. ; IF REPEAT COUNT GONE TDNN P1,FINFLG ; CHECK IF FINISHED POPJ P, ; JUST RETURN FOR MORE SETZM %UDBAD ; SETUP FOR NO MORE INPUT PJRST %SETAV ; RETURN TO USER PROG ;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 * %LDOST: 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,%SCLFC PJRST CHKEND ; CHECK FOR COL 1 %LDO: PUSHJ P,LDSET ;SETUP VARIABLE PARAMS PJRST NLMO ; OUTPUT IT 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,IO.SIZ ; 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, SUBTTL %NLI - Name List Input Routine ;++ ;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 MOVX T0,D%NML ;MEANS "=" & "(" ARE LOGIC DELIMS IORM T0,FLAGS(D) MOVX T1,NLEFLG ;END OF DATA FLAGS MOVEM T1,FINFLG MOVX T1,COMFLG+SPCFLG+ALFLAG+NLEFLG+NULFLG+ASTFLG+EOLFLG+EQUFLG+LPRFLG ;LEGAL DELIMITERS [3063] MOVEM T1,LDLFLG ;FOR CHECKING AFTER A SCAN MOVX T1,ALFLAG ;ALPHA CHAR ONLY BEGINS VARIABLE MOVEM T1,NLVFC. ;SAVE FOR SCAN ; ; Get the address of the NAMELIST name string from the argument block ; MOVE T1,NLARG. ;Get the address of the argument block MOVE T1,(T1) ;Get address of namelist name string MOVEM T1,NLVAL. ;Save it! ; ; Get the NAMELIST string from the data file. (String goes into NLNAM.) ; NLILP1: PUSHJ P,NLGETB ;GET BEG OF NAMELIST DATA PUSHJ P,SKPCHR ;SKIP BEGIN CHAR PUSHJ P,NLINAM ;Read Namelist Name string from data file MOVE T1,NLVAL. ;Get into T1 for routine CHKEM PUSHJ P,CHKEM ;[5011]are the namelist name strings the same JRST NLILP1 ;No, Loop and read another namelist name ;Yes,(we've found the correct namelist name) SETZM NLNAM. ;Clear namelist name pointer {unneed anymore} ; ; Found the correct namelist name. Now, find the correct variable name. ; NLILP2: PUSHJ P,VARNAM ;Read a variable name from data file. TDNE P1,FINFLG ;END OF DATA? JRST NLEND ;YES. LEAVE SKIPN NLNAM. ;Otherwise, did we find anything? JRST DOLFND ;NO. IT WAS AN ERROR, UNDOUBTEDLY PUSHJ P,NLVSRH ;Search namelist argument table for a match MOVE T1,NLNAM. ;Get name incase error TXNN P1,NLSFLG ;was a match found? $ACALL VNN ;No, an error. 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 SUBTTL CHKEM - CHECK TWO SIXBITZ STRINGS ;+ ;[5011] NEW ; This will check to see if the value we are given is a NEW style ; pointer to a SIXBITz string or a sixbit word. If it's a work then ; compair the word. Else, Check the two strings byte for byte to see ; if there the same. If the strings differ then just return. But, ; if there exactly the same (excluding the nulls) take a skip return. ; ; NLNAM. - Is the first word of the string from the data file. ; T1 - Is the address of the string (or the word) from the argument block. ;- CHKEM: XMOVEI T2,T1 ;MAKE A COPY OF IT $BLBP6 T2 ;MAKE A BYTE POINTER TO STRING ILDB T2,T2 ;GET THE FIRST BYTE (CHAR OR PTR?) JUMPN T2,CHKEM2 ;OLD STYLE SIXBIT WORDS? ; ; New style long namelist names strings ; CHKEM0: PUSHJ P,%PUSHT ;SAVE T0 THRU T5 $BLBP6 T1 ;MAKE A BYTE POINTER TO STRING PUSH P,T1 ;SAVE THE BP TO STRING ; ; Count number of characters in string ; SETZ T0 CHKEM1: ILDB T2,T1 ;GET A CHARACTER FROM STRING SKIPE T2 ;EXIT LOOP WHEN NULL FOUND AOJA T0,CHKEM1 ;OTHERWISE INCR COUNT & LOOP ; ; Compair the strings ; POP P,T1 ;GET THE BYTE POINTER TO STRING SETZB T2,T5 ;ONLY ONE WORD BYTE POINTERS MOVEI T3,37 ;[5012]LENGTH OF STRING READ FROM DATA FILE XMOVEI T4,NLNAM. ;MAKE BP TO OTHER STRING $BLBP6 T4 ;MAKE A BYTE POINTER TO STRING EXTEND T0,[CMPSE ;COMPAIR THE STRINGS 0 0] PJRST %JPOPT ;NOT EQUAL, RESTOR AND RETURN PUSHJ P,%POPT ;THERE EQUAL, RESTORE ACS' PJRST %POPJ1 ;AND TAKE A SKIP RETURN CHKEM2: CAME T1,NLNAM. ;SAME AS FROM ARG LIST? POPJ P, ;NO, RETURN PJRST %POPJ1 ;YES, TAKE A SKIP RETURN ;End of routine CHKEM SUBTTL ;INITIALIZATION OF NAMELIST/LDIO PARAMETERS NLINIT: MOVX T1,D%CLR ;CLEAR TEMP FLAGS ANDCAM T1,FLAGS(D) XMOVEI T1,@A.NML ;Get addr of arg block LDB T2,[POINTR A.NML,ARGTYP] ;GET ARG TYPE JUMPN T2,GOTNLA ;IF NON-ZERO, T1 HAS NAMELIST ADDR MOVE T1,(T1) ;OTHERWISE IT HAS PNTR TO NAMELIST ADDR GOTNLA: MOVEM T1,NLARG. ;SAVE ARG LIST ADDR SETZM NLSWRD ;Clear string count SKIPN T1,NLSPTR ;Is there a string yet? HRLZI T1,(POINT 7,) ;NO. load a 7 bit pointer MOVEM T1,NLCPTR ;Initialize current input string ptr SETZ P1, ;CLEAR FLAG WORD SETZM NLRP. ;CLEAR REPEAT COUNT SETZM NLFLG. ;CLEAR FLAG SETZM CHRLST ;[3120]Clear flag SETZM %FWVAL ;FREE FORMAT SETZM %DWVAL SETZM %XPVAL DSETZM SS.ADR ;Reset substring words [3063] SETZM NLFV. ;SET NO VARIABLES FILLED SETZM %SCLFC ;CLEAR SCALE FACTOR SETZM VALTYP ;Clear input variable type [3063] 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 MOVE T0,VARTYP ;Get variable type [3063] CAIE T0,TP%CHR ;Character? [3063] JRST CALAR1 ;NO. [3063] PUSHJ P,CALCHR ;Do character processing[3063] JRST CALAR2 ;Skip non-char processing[3063] CALAR1: SKIPE NLDIM. ;ARRAY? [3112] PUSHJ P,CALADD ; YES. PROCESS INDICES IF ANY [3063] CALAR2: TDNE P1,FINFLG ;LEAVE IF DONE [3063] POPJ P, CAIE T1,"=" ;DO WE HAVE =? ; IOERR (NEQ,799,513,?,Found "$C" when expecting "=",) $ACALL NEQ 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.). ;[3063] We now check for new(V7)-style NAMELIST blocks. Old(V6)-style ; blocks had ARRAY-SIZE (number of elements) in the left-half ; and ARRAY-OFFSET in the right half of the third word of the ; block. New-style has ARRAY-SIZE in the third word and OFFSET ; in the fourth word. New-style blocks are indicated by "1" ; in bit zero of the second word, while old-style blocks ; have zero in bit zero (see diagram at the beginning of NMLST). ; To simplify things, ARRAY-SIZE and ARRAY-OFFSET are now stored ; in NLEMS. and NLOFF., respectively, during initialization. VARSET: MOVEI T1,1 ;INITIALIZE # ENTRIES AT 1 MOVEM T1,NLNUM. MOVE T2,NLVAR. ;GET THE ARG PNTR MOVE T1,(T2) ;Get pointer to variable name string MOVEM T1,NLNAM. ;SAVE IT LDB T1,[POINT 7,1(T2),8] ;GET # DIMS MOVEM T1,NLDIM. ;SAVE # DIMS JUMPE T1,VARST1 ;IT'S A SCALAR SKIPL 1(T2) ;New style block?(ck 1st wd/ ARRAYNAME entry) JRST OLDBLK ;NO MOVE T1,2(T2) ;Get # entries in array MOVEM T1,NLNUM. ;Save # array entries left MOVEM T1,NLEMS. ;Save # total array entries MOVE T1,3(T2) ;Get offset MOVEM T1,NLOFF. ;Save offset XMOVEI T1,4(T2) ;Get address if first factor MOVEM T1,NLFCT. ;Save address of first factor JRST VARST1 ;Back in line OLDBLK: HLRZ T1,2(T2) ;GET # ENTRIES IN ARRAY MOVEM T1,NLNUM. ;SAVE IT MOVEM T1,NLEMS. ;Save # total array entries HRRZ T1,2(T2) ;Get offset MOVEM T1,NLOFF. ;Save offset XMOVEI T1,3(T2) ;Address of first factor MOVEM T1,NLFCT. ;Save address/first factor VARST1: LDB T3,[POINT 4,1(T2),12] ;GET TYPE MOVEM T3,VARTYP ;SAVE TYPE NLTYP: CAIN T3,TP%CHR ;Character string? JRST NLICHR ;YES. Go initialize for characters XMOVEI T1,@1(T2) ;Get base addr MOVEM T1,NLADD. ;SAVE IT MOVE T1,%SIZTB(T3) ;GET SIZE MOVEM T1,NLSIZ. ;SAVE SIZE MOVEM T1,NLINC. ;AND OFFSET POPJ P, NLICHR: DMOVE T2,@1(T2) ;Load pointer & count MOVEM T2,NLADD. ;Store it MOVEM T2,IO.ADR ;For string comparisons MOVEM T3,NLSIZ. ;Save length MOVEM T3,NLINC. ;Save increment POPJ P, ;All done ;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? POPJ P, ;NO. Entire array(all done) MOVE P3,NLDIM. ;P3= # dims left to process MOVE P4,NLFCT. ;P4 points to factors [3063] 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,) $ACALL NRP PUSHJ P,SKPCHR ;SKIP THE RIGHT PAREN PUSHJ P,NLNB ;AND GO TO NEXT DELIM ;DON'T TOUCH T1 - CONTAINS DELIM MOVN T2,NLOFF. ;Get negative offset [3063] 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,) $ACALL ILS ;?Illegal subscript OFFOK: IDIV T3,NLSIZ. ;GET NEG # ENTRIES IN OFFSET MOVE T2,NLEMS. ;Get total entries in array [3063] ADD T2,T3 ;GET # ENTRIES LEFT MOVEM T2,NLNUM. ;SAVE IT JUMPG T2,%POPJ ;OK IF .GT. ZERO $ACALL ILS ;?Illegal subscript ;[3063] ;CALCHR: is the analog of CALADD. We process the indices of a character ; array reference, utilizing ADJBP to calculate the address of the ; referenced element. If the element is out of bounds, by virtue ; of beginning before the actual start of the array, or of being ; the nth +1 or greater element of the array, a fatal error has ; occurred. When we leave this routine, NLNUM. = the number of ; elements left in the array, including the one just identified. ; When all of the dimensions have been processed, and the element's ; address is known, we look for a substring identifier. If one ; is found, we process it and set SS.ADD = substring address, ; and SS.SIZ = substring size, else SS.ADR and SS.SIZ = zero. CALCHR: DSETZM SS.ADR ;Reset substring indicator SKIPN P3,NLDIM. ;Array? (P3=dimensions to process) JRST ENDIMS ;NO. Go check for substring MOVE P2,NLVAR. ;Get variable entry pointer CAIE T1,"(" ;LEFT PAREN? POPJ P, ;NO. ENTIRE ARRAY MOVE P4,NLFCT. ;P4 points to factors XMOVEI T1,NLVAL. ;POINT TO VALUE MOVEM T1,IO.ADR ;FOR %INTI SETZM IO.SIZ ;Initialize counter ADCLP1: PUSHJ P,%INTI ;GET AN INTEGER MOVE T2,NLVAL. ;Get value IMUL T2,(P4) ;MULTIPLY BY A FACTOR ADDM T2,IO.SIZ ;Count it PUSHJ P,NLSDEL ;GET THE NEXT DELIMITER SOSLE P3 ;Done if no more dimensions AOJA P4,ADCLP1 ;Go add in next factor ADCLPD: PUSHJ P,GETDEL ;GET THE DELIM CAIE T1,")" ;Proper delimiter of indices? $ACALL NRP ; "? Missing right paren" PUSHJ P,SKPCHR ;SKIP THE RIGHT PAREN PUSHJ P,NLNB ;AND GO TO NEXT DELIM ;DON'T TOUCH T1 - CONTAINS DELIM MOVN T2,NLOFF. ;Get negative offset ADDB T2,IO.SIZ ;Calculate real offset SKIPGE T2 ;OK if positive $ACALL ILS ;"Illegal subscript" ADJBP T2,NLADD. ;Adjust the pointer MOVEM T2,NLADD. ;Store new pointer MOVN T2,IO.SIZ ;Negative offset IDIV T2,NLSIZ. ;Calc elements ADDB T2,NLNUM. ;Calc elements left JUMPG T2,ENDIMS ;OK if .GT. zero $ACALL ILS ;"? Illegal subscript" ENDIMS: TDNN P1,FINFLG ;LEAVE IF DONE CAIE T1,"(" ;Is there sub-string info? POPJ P, ;NO PUSHJ P,SKPCHR ;Skip "(" SUBSTR: XMOVEI T1,NLVAL. ;Point to value MOVEM T1,IO.ADR ;For %INTI MOVEI T2,1 ;Assume character position 1 MOVEM T2,NLVAL. ;Store default position PUSHJ P,NLNB ;Get next non-blank CAIN T1,":" ;Null value? JRST SUB1 ;YES. PUSHJ P,%IBACK ;Point to beginning PUSHJ P,%INTI ;Get the 1st character position MOVE T1,NLSIZ. ;Full element size EXCH T1,NLVAL. ;Assume substring runs to last char CAMLE T1,NLVAL. ;First character within element? $ACALL ISS ;"Illegal substring descriptor" SOSGE T1 ;Relative character position > zero? $ACALL ISS ;"Illegal substring descriptor" MOVNM T1,SS.SIZ ;Save (NEG) 1ST char relative position ADJBP T1,NLADD. ;Substring pointer MOVEM T1,SS.ADR ;Store substring pointer PUSHJ P,GETDEL ;Get the delimiter CAIE T1,":" ;Is it the right one? $ACALL NEC ;"? Got $C when expecting ":"" SUB1: PUSHJ P,SKPCHR ;Skip ":" PUSHJ P,NLNB ;Get the next delimiter CAIN T1,")" ;End of substring descriptor? JRST SUB2 ;YES. PUSHJ P,%IBACK ;Backup for %INTI PUSHJ P,%INTI ;Get ending character position SUB2: MOVE T1,NLVAL. ;Load last character position CAMLE T1,NLSIZ. ;Character position within element? $ACALL ISS ;"? Illegal substring descriptor" ADDB T1,SS.SIZ ;Calculate substring length SKIPG T1 ;Positive length? $ACALL ISS ;"? Illegal substring descriptor" PUSHJ P,GETDEL ;Get the delimiter CAIE T1,")" ;Is it the right one? $ACALL NRP ;"? Missing right paren" PUSHJ P,SKPCHR ;Skip right paren PJRST NLNB ;Get next delimiter and return SEGMENT DATA SS.ADR: BLOCK 1 SS.SIZ: BLOCK 1 SEGMENT CODE SUBTTL VARNAM & NLINAM - ASSEMBLES A VARIABLE NAME OR NAMELIST NAME ;+ ; Reads from the data file a variable or namelist name from the data file. ; Name strings can be up to 31 characters long. If we're reading a variable ; name and there's one already in NLNAM. then just return. (it's probibly an ; error) ;- VARNAM: SKIPE NLNAM. ;IF IT WAS NON-ZER POPJ P, ;IT WAS A BAD LOGIC VALUE NLINAM: MOVE P2,[NLNAM.,,NLNAM.+1] ;[5011]Clear out the entire name list SETZM NLNAM. ;[5011] or variable name string. BLT P2,NLNAM.+5 ;[5011] 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) $ACALL ILN MOVEI P2,37 ;[5012]Max string length is 31 chars total SKIPA P3,[POINT 6,NLNAM.] ;Make SIXBIT pntr, Already got 1st char NLINL1: PUSHJ P,GETCHR ;Get next char TXNN P1,ALFLAG+DIGFLG+Us$Flg ;[5011]ALPHA,DIGIT,UNDERSCORE or DOLAR? JRST [SETZ T1, ;[5011]No (end of string) IDPB T1,P3 ;[5011]Make a nullto terminate the string POPJ P, ];[5011]then return CAIL T1,140 ;Otherwise,Convert char to SIXBIT SUBI T1,40 SUBI T1,40 IDPB T1,P3 ;Copy each character to string SOJG P2,NLINL1 ;Loop for entire string ; PJRST NLNA ;Then scan for non-alphameric ; Ignore the remander of characters in this string (longer than 31 chars). ; Terminate the string with a null. Scan until non-alphameric char found. NLNA: SETZ T1, ;[5011]Make a null IDPB T1,P3 ;[5011]Terminate string PUSHJ P,GETCHR ;GET A CHAR TXNE P1,ALFLAG+DIGFLG+Us$Flg ;[5011]ALPHA,DIGIT,UNDERSCORE or DOLAR? JRST NLNA ;YES. SKIP IT POPJ P, ;Then return ;End of routine VARNAM SUBTTL NLVSRH - Search for a variable name in the namelist arg block ;+ ; We have read in a namelist variavle name from the data file we will ; come here to search through the namelist argument block for a match. ; The number of entries taken by a variable in the namelist argument ; 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(or ptr to name) CAMN T1,FINCOD ;0 OR END CODE IS END POPJ P, ;RETURN IF END OF LIST PUSHJ P,CHKEM ;[5011]Are the variable name strings the same JRST NLVLP2 ;[5011]No keep searching. JRST NLVFND ;Yes NLVLP2: LDB T2,[POINT 7,1(T3),8] ;NO, GET # DIMS ADDI T3,2 ;ASSUME SCALAR JUMPE T2,NLVLP1 ;BACK IF SCALAR SKIPGE -1(T3) ;Size and offset in half-words?[3063] AOJ T3, ;NO. block is one word longer [3063] ADDI T3,1(T2) ;MORE JUNK IF ARRAY JRST NLVLP1 NLVFND: TXO P1,NLSFLG ;SET FOUND FLAG MOVEM T3,NLVAR. ;SAVE PNTR POPJ P, SUBTTL - ;+ ;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. ; ;If the destination variable is of type character, jump to ;VARCHR to perform byte-string instructions, and to check ;whether pointers are set to beginning of repeated string. ;As before, non-character variables will be filled from ;Hollerith strings, with each loop through NLP picking up ;the next five (single precision) or ten (double precision) ;bytes from the input string. The string has been padded ;with sufficient spaces (maximum of 9) to allow creation ;of a single or double precision variable via a MOVE-MOVEM ;or DMOVE-DMOVEM instruction pair. These spaces are not ;included in the string count. When the string is ;exhausted, the pointers are reset to the beginning of the ;string, and if the repeat count is not zero, the next ;destination variable (if non-character) will be filled ;using the current string. ;- NLMAIN: NLP: SKIPN NLRP. ;REPEAT COUNT? NLVAL: PUSHJ P,NLSCV ;NO. GET VALUE & REPEAT COUNT SKIPGE T1,NLFLG. ;DID WE GET A VALUE? POPJ P, ;NO. LEAVE JUMPE T1,FULVAL ;JUST DECR REPEAT COUNT IF NULL MOVE T1,VARTYP ;GET VARIABLE TYPE CAIN T1,TP%CHR ;Type character? JRST VARCHR ;YES. special processing 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) FULVAL: 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. ;VARCHR: ;Variables of type character, however, use one string per ;destination variable. VARCHR resets NLCPTR and NLCWRD, ;decrements NLRP. if the preceding variable did not exhaust ;the string, and if NLRP. is zero, loops back to NLVAL to ;get another value. When VARCHR has an appropriate value, ;it moves the string and jumps back in line. NLRPI has ;been taught to reset the pointers and decrement NLRP. ;for each destination variable of type character. VARCHR: MOVE T1,NLSWRD ;Beginning word count CAME T1,NLCWRD ;Are we in the middle of a string? PUSHJ P,RSTPTR ;YES. Reset ptr and decr repeat count SKIPN NLRP. ;Still repeat count? JRST NLVAL ;NO. Go input another variable MOVE T1,VALTYP ;Get input variable type CAIE T1,TP%LIT ;Input type literal? $ACALL SNQ ;"? String not within single quotes" MOVE T0,NLSBYT ;Source string count MOVE T1,NLSPTR ;Source byte pointer SKIPN T3,SS.SIZ ;Is it a substring? [3063] MOVE T3,NLSIZ. ;NO. SKIPN T4,SS.ADR ;Is it a substring? [3063] MOVE T4,NLADD. ;NO. EXTEND T0,[MOVSLJ " "] ;Move the string with space fill TRNN ;Ignore truncation (NO-OP) SETOM NLFV. ;FILLED A VARIABLE PUSHJ P,NLRPI ;PROCESS VALUE PNTR/COUNTS SOSG NLNUM. ;Any more elements? POPJ P, ;NO...quit DSETZM SS.ADR ;Reset substring stuff [3063] MOVE T1,NLINC. ;Get array increment ADJBP T1,NLADD. ;Adjust destination byte pointer MOVEM T1,NLADD. ;Store new pointer JRST NLP ;Loop thru next element ;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 SETZM VALTYP ;Clear input variable type 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 %FLINF ;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 ;Set acceptable input type 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,) $ACALL RPE ;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 NLSCN1: 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 T1,NLTYPE(P2) ;GET TYPE MOVEM T1,VALTYP ;SAVE IT CAIN T1,TP%DPR ;IS IT DOUBLE REAL? SETZ T1, ;YES. GIVE 0 SO FLIRT WON'T CONVERT MOVEM T1,IO.TYP ;SAVE TYPE FOR I/O ROUTINE XCT T1,NLSUB(P2) ;DO READ PUSHJ P,GETDEL ;GET THE DELIMITER, SET FLAGS TDNE P1,LDLFLG ;LEGAL DELIMITER AT END OF SCAN? POPJ P, ;YES $ACALL ILC ;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? JRST CHKCV ;[4153] NOT ALLOWED, OR VAR NOT FILLED SETZM NLFLG. ;SET FLAG FOR NULL VALUE SETZM NLNUM. ;[2037] NO ELEMENTS LEFT SETZM NLRP. ;[2037] NO REPEAT COUNT YET. POPJ P, CHKCV: MOVE T1,VARTYP ;[4153] GET DESIRED VARIABLE TYPE CAIE T1,TP%CHR ;[4153] CHARACTER? $ACALL ILC ;[4153] NO. "ILLEGAL CHARACTER IN DATA" $ACALL SNQ ;[4153] YES. MUST BE IN SINGLE QUOTES ;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: SETZM NLSGN. ;+=0, -=-1 TXNN P1,SGNFLG ;IS THE CHAR A SIGN? JRST SGNEND ;NO. MOVE BACK PNTR SGNLP: CAIN T1,"-" ;IS IT A MINUS? SETCMM 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,) $ACALL SNV 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? $ACALL SNV ;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 JRST %SETAV ;Reset & return ;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 [3063] 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,%RIPOS ;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,%SIPOS ;SET IT PUSHJ P,GETCHR ;GET IT TXNE P1,NLEFLG ;NAMELIST BEG/END FLAG? POPJ P, ; YUP GTNREC: PUSHJ P,%IRECS ;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,%RIPOS ;GET INPUT POSITION CAIG T1,1 ;AT COLUMN 1? JRST GETCHR ;YES. THERE IS NO PREVIOUS CHAR 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,%RIPOS ;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 SKIPGE IRCNT(D) ;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 CAIE T1,"_" ;[5011]Underscore or CAIN T1,"$" ;[5011]Dollar sign? TXO P1,US$FLG ;[5011]Yep, Set 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: SKIPLE IRCNT(D) ;END OF RECORD ALREADY? JRST GTCHR1 ;NO. Go get a character PUSHJ P,%IRECS ;YES. GET NEXT LINE MOVE T0,FLAGS(D) ;Get flags TXNN T0,D%NML ;Is this a NAMELIST request? JRST GTCHR1 ;NO MOVE T0,VALTYP ;Get input value type CAIE T0,TP%LIT ;Are we in a character string? JRST GTCHR1 ;NO. Proceed as always ; IS NEXT CHECK REALLY NECESSARY? PUSHJ P,GETCHR ;Get the first character TDNE P1,FINFLG ;SAME POPJ P, ; CHECKS TXNE P1,EOLFLG ; AS AT JRST NULCHR ; "TESTL" CAIE T1," " ;Real character; is it a space? POPJ P, ;NO, return with this character 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: MOVX 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 now checks for destination variable of type character. ;If YES, the pointers are reset and NLRP. is decremented, ;since the there is a one-to-one correspondence between ;input and destination variables of type character. NLRPI: SKIPN NLSWRD ;Is there a string? JRST DECRP ;NO. go decr repeat count MOVEI T1,TP%CHR ;Type character CAMN T1,VARTYP ;Is it? JRST RSTPTR ;YES. go reset pointers & return MOVE T1,NLSIZ. ;Words used from string ADDM T1,NLCPTR ;Update current pointer MOVN T1,T1 ;Negative ADDB T1,NLCWRD ;Compute words left JUMPLE T1,RSTPTR ;String exhausted? POPJ P, ;NO ;RSTPTR is an entry point from VARCHR to allow reset and ;decrement when a destination variable of type character ;follows one which is not, and the pointers have not yet ;been reset to the beginning of the string. RSTPTR: MOVE T1,NLSPTR ;Pointer to beginning of string MOVEM T1,NLCPTR ;Current pointer MOVE T1,NLSWRD ;String count MOVEM T1,NLCWRD ;Current count DECRP: SOSLE NLRP. ;[3164]DECR REPEAT COUNT POPJ P, ;[3164]Leave if positive SETZM NLSBYT ;[3164]Reset string byte count SETZM NLSWRD ;[3164]Reset string word 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: PUSHJ P,%GRIN PUSHJ P,TDBL PUSHJ P,LOGI PUSHJ P,ALPHI PUSHJ P,OCTI PUSHJ P,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,,OCTLOG 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,,OCTLOG TP%INT,,OCTINT TP%SPR,,OCTSR TP%DPR,,OCTDR TP%DPX,,OCTDR TP%CPX,,OCTDR 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. OCTDR: OCTLOG: OCTINT: OCTSR: DMOVE T1,NLVAL. ;TRANSFER BOTH WORDS DMOVEM T1,NLCVL. ;IT CAN'T HURT POPJ P, CPXDR: DMOVE T1,NLRFR ;GET REAL RAW FRACTION DMOVEM T1,%FLRFR ;SAVE IT MOVE T1,NLRBX ;GET REAL PART RAW EXPONENT MOVEM T1,%FLRBX ;SAVE IT XMOVEI T1,NLCVL. ;POINT TO CONVERTED VALUE MOVEM T1,IO.ADR PJRST %FLDPR ;CONVERT IT DRDR: XMOVEI T1,NLCVL. ;POINT TO CONVERTED VALUE MOVEM T1,IO.ADR PJRST %FLDPR ;CONVERT IT CPXLOG: CPXSR: DMOVE T1,NLRFR ;GET REAL PART RAW FRACTION DMOVEM T1,%FLRFR ;SAVE FOR CONVERT MOVE T1,NLRBX ;GET REAL PART RAW EXPONENT MOVEM T1,%FLRBX ;SAVE FOR CONVERT MOVE T1,NLSGN1 ;GET REAL PART SIGN MOVEM T1,%FLFSG ;SAVE IT XMOVEI T1,NLCVL. ;POINT TO CONVERTED VALUE MOVEM T1,IO.ADR ;SAVE IT PJRST %FLSPR ;GO CONVERT IT DRLOG: DRCPX: DRSR: XMOVEI T1,NLCVL. ;POINT TO CONVERTED VALUE MOVEM T1,IO.ADR PJRST %FLSPR ;CONVERT TO SINGLE PRECISION CPXINT: DMOVE T2,NLRFR ;GET SAVED RAW FRACTION MOVE T4,NLRBX ;AND BINARY EXPONENT MOVE T1,NLSGN1 ;GET SIGN OF REAL PART MOVEM T1,%FLFSG ;SAVE IT JRST XINT ;JOIN DRINT CODE DRINT: DMOVE T2,%FLRFR ;GET LEFT-JUSTIFIED FRACTION MOVE T4,%FLRBX ;GET BINARY EXPONENT JUMPLE T4,NOINT ;ZERO IF EXP .LE. 0 XINT: SETZ T1, ;CLEAR INTEGER 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 ADDI T4,1 ;AND INCR BINARY EXPONENT NORND: CAILE T4,^D35 ;WILL WE SHIFT TO OBLIVION? JRST INTOVL ;YES. RETURN OVERFLOW LSHC T1,1(T4) ;SHIFT INTO INTEGER SKIPGE %FLFSG ;LOCAL MINUS? MOVN T1,T1 ;YES. NEGATE IT MOVEM T1,NLCVL. ;STORE IT NOINT: POPJ P, INTOVL: HRLOI T1,377777 ;RETURN LARGEST NUMBER SKIPGE %FLFSG ;LOCAL MINUS? MOVN T1,T1 ;YES. NEGATE IT MOVEM T1,NLCVL. $ECALL IOV ;%integer overflow POPJ P, CPXCPX: DMOVE T1,NLRFR ;GET REAL PART RAW FRACTION DMOVEM T1,%FLRFR ;SAVE FOR CONVERT MOVE T1,NLRBX ;GET RAW FRACTION MOVEM T1,%FLRBX ;SAV FOR CONVERT MOVE T1,NLSGN1 ;GET REAL PART LOCAL SIGN MOVEM T1,%FLFSG ;SAVE FOR CONVERT XMOVEI T1,NLCVL. ;POINT TO REAL PART OF CONVERTED VALUE MOVEM T1,IO.ADR PUSHJ P,%FLSPR ;CONVERT TO SINGLE PRECISION DMOVE T1,NLRFR2 ;NOW THE SAME FOR IMAGINARY PART DMOVEM T1,%FLRFR MOVE T1,NLRBX2 MOVEM T1,%FLRBX MOVE T1,NLSGN2 MOVEM T1,%FLFSG XMOVEI T1,NLCVL.+1 ;POINT TO IMAG PART OF CONVERTED VALUE MOVEM T1,IO.ADR PJRST %FLSPR ;CONVERT TO SINGLE PRECISION ALPINT: ALPLOG: ALPSR: MOVE T1,NLCPTR ;Get address of word MOVE T1,(T1) ;Get the word MOVEM T1,NLCVL. ;Store it POPJ P, CPXDPX: DMOVE T1,NLRFR ;GET REAL PART RAW FRACTION MOVEM T1,%FLRFR ;SAVE FOR CONVERT MOVE T1,NLRBX ;SAME FOR RAW EXPONENT MOVEM T1,%FLRBX MOVE T1,NLSGN1 ;GET REAL PART LOCAL SIGN MOVEM T1,%FLFSG ;SAVE FOR CONVERT DRDPX: XMOVEI T1,NLCVL. ;POINT TO CONVERTED VALUE MOVEM T1,IO.ADR ;SAVE FOR CONVERSION ROUTINE PJRST %FLGPR ;GO CONVERT IT TO G-FLOATING ALPDR: ALPCPX: MOVE T1,NLCPTR ;Get address of value DMOVE T1,(T1) ;Get 2 words DMOVEM T1,NLCVL. ;Save them POPJ P, BADCNV: ;IOERR (CCC,799,519,?,Can't convert constant to correct type,) $ACALL CCC ;NAMELIST/LDIO has its own alphameric input routine because ;we need to have the entire string available when the repeat ;count is greater than one. We input one byte at a time, ;checking only for single quotation marks ('). The first ;quotation mark denotes the beginning of the string, and ;has already been found; we skip it here. All ASCII ;characters are permissible. Two single quotation marks ('') ;in the input stream signify one input quote ('). The input ;stream is searched until only one single quote is found ;() is legal within a character string. Null strings ;are illegal. If there is not room in the string buffer for ;the current byte, NLXIRB is called to double the string buffer, ;and the byte is then deposited in the new buffer. NLXIRB ;returns: T1=pointer to beginning of new buffer ; T2=pointer to byte last-deposited in new buffer ; T3=free bytes remaining in new buffer. ;When the string is complete, it is padded with from five ;to nine spaces in order to allow a MOVE-MOVEM or DMOVE-DMOVEM ;combination to fill a single or double precision variable from ;the end of the string. These spaces are not included in the ;string byte length (NLSBYT) or word length (NLSWRD). ALPHI: SETZM NLSBYT ;Reset byte count PUSHJ P,SKPCHR ;Skip the initial quote MOVE P2,NLBFLN ;Buffer-length equals bytes left ALPLP1: PUSHJ P,GTCHRL ;Get a character CAIE T1,"'" ;Another quote? JRST ALPDPB ;NO. OK to deposit byte PUSHJ P,GETCHR ;Get next character, don't call %IREC CAIE T1,"'" ;2 quotes in a row? JRST ALPFIN ;NO, string is complete ALPDPB: SOJGE P2,ADPBOK ;If bytes left, OK to deposit byte PUSH P,T1 ;Buffer empty, save character SETZ T3, ;No minimum size PUSHJ P,NLXIRB ;Expand buffer MOVEI P2,(T3) ;Bytes left POP P,T1 ;Restore character JRST ALPDPB ;Go count this byte ADPBOK: IDPB T1,NLCPTR ;Deposit the character in string JRST ALPLP1 ;Loop for more ALPFIN: MOVE T1,NLBFLN ;Buffer byte length SUB T1,P2 ;Minus bytes remaining=string length SKIPN T1 ;Null string? $ACALL NLS ;YES. "Null string illegal" MOVEM T1,NLSBYT ;save string length in bytes IDIV T1,BPW(D) ;Get remainder in T2 MOVEM T1,NLSWRD ;Save string length in words JUMPE T2,FILWRD ;If end on boundary, go space next word AOS NLSWRD ;Remainder means partial word SUB T2,BPW(D) ;Negative # of spaces (partial word) FILWRD: SUB T2,BPW(D) ;Fill (another) word full of spaces ADD P2,T2 ;Is there enough room in buffer? JUMPGE P2,PUTSPC ;YES. Go do it PUSH P,T2 ;Save negative count MOVN T3,T2 ;Minimum expansion count PUSHJ P,NLXIRB ;Expand buffer POP P,T2 ;Restore negative count PUTSPC: MOVEI T1," " ;Pad with spaces DPBSPC: IDPB T1,NLCPTR ;Deposit the space AOJL T2,DPBSPC ;Loop if more spaces MOVE T1,NLSPTR ;Get beginning-of-buffer pointer MOVEM T1,NLCPTR ;Set current pointer MOVE T1,NLSWRD ;Words in string MOVEM T1,NLCWRD ;Set current words (left)=string length POPJ P, ;NLXIRB: Routine to expand the NAMELIST input string buffer. ; ; Doubles old buffer length, adds value in T3, rounds up to ; word boundary, and calls %MVBLK to create new buffer and ; move old buffer to beginning of new buffer. Computes the ; pointer to the last used byte in the new buffer by using ; the pointer from the old buffer and the difference between ; the pointers to the beginnings of the old and new buffers. ; ; If there is no old buffer, adds value in T3 to NLBFLN, ; rounds to word boundary, and calls %GTBLK to create the ; desired buffer. ;RETURN: T1 = pointer to beginning of (new) buffer ; T2 = pointer to last used byte in (new) buffer ; T3 = free bytes in (new) buffer ; NLBFLN, NLSPTR, & NLCPTR are updated to reflect new values. NLXIRB: MOVE T2,NLBFLN ;Old buffer length in bytes HRRZ T1,NLSPTR ;Old buffer address PUSHJ P,XPNLBF ;Expand and move HRRZ T2,NLSPTR ;Address of old buffer MOVEM T1,NLSPTR ;Pointer to start of new buffer HRRZI T1,(T1) ;Strip pointer stuff SUBI T2,(T1) ;Difference between old & new addresses MOVN T2,T2 ;Negative difference between addresses ADDM T2,NLCPTR ;Pointer to current (first free) byte MOVE T4,NLBFLN ;Old byte size MOVEM T3,NLBFLN ;Store new byte size SUBI T3,(T4) ;Return free bytes in T3 POPJ P, XPNLBF: JUMPE T1,GTNLBF ;If none yet, go get one MOVEI T4,(T2) ;Byte size of current buffer LSH T4,1 ;Doubled ADDI T4,(T3) ;(Current buffer*2)+mininum size IDIV T2,BPW(D) ;Buffer size in words MOVEI T3,(T4) ;Desired buffer length ADDI T3,4 ;Round to word boundary IDIV T3,BPW(D) ;New size in words PUSHJ P,%MVBLK ;Expand buffer $ACALL MFU ;[4131] CAN'T IMUL T3,BPW(D) ;New size in bytes HRLI T1,(POINT 7) ;Pointer to beginning of buffer HRLI T2,(POINT 7) ;Pointer to first free byte POPJ P, ;RETURN GTNLBF: ADDI T3,NLDIBF+4 ;Round (initial byte size + minimum)to boundary IDIV T3,BPW(D) ;Word size MOVEI T1,(T3) ;Move where needed by %GTBLK IMUL T3,BPW(D) ;Bytes that will be in buffer PUSH P,T3 ;Destroyed by %GTBLK PUSHJ P,%GTBLK ;Create buffer $ACALL MFU ;[4131] CAN'T POP P,T3 ;Restore buffer length in bytes HRLI T1,(POINT 7) ;Pointer to beginning of buffer MOVE T2,T1 ;Current pointer=beginning pointer 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,GETCHR ;GET NEXT CHAR, don't bump record 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,%FLRFR ;SAVE RAW FRACTION MOVEM T1,NLRFR MOVE T1,%FLRBX ;AND RAW BINARY EXPONENT MOVEM T1,NLRBX MOVE T1,%FLFSG ;GET LOCAL SIGN XOR T1,NLSGN. ;COMBINE WITH GLOBAL SIGN MOVEM T1,NLSGN1 ;SAVE IT PUSHJ P,NLSDEL ;SCAN FOR DELIM CAIE T1,"," ;WAS IT A COMMA? $ACALL ILC ;"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 $ACALL ILC ;"ILLEGAL CHARACTER IN DATA" PUSHJ P,GETCHR ;THROW AWAY ")", do not get next record DMOVE T1,%FLRFR ;SAVE AWAY THE RAW COMPONENTS DMOVEM T1,NLRFR2 ;LOCALLY MOVE T1,%FLRBX MOVEM T1,NLRBX2 MOVE T1,%FLFSG ;GET LOCAL SIGN XOR T1,NLSGN. ;COMBINE WITH GLOBAL ONE MOVEM T1,NLSGN2 ;FOR THE IMAGINARY PART SETZM NLSGN. ;NO GLOBAL SIGN ANYMORE ;MUST DO THIS TO PREVENT DMOVN ;OF COMPLEX VALUE, WHICH WOULD ;YIELD TRASH POPJ P, OCPXI: PUSHJ P,%OCTI ;GET OCTAL NUMBER SETZM %FLFSG ;ASSUME LOCAL POSITIVE VALUE DMOVE T1,@IO.ADR ;GET VALUE JUMPGE T1,CPXNN ;NEGATE IF NEGATIVE DMOVN T1,T1 SETOM %FLFSG ;GIVE LOCAL SIGN NEGATIVE CPXNN: LDB T3,[POINT 9,T1,8] ;GET BINARY EXPONENT MOVEM T3,%FLRBX ;SAVE AS RAW VALUE TLZ T1,777000 ;WIPE OUT EXPONENT ASHC T1,8 ;LEFT-JUSTIFY FRACTION DMOVEM T1,%FLRFR ;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,%FLINF ;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,%FLINF ;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 SUBTTL %NLO - Namelist Output Routine ;++ ; 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%NML ;SET FOR NMLST OUTPUT IORM T0,FLAGS(D) MOVEI T1,1 ;SET FOR 1PG OUTPUT MOVEM T1,%SCLFC 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 ADDB T1,NLVAR. ;FOR INCR TO NEXT VARIABLE MOVE T2,NLDIM. ;GET # DIMS JUMPE T2,NLOLP ;CORRECT IF SCALAR SKIPGE -1(T1) ;Array size/offset in halfwords? AOJ T1, ;NO. One extra word ADDI T1,1(T2) ;ADD # DIMS +1 IF ARRAY MOVEM T1,NLVAR. ;Set to next variable 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 PUSHJ P,%ORECS ;EOL AGAIN JRST %SETAV ;Reset & return 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 SETOM %FTSLB ;SUPPRESS LEADING BLANKS ON OUTPUT SETZM %SPFLG ;SUPPRESS LEADING PLUS SIGN NLMOLP: MOVE T1,VARTYP ;GET VARIABLE TYPE CAIN T1,TP%CHR ;Character? JRST NLDCHR ;YES. Go put out a string MOVE T1,OSIZTB(T1) ;GET SIZE OF DATA MOVEM T1,OSIZE ;MAKE ROOM FOR IT SKIPE CHRLST ;[3120]Last output character string? PUSHJ P,PUTCHK ;[3120]YES. Chk fit, RET +1 if NO, +2 if YES PUSHJ P,PUTCOM ;[3120]CHECKS CUR POS AND DATA SIZE SETZM CHRLST ;[3120]This is not a string 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 ;HOLLERITH OUTPUT - A SIDE-EFFECT OF ALLOWING EXPRESSIONS IN I/O LISTS ;IS THAT THIS CAN NOW APPEAR, WHEREAS IT COULD NOT BEFORE. WE FAKE UP ;A CHARACTER DESCRIPTOR FOR THE HOLLERITH STRING BY (YOU GUESSED IT) ;READING THE STRING TO THE END. HOLOUT: MOVE T1,IO.ADR ;GET ADDRESS $BLDBP T1 ;BUILD BYTE POINTER MOVEM T1,IO.ADR ;SAVE BYTE POINTER BACK SETZ T2, ;CLEAR COUNT HOLP: ILDB T3,T1 ;GET A CHAR JUMPE T3,HOLEND ;END IS A NULL CHAR AOJA T2,HOLP ;INCR COUNT, LOOP HOLEND: MOVEM T2,IO.SIZ ;SAVE SIZE JRST NLDCHR ;GO DO CHARACTER OUTPUT ; NLDCHR: ; Here from NLMOLP when VARTYP is found to be 15(CHARACTER- ; STRING), bypassing repeat-count checking. Now we simply ; move the string to the output buffer via 'MOVSLJ' IN ; %OMBYT. The STANDARD mandates NO value separators ; before or after character-strings, so we reset .NLFLG ; to pretend that the next value output is the 'first'. ; ; We must move the source string with no truncation or fill, ; filling the entire record where possible. First calculate ; space left in record. If source string remaining will not ; fit into available record, move available record length to ; source count, call %OMBYT to fill the record, call %SPCEOL ; to output the record and a leading space, and loop until ; the remaining source string will fit in available record. ; Then move the source count to destination count, call ; %OMBYT and return. NLDCHR: MOVE T0,FLAGS(D) ;Get flags TXNE T0,D%NML ;NAMELIST? JRST NLCHR ;YES. LDELEM: SETOM CHRLST ;[3120]to prevent value separator after this string SETZM NLFLG. PUSHJ P,%ROPOS ;[3307] get first free byte number in buffer SUBI T1,1 ;[3307] adjust to last byte used LOAD T3,TTYW(D) ;record size SUB T3,T1 ;bytes left in record JUMPLE T3,LDEOL ;[3307] At or beyond EOL, output a record JUMPN T1,LDSRCE ;At start of buffer? MOVEI T1," " ;YES. Load a space PUSHJ P,PUTCHR ;Store at beginning of record SUBI T3,1 ;[3307] Subtract leading space LDSRCE: MOVE T1,IO.ADR ;source MOVE T5,IO.SIZ ;bytes to be put out LDCHLP: MOVE T0,T5 ;bytes-to-go SUB T5,T3 ;minus bytes left in record SKIPGE T5 ;overflow? MOVE T3,T0 ; no, destination count = source MOVEI T0,(T3) ;source count always = destination count MOVEM T5,IO.EXT ;T5 crunched by %OMBYT PUSHJ P,%OMBYT ;do it SKIPG T5,IO.EXT ;Anything left in source string? JRST LDNUMS ; NO. go check for more strings PUSHJ P,%PUSHT ;[3307] Save ACs PUSHJ P,SPCEOL ;Put record & leading space PUSHJ P,%POPT ;[3307] Restore ACs LOAD T3,TTYW(D) ;Record size SUBI T3,1 ;[3307] Subtract leading space from free bytes JRST LDCHLP ;Go around again LDNUMS: SOSG IO.NUM ;More items in IOLST? POPJ P, ;NO MOVE T1,IO.INC ;Get increment ADJBP T1,IO.ADR ;Next element address MOVEM T1,IO.ADR ;Set the address JRST LDELEM ;Go put it out LDEOL: PUSHJ P,SPCEOL ;[3307] Output record and leading space LOAD T3,TTYW(D) ;[3307] Get line width again SUBI T3,1 ;[3307] Adjust for leading space JRST LDSRCE ;[3307] Go back for more NLCHR: PUSHJ P,%ROPOS ;Find out where we are (T1 points to free byte) SOS T1 ;Bytes actually put out so far MOVEM T1,NLBYT ;initialize byte counter NCHRLP: SKIPN NLFLG. ;Have we put out any values yet? JRST NLCHR1 ;NO, skip comma MOVEI T1,"," PUSHJ P,PTNLCH ;Put out a comma NLCHR1: MOVE T1,NLBYT ;Find out where we are CAIN T1,1 ;Beginning of record? JRST NLCHR2 ;YES. Don't need separator or size check MOVE T2,NLSIZ. ;String length(assume no internal quotes) ADDI T2,3 ;Add two quotes & separator LOAD T3,TTYW(D) ;Maximum record size CAILE T2,(T3) ;Can a quoted string & space possibly fit? JRST NLSEP ;NO. don't bother ADD T1,T2 ; CAIG T1,(T3) ;Will it run past end of current record? JRST NLSEP ;Hope not PUSHJ P,%ORECS ;Output the record & leading space SETZM NLBYT ;Reset NAMELIST byte-count NLSEP: MOVEI T1," " PUSHJ P,PTNLCH ;Put out a space NLCHR2: PUSHJ P,NLCRP ;CHECK FOR A REPEATED VALUE MOVE T1,NLRP. ;GET THE REPEAT COUNT CAIG T1,1 ;IS IT 1? JRST NLCHR3 ;YES PUSHJ P,NLORP ;.GT.1. OUTPUT WITH * PUSHJ P,%ROPOS ;Get byte position of first free byte SOS T1 ;Convert to byte count MOVEM T1,NLBYT ;Set current byte count NLCHR3: MOVEI T1,"'" ;Initial quotation mark PUSHJ P,PTNLCH ;Put it out MOVE T5,NLSIZ. ;String length NLCHLP: ILDB T1,NLADD. ;Load next byte CAIE T1,"'" ;Is it a quote? JRST NCHLP1 ; NO. PUSHJ P,%ROPOS ;Get byte position of next free byte LOAD T2,TTYW(D) ;Get position of last byte in record CAIL T1,(T2) ;Is it the last byte? PUSHJ P,SPCEOL ; YES MOVEI T1,"'" ;Reload the quote PUSHJ P,PTNLCH ;Put out leading quote NCHLP1: PUSHJ P,PTNLCH ;Put out the character SOJG T5,NLCHLP ;Loop thru string MOVEI T1,"'" ;Load a quote PUSHJ P,PTNLCH ;Put it out SETOM NLFLG. ;Flag that we did it SKIPN NLNUM. ;Any more strings? POPJ P, ;NO. MOVE T1,NLRP. ;Repeat count SOS T1 ;We just put one out IMUL T1,NLINC. ;Calculate offset to next variable ADJBP T1,NLADD. ;Adjust to address/next variable MOVEM T1,NLADD. ;Store address/next variable MOVEM T1,IO.ADR ;Store for NLCSTR JRST NCHRLP ;Loop thru IOLST SEGMENT DATA IO.EXT: BLOCK 1 ; SEGMENT CODE ;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. MOVE T0,VARTYP ;GET VARIABLE TYPE CAIN T0,TP%CHR ;CHARACTER? JRST NLCSTR ;YES. GO DO BYTE STRING COMPARISONS 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 ;NLCSTR: ; Compares strings for repeated values. NLCSTR: SOSG NLNUM. ;[3272]Any more elements? POPJ P, ;NO MOVE T1,NLINC. ;Byte size MOVEI T3,(T1) ;Save byte size for comparison MOVE T4,NLADD. ;Current string ADJBP T1,IO.ADR ;Point to next element MOVEM T1,IO.ADR ;Store the pointer MOVEI T0,(T3) ;String counts are the same EXTEND T0,[CMPSE " " " "] ;Strings identical? POPJ P, ;NO AOS NLRP. ;Count repeated string JRST NLCSTR ;Loop thru iolst ;+ ; NLONAM - OUTPUT A SIXBIT NAME TO THE DATA FILE ;- NLONAM: MOVEI T1,6 ;MAX COUNT MOVEM T1,NLRP. ;SAVE IT MOVE T1,[POINT 6,NLNAM.];[5011] MAKE A BYTE POINTER TO CHAR MOVEM T1,NLVAL. ;[5011]SAVE IT ILDB T1,T1 ;[5011] GRAB THE FIRST BYTE JUMPN T1,NLONLP ;[5011] IF IT'S NULL THEN ITS A POINTER MOVE T1,NLNAM. ;[5011] GET ADDRESS OF STRING $BLBP6 T1 ;[5011]MAKE A BYTE POINTER TO STRING MOVEM T1,NLVAL. ;[5011] SAVE IT MOVEI T1,37 ;[5012] MAX STRING LENGTH MOVEM T1,NLRP. ;[5011] 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, ;[5011] End of routine NLONAM ;NLORP - OUTPUT REPEAT COUNT AND * NLORP: XMOVEI T1,NLRP. ;GET REPEAT COUNT ADDR MOVEM T1,IO.ADR ;SAVE IT MOVEI T1,TP%INT ;USE SINGLE INTEGER MOVEM T1,IO.TYP ;FOR DATA TYPE FOR %GINTO PUSHJ P,%GINTO ;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,%ROPOS ;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,%ROPOS ;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 CAN BE ;DONE HERE AND BE GLOBAL FOR ALL OF NAMELIST OUTPUT. SEGMENT DATA NLBYT: BLOCK 1 SEGMENT CODE PTNLCH: AOS NLBYT ;Count this byte LOAD T2,TTYW(D) ;Record size CAML T2,NLBYT ;Will we overflow the line? JRST PUTCHR ;NO PUSH P,T1 ;Save the character PUSHJ P,SPCEOL ;Output record & a leading space MOVEI T1,1 ;Count the space MOVEM T1,NLBYT ;Reset output count POP P,T1 ;Get the character JRST PTNLCH ;It better go out this time!!! PUTCHR==%OBYTE ;THIS IS THE TABLE OF "OUTPUT SUBROUTINES BY TYPE". THE VARIABLE ;TYPE IS USED AS THE INDEX INTO THE TABLE. OUTSUB: IFIW %GINTO ;0 NOT SPECIFIED IFIW %LOUT ;1 LOGICAL IFIW %GINTO ;2 INTEGER IFIW NONO ;3 IFIW %GROUT ;4 SINGLE REAL IFIW NONO ;5 IFIW %OCTO ;6 SINGLE OCTAL IFIW NONO ;7 STATEMENT LABEL IFIW %GROUT ;10 DOUBLE REAL IFIW NONO ;11 DOUBLE INTEGER IFIW %OCTO ;12 DOUBLE OCTAL IFIW %GROUT ;13 EE DOUBLE REAL IFIW CPXO ;14 COMPLEX IFIW NONO ;15 COBOL BYTE STRING IFIW NONO ;16 IFIW HOLOUT ;17 ASCIZ NLGET: JFCL MOVE T1,@NLADD. DMOVE T1,@NLADD. ;OUTPUT DATA ELEMENT SIZE TABLE - GIVES MAXIMUM SIZE OF A DATA ELEMENT ;BASED ON ITS DATA TYPE OSIZTB: ^D14 ;0 (BADLY SPECIFIED INTEGER) 3 ;1 LOGICAL ^D14 ;2 INTEGER 0 ;3 ^D16 ;4 REAL 0 ;5 0 ;6 0 ;7 ^D16 ;10 DOUBLE REAL 0 ;11 0 ;12 ^D16 ;13 EE DOUBLE REAL ^D32 ;14 COMPLEX 0 ;15 0 ;16 0 ;17 ;CPXO - SIMILAR TO CPXI - SINCE THERE IS NO OFFICIAL ROUTINE ;FOR COMPLEX VARIABLE OUTPUT, WE HAVE TO DO IT HERE, SENDING ;EACH PART OUT THROUGH %GROUT (WHICH MUST BE FOOLED INTO ;THINKING THE VARIABLE TYPE IS SINGLE REAL...). CPXO: MOVEI T1,TP%SPR ;MAKE THE TYPE SINGLE REAL MOVEM T1,IO.TYP MOVEI T1,"(" ;OUTPUT LEFT PAREN PUSHJ P,PUTCHR PUSHJ P,%GROUT ;OUTPUT REAL PART MOVEI T1,TP%SPR ;USE REAL DATA SIZE MOVE T1,OSIZTB(T1) ;FROM SIZE TABLE MOVEM T1,OSIZE ;TO CHECK FOR ENOUGH ROOM MOVEI T1,"," ;OUTPUT COMMA PUSHJ P,PUTCHR PUSHJ P,PUTCHK ;AND CHECK FOR LINE-TOO-LONG PUSHJ P,SPCEOL ;IN WHICH CASE OUTPUT EOL XMOVEI T1,NLVAL.+1 ;OUTPUT IMAGINARY PART MOVEM T1,IO.ADR ;SAVE FOR OUTPUT PUSHJ P,%GROUT MOVEI T1,")" ;OUTPUT RIGHT PAREN PJRST PUTCHR NONO: $SNH ;NONEXISTENT OUTPUT ROUTINE PURGE $SEG$ END