Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
fornml.mac
There are 9 other files named fornml.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORNML NAMELIST AND LIST-DIRECTED I/O 7(4153)
SUBTTL NAME LIST SEQUENTIAL ACCESS CALLING SEQUENCES - 28-Oct-81
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;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 *****
***** 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. 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 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: 012 89 12 14 1718 35
------------------------------------
! SIXBIT /ARRAY NAME/ !
------------------------------------
!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
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
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 1 ;NAME 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
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,
;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
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,<T1>)
$ACALL VNN ;?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: 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 "=",<T1>)
$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 VARIABLE NAME
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
;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,)
$ACALL ILN
MOVEI P2,6 ;6 CHARS TOTAL
SKIPA P3,[POINT 6,NLNAM.] ;SIXBIT PNTR, ALREADY GOT 1ST CHAR
NLINL1: PUSHJ P,GETCHR ;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,GETCHR ;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
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,
;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*<BLANK>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
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
;(<CRLF>) 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
;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
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
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