Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/24/input.mac
There are 2 other files named input.mac in the archive. Click here to see a list.
COMMENT * SIMULA specification;
OPTIONS(/E:CODE,NOCHECK,input);
INTEGER PROCEDURE input;!(fileref,[[,item]...]);
COMMENT Inputs successive items from a file which is IN Infile
or Directfile. Image is not used - input is directly from the buffers;
!*;! MACRO-10 code !*;!
TITLE input
ENTRY input
search simmac,simmcr,simrpa
sall
macinit
SUBTTL SIMULA utility, Lars Enderin Oct 1975
count==ZBI%S
fileref==ZBI%S+1
nextparam==fileref+1
firstpar==fileref+2
DEFINE ops(A)<
IRP A,<
OPDEF A [PUSHJ XPDP,A]
>>
ops <pointers,inputword,inputtext,inputref,inputarray,newbuffer>
ops <inputmove>
XSP== 13
XBH== 7
XFIL== XWAC3
XBP== XWAC4
XLI== XL
XPT== 14 ;!??
cnt==OFFSET(ZBHCNT)
bup==OFFSET(ZBHBUP)
maxoffset==^d31
DEFINE inputerr(n,t)<
EXEC .inputerr
n+"0",,[ASCIZ/t/]
>
DEFINE normalize(xp)<
IF TLNE xp,400000
GOTO FALSE
THEN HRLI xp,440700
ADDI xp,1
FI
>
OPDEF COMPBLOCK [PUSHJ XPDP,IOCB]
OPDEF COMPSTART [PUSHJ XPDP,IOCS]
OPDEF READBLOCK [PUSHJ XPDP,IORB]
OPDEF ERRFILE [PUSHJ XPDP,IOERF]
SUBTTL input
input: PROC
;! Compute file ref and check it
IF ;! No thunk
SKIPL X1,fileref(XCB)
GOTO FALSE
THEN ;! Easy access to value
HRRZ X2,fileref+1(XCB)
ADDI X2,(X1)
L XWAC1,(X2) ;! file reference
ELSE ;! Use RTS routine
LI XWAC1,(XCB)
HRLI XWAC1,fileref
EXEC PHFV
XWD 0,0
FI
ST XWAC1,fileref(XCB) ;! save the computed value for later
LF X2,ZBIZPR(XWAC1)
LOOP ;! Check qualif
CAIE X2,IOIN
CAIN X2,IODF
GOTO L1 ;! Ok!
LF X2,ZCPZCP(X2)
AS ;! long as there is a prefix
JUMPN X2,TRUE
SA
inputerr 3,Wrong file type
GOTO inpend
L1():! IFON ZIFEND(XWAC1)
GOTO EOFERR
IF ;! No more data
IFOFF ZFIEND(XWAC1)
GOTO FALSE
THEN ;! Set ENDFILE, return 0
SETON ZIFEND(XWAC1)
GOTO inpend
FI
L [Z firstpar(XCB)]
ST nextparam(XCB)
IF ;! Directfile
CAIE X2,IODF
GOTO FALSE
THEN ;! Check for end of file condition before proceeding
LFE ,ZDFLOC(XWAC1)
JUMPLE inpeof
LF X1,ZDFLIM(XWAC1)
CAILE (X1)
GOTO inpeof
SETOFF ZDFOUT(XWAC1) ;!Signal input (not output)
IF ;! First input or output after Locate
IFON ZFIPGT(XWAC1)
GOTO FALSE
THEN ;! Must input correct block, compute byte pointer
pointers
COMPBLOCK
STACK X1 ;! Used by COMPSTART as parameter in stack
LF X1,ZDFBLK(XWAC1)
CAIE (X1)
READBLOCK ;! If different block
COMPSTART
UNSTK X1
SETON ZFIPGT(XWAC1)
FI
ELSE ;! Infile
L XFIL,XWAC1
LF XBH,ZFIIBH(XFIL)
SUBI XBH,1
L XBP,bup(XBH)
WHILE ;! Not on a word boundary
TLNN XBP,300000
GOTO FALSE
DO ILDB XBP
SOS cnt(XBH)
SKIPE ;! Do not count null character
AOS count(XCB)
OD
ST XBP,bup(XBH)
FI
;! Handle one parameter here
;! -------------------------
L2():! LI XWAC2,@nextparam(XCB)
LD XWAC1,(XWAC2)
JUMPE XWAC1,inpend
pointers
IF ;! File is not open
IFON ZFIOPN(XFIL)
GOTO FALSE
THEN inputerr 4,File not open
BRANCH inpend
FI
LF X1,ZFLAKD(,XWAC1)
LF X2,ZFLATP(,XWAC1)
IF ;! Kind is simple
CAIE X1,QSIMPLE
GOTO FALSE
THEN
L3():! IF ;! No thunk
JUMPGE XWAC1,FALSE
THEN ;! Get dyn address directly
HRLI XWAC1,(XWAC2)
ADDI XWAC2,(XWAC1) ;! Abs address
CAIN X2,QREF ;! We need the value of a REF
L XWAC1,(XWAC2)
ELSE ;! via PHFA, PHFV or PHFT
LI X1,PHFA
CAIN X2,QTEXT
LI X1,PHFT
CAIN X2,QREF ;![130]
LI X1,PHFV
LI XWAC1,(XCB)
HRL XWAC1,nextparam(XCB)
EXEC 0(X1)
XWD 0,0
L @nextparam(XCB)
LF X1,ZFLAKD
LF X2,ZFLATP
HLRZ XWAC2,XWAC1
ADDI XWAC2,(XWAC1) ;! Abs address
pointers ;! reconstructed
FI
IF ;! Simple value type
CAIL X2,QTEXT
GOTO FALSE
THEN ;![130] Must not be an expression
IF
IFOFFA ZFLVTD(XWAC1)
GOTO FALSE
THEN inputerr 2,Expression not allowed
FI
inputword
ST (XWAC2)
IF ;![130] Long real
CAIE X2,QLREAL
GOTO FALSE
THEN ;!One more word
inputword
ST 1(XWAC2)
FI
ELSE
IF ;![130] Constant
HRRZ @nextparam(XCB)
JUMPN FALSE
THEN ;! Constants have no block address
inputerr 2,Constant not allowed
ELSE
IF ;! TEXT
CAIE X2,QTEXT
GOTO FALSE
THEN ;! We have dynamic address of text var in XWAC1
;! Save in ZFL
ST XWAC1,@nextparam(XCB)
inputtext
HLRZ X1,@nextparam(XCB)
ADD X1,@nextparam(XCB)
STD XWAC1,(X1)
ELSE
IF ;! REF
CAIE X2,QREF
GOTO FALSE
THEN inputref
ELSE ;! Wrong type
inputerr 1,Wrong type
FI FI FI FI
ELSE ;! Not of simple kind, may be array or parameterless procedure
IF ;![130] It is a procedure
CAIE X1,QPROCEDURE
GOTO FALSE
THEN ;! Error unless TEXT or REF
CAIE X2,QTEXT
CAIN X2,QREF
GOTO L3
inputerr 2,Expression or procedure not allowed
ELSE
IF ;! Array
CAIE X1,QARRAY
GOTO FALSE
THEN LI XWAC1,(XCB)
HRL XWAC1,nextparam(XCB)
EXEC PHFM
XWD 0,0
pointers ;! reconstructed
inputarray
ELSE
inputerr 2,Wrong kind
FI FI FI
HRRZ nextparam(XCB)
ADDI 2
HRRM nextparam(XCB)
CAIL maxoffset
GOTO inpend
GOTO L2 ;! Fetch next parameter
EOFERR: inputerr 6,End of file
GOTO inpend
inpeof: HRROS count(XCB) ;![126] Signal incomplete input
SETON ZIFEND(XFIL)
;! GOTO inpend
inpend: LOWADR
HRRI XPDP,YOBJRT-1(XLOW)
HRLI XPDP,-QPDLEN
L count(XCB)
IF ;! We had some error
JUMPGE FALSE
THEN ;! Return -rh as result
HRRZ
MOVN
FI
ST count(XCB)
BRANCH CSEP
EPROC ;! input
SUBTTL pointers
pointers:
L XFIL,fileref(XCB)
LF XBH,ZFIIBH(XFIL)
SUBI XBH,1
L XBP,bup(XBH)
normalize(XBP)
ST XBP,bup(XBH)
RETURN
SUBTTL inputword
inputword:PROC
SKIPG cnt(XBH)
NEWBUFFER
MOVNI 5 ;! Account for one word taken out of buffer
ADDM cnt(XBH)
LI 5
ADDM count(XCB)
L (XBP) ;! Pick up one word
AOS XBP,bup(XBH)
RETURN
EPROC
SUBTTL inputtext
inputtext:PROC
inputword
IF ;! NOTEXT
JUMPN FALSE
THEN ;! No more input
SETZB XWAC1,XWAC2
ELSE ;! Allocate a new text and copy to it from file
L XWAC1,
EXEC TXBL
XWD 0,0
pointers
LF XLI,ZTELEN(XWAC1)
SUBI XLI,2
LI X2,2(XWAC1) ;! Start of text
IMULI XLI,5
inputmove
FI
RETURN
EPROC
SUBTTL inputarray
inputarray:
PROC
L X1,XWAC1
LF X2,ZARSUB(X1)
IMULI X2,3
ADDI X2,3
;! Number of words
LF XLI,ZARLEN(X1)
SUBI XLI,(X2)
ADDI X2,(X1)
LF ,ZARTYP(X1)
IF ;! Value type
CAIL QTEXT
GOTO FALSE
THEN ;! Copy the whole array directly from file
IMULI XLI,5
inputmove
ELSE ;! TEXT or REF array
CAIE QTEXT
GOTO L9 ;! Do not output REF array at all
LOWADR
objad==YSUPCP
ST XWAC1,objad(XLOW)
MOVNI XPT,(XLI)
MOVSS XPT
HRRI XPT,(X2)
SUBI XPT,(XWAC1)
STACK XPT
LOOP
ST XPT,(XPDP)
inputtext
LOWADR
HRRZ X1,objad(XLOW)
ADDI X1,(XPT)
STD XWAC1,(X1)
AS
AOBJP XPT,.+1
AOBJN XPT,TRUE
SA
UNSTK
SETZM objad(XLOW)
FI
L9():! RETURN
EPROC ;! inputarray
SUBTTL inputref
XREF==XPT;! Points to class object
XMP==XM ;! Map pointer
XPR==X10;! Prototype pointer
OPDEF loadref [HRRZ XREF,@nextparam(XCB)]
inputref: PROC
LI X1,@nextparam(XCB)
LD X0,(X1)
LF XPR,ZFLZQU ;! Prototype
IF ;! Object contains protected attributes on or outside this level
IFOFF ZCPPTA(XPR)
GOTO FALSE
THEN ;! Cannot input it
inputerr 5,Class obj contains protected attributes
BRANCH L9
FI
ST XWAC1,@nextparam(XCB) ;! Save object address
L1():! loadref
inputword
CAIN NONE
GOTO L9 ;! Nothing to read if only output was NONE
IF ;! Identical prototype
CAIE (XPR)
GOTO FALSE
THEN ;! No further check should be needed
;! No code for this case yet
NOP
FI
LF X2,ZCPPRL(XPR) ;! Prefix level
LF XK,ZPCNRP(XPR) ;! Number of parameters
L X1,XK
HRL X1,X2
inputword ;! PRL,,NRP
IF ;! Different
CAME X1
GOTO FALSE
THEN ;! Number of parameters may possibly be different
XOR X1
IF ;! Prefix levels differ
TLNN -1
GOTO FALSE
THEN ;! Error
inputerr 8,inputref wrong prefix level
GOTO L9
FI FI
IF ;! We have any parameters
JUMPE XK,FALSE
THEN ;! check that descriptors match except for REF
LI XL,OFFSET(ZPCZFP)(XPR)
LOOP
LF X1,ZTDTYP(XL)
IF ;! Not REF
CAIN X1,QREF
AOJA XL,FALSE ;! Skip extra word also
THEN ;! input
inputword
XOR (XL)
IF ;! First half does not match
TLNN -1
GOTO FALSE
THEN ;! Error
inputerr 8, inputref par mismatch
GOTO L9
FI FI
ADDI XL,1
AS
SOJG XK,TRUE
SA
inputword ;! This word should be zero
IF ;! Not zero
JUMPE FALSE
THEN ;! Error
inputerr 8,inputref par mismatch
GOTO L9
FI
FI
;! input and check map for this prefix level
LF XMP,ZPRMAP(XPR) ;! Point to map
WLF X1,ZMPNOV(XMP)
inputword
IF ;! [227] Map pointer is zero
JUMPN XMP,FALSE
THEN ;! Must match with -1 now
AOJE L2
inputerr 8,Object structure error
FI
CAMN [-1] ;! [227]
SETZ ;! [227] Force error if no map on output
XOR X1
TLNE -1
BRANCH [inputerr 8,wrong number of non-refs non-arrays
GOTO L9()]
WLF X1,ZMPNTX(XMP)
inputword
XOR X1
TLNE -1
BRANCH [inputerr 8,wrong number of texts
GOTO L9()]
;! Identify arrays
WLF XL,ZMPNRV(XMP)
IF ;! Any REF and/or ARRAY
JUMPE XL,FALSE
THEN ;! Find all arrays, input and check identification for non-REF arrays
ADDI XL,(XREF) ;! AOBJN word
LOOP
L XM,(XL)
IF ;! non-REF ARRAY
CAIN XM,NONE
GOTO FALSE
LF ,ZDNTYP(XM)
CAIE QZAR
GOTO FALSE
LF ,ZARTYP(XM)
CAIN QREF
GOTO FALSE
THEN ;! input size, nsub, type in one word
LF X1,ZARLEN(XM)
HLL X1,OFFSET(ZARSUB)(XM) ;![126]
inputword
CAME X1
BRANCH [inputerr 8,array not compatible
GOTO L9()]
FI
AS
INCR XL,TRUE
SA
FI
;! Final zero closes array specs
inputword
JUMPN [inputerr 0,phase error inputref
GOTO L9()]
;! Handle prefix chain
L2():! LF XPR,ZCPZCP(XPR)
JUMPN XPR,L1
inputword ;! End of identification list
JUMPN [inputerr 0,phase error inputref
GOTO L9()]
SUBTTL inputref, input of attribute values
;! input of values for one prefix level
;! -------------------------------------
loadref
LI X1,@nextparam(XCB)
LD X0,(X1)
LF XPR,ZFLZQU
L4():! LF XK,ZPCNRP(XPR) ;! [227] Go here for each prefix level
IF ;! Parameters exist
JUMPE XK,FALSE
THEN ;! input all but REF
MOVNI (XK)
LI XK,OFFSET(ZPCZFP)(XPR)
HRLM XK
LOOP
LF X1,ZTDTYP(XK)
IF ;! NOT REF
CAIN X1,QREF
GOTO FALSE
THEN
LF ,ZPDKND(XK)
IF ;! ARRAY
CAIE QARRAY
GOTO FALSE
THEN
LF X2,ZFPOFS(XK) ;![126]
ADDI X2,(XREF) ;![126]
L XWAC1,(X2)
inputarray
loadref
ELSE
CAIE QSIMPLE
RFAIL inputref wrong par kind
IF ;! Simple value type
CAIL X1,QTEXT
GOTO FALSE
THEN
inputword
LF X2,ZFPOFS(XK) ;![126]
ADDI X2,(XREF) ;![126]
ST (X2)
IF ;! LONG REAL
CAIE X1,QLREAL
GOTO FALSE
THEN inputword
ST 1(X2)
FI
ELSE ;! Must be TEXT
CAIE X1,QTEXT
RFAIL inputref wrong par type
inputtext
loadref
LF X2,ZFPOFS(XK) ;![126]
ADDI X2,(XREF) ;![126]
STD XWAC1,(X2) ;![126]
FI FI
ELSE ;! Skip extra word
AOS XK
FI
AS
INCR XK,TRUE
SA
FI
;! Now input attributes according to map
;!---------------------------------------
LF XMP,ZPRMAP(XPR)
JUMPE XMP,L8 ;! [227]
LFE XLI,ZMPNOV(XMP)
LFE XK,ZMPNTX(XMP)
SUB XLI,XK ;! Number of non-ref, non-text, non-array variables
IF ;! Any such variables
JUMPE XLI,FALSE
THEN ;! input them all via inputmove
LF X2,ZMPDOV(XMP)
ADDI X2,(XREF)
MOVMS XLI
IMULI XLI,5 ;! Number of characters
inputmove
FI
IF ;! Any TEXT
WLF XK,ZMPNTX(XMP)
JUMPE XK,FALSE
THEN
LOOP
inputtext
loadref ;! Restore XREF in case of GC
L X1,XREF ;![126]
ADDI X1,(XK) ;![126]
STD XWAC1,(X1) ;![126]
AS
AOBJP XK,.+1
AOBJN XK,TRUE
SA
FI
;! Input any arrays
WLF XL,ZMPNRV(XMP)
IF ;! Any REF and/or ARRAY
JUMPE XL,FALSE
THEN ;! Find all arrays, input values for non-REF arrays
ADDI XL,(XREF) ;! AOBJN word
LOOP
L XWAC1,(XL)
IF ;! non-REF ARRAY
CAIN XWAC1,NONE
GOTO FALSE
LF ,ZDNTYP(XWAC1)
CAIE QZAR
GOTO FALSE
LF ,ZARTYP(XWAC1)
CAIN QREF
GOTO FALSE
THEN ;! Input values
inputarray
FI
AS
AOBJN XL,TRUE
SA
FI
;! Final zero closes array specs
inputword
JUMPN [inputerr 0,phase error inputref
GOTO L9()]
L8():! LF XPR,ZCPZCP(XPR)
JUMPN XPR,L4
L9():! RETURN
EPROC
SUBTTL newbuffer
newbuffer:
PROC
SAVE <X0,X1,X2,XWAC1>
HRRZ XWAC1,fileref(XCB)
SETON ZFINB(XWAC1)
READBLOCK
SETOFF ZFINB(XWAC1)
L XBP,bup(XBH)
IFON ZFIEND(XWAC1)
BRANCH inpeof
RETURN
EPROC
SUBTTL inputmove
inputmove:PROC
IF ;! Only one word
CAILE XLI,5
GOTO FALSE
THEN ;! Use inputword
inputword
ST (X2)
RETURN
FI
SAVE <X2,XJ,XK,XLI>
L1():! SETZ XJ, ;! No truncation yet
L XK,XLI
SKIPG cnt(XBH)
NEWBUFFER
IF ;! Buffer does not have it all
CAMG XK,cnt(XBH)
GOTO FALSE
THEN ;! Move what fits
L XK,cnt(XBH)
SUBI XLI,(XK)
HRROS XJ ;! Flag truncation
FI
L XK
IDIVI 5
ST XK
IMULI 5
ADDM count(XCB)
MOVNS
ADDM cnt(XBH)
;! BLT word in X0
L XBP,bup(XBH)
normalize(XBP)
LI (X2)
HRLI (XBP)
ADDI XBP,(XK)
ADDI X2,(XK)
ST XBP,bup(XBH)
BLT -1(X2) ;! Move info
JUMPL XJ,L1
RETURN
EPROC
SUBTTL inputerr
.inputerr:PROC
SAVE X1
N==1 ;! One saved value on stack
Outstr [ASCIZ/input error /]
HLRZ X1,@-N(XPDP)
Outchr X1
Outstr [ASCIZ/, /]
HRRZ X1,@-N(XPDP)
Outstr (X1)
Outstr [ASCIZ/
/]
HRRZ XWAC1,fileref(XCB)
ERRFILE
RTSERR QDSCON,214 ;! ??
AOS -N(XPDP) ;! Skip return
HRROS count(XCB) ;! Signal error exit
RETURN
EPROC
LIT
END;