COMMENT * SIMULA specification; OPTIONS(/E:CODE,NOCHECK,output); INTEGER PROCEDURE output;!(fileref,[[,item]...]); COMMENT outputs successive items on a file which is IN Outfile or Directfile. Image is not used - output is directly to the buffers; !*;! MACRO-10 code !*;! ifndef qpz, ;! Default - generate output rel file ife qpz,< TITLE output ENTRY output > ifn qpz,< ;! Generate putsize.rel from this file if qpz=/=0 TITLE putsize ENTRY putsize > search simmac,simmcr,simrpa sall macinit SUBTTL SIMULA utility, Lars Enderin Nov 1975 ;!*** Copyright 1975 by the Swedish Defence Research Institute. *** ;!*** Copying is allowed. *** DF BYTESIZE,0,6,11 ;! Byte size field of byte pointer count==ZBI%S fileref==ZBI%S+1 nextparam==fileref+1 firstpar==fileref+2 DEFINE ops(A)< IRP A,< OPDEF A [PUSHJ XPDP,A] >> ops ife qpz,< ops > XSP== 13 XBH== 7 XFIL== XWAC3 XBP== XWAC4 XLI== XL XPT== 14 maxoffset==^d31 ifn qpz,< nextparam==maxoffset+1 maxoffset==maxoffset-2 firstpar==fileref opdef putword [AOS count(XCB)] opdef putmove [ADDM XLI,count(XCB)] define pointers <> define errfile <> > cnt==OFFSET(ZBHCNT) bup==OFFSET(ZBHBUP) DEFINE puterr(n,t)< EXEC .puterr n+"0",,[ASCIZ/t/] > ife qpz,< 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] > ife qpz,< SUBTTL output output: 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 CAIN X2,IOPF ;! Printfile disallowed GOTO FALSE CAIE X2,IOOU ;! Outfile or CAIN X2,IODF ;! Directfile are GOTO L1 ;! Ok! LF X2,ZCPZCP(X2) AS ;! long as there is a prefix JUMPN X2,TRUE SA puterr 3,Wrong file type GOTO PUTEND L1():! L [Z firstpar(XCB)] ST nextparam(XCB) IF ;! Directfile CAIE X2,IODF GOTO FALSE THEN SETON ZDFOUT(XWAC1) ;! Signal output (not input) IF ;! First output or input after Locate IFON ZFIPGT(XWAC1) GOTO FALSE THEN ;! Must get 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 ;! Outfile L XFIL,XWAC1 LF XBH,ZFIOBH(XFIL) SUBI XBH,1 L XBP,bup(XBH) IF ;! First put after Outimage, but not first output L OFFSET(ZFIPGT)(XFIL) IFONA ZFIPGT GOTO FALSE IFOFFA ZFILBO IFONA ZFIFO GOTO FALSE THEN ;! Insert line feed SOSGE cnt(XBH) NEWBUFFER LI QLF IDPB XBP SETON ZFIPGT(XFIL) FI WHILE ;! Not on a word boundary TLNN XBP,300000 GOTO FALSE DO IBP XBP SOS cnt(XBH) OD ST XBP,bup(XBH) FI ;! Handle one parameter here ;! ------------------------- L2():! pointers IF ;! File is not open IFON ZFIOPN(XFIL) GOTO FALSE THEN puterr 4,File not open BRANCH PUTEND FI > ;! end of ife ifn qpz,< putsize:PROC L [Z firstpar(XCB)] ST nextparam(XCB) L2():! > ;! end of ifn LI XWAC2,@nextparam(XCB) LD XWAC1,(XWAC2) JUMPE XWAC1,PUTEND 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 value directly ADDI XWAC2,(XWAC1) LD XWAC1,(XWAC2) ELSE ;! via PHFV LI XWAC1,(XCB) HRL XWAC1,nextparam(XCB) EXEC PHFV XWD 0,0 L @nextparam(XCB) LF X2,ZFLATP pointers ;! reconstructed FI L XWAC1 IF ;! Long real CAIE X2,QLREAL GOTO FALSE THEN putword L XWAC2 putword ELSE IF ;! Simple value type CAIL X2,QTEXT GOTO FALSE THEN putword ELSE IF ;! TEXT CAIE X2,QTEXT GOTO FALSE THEN puttext ELSE IF ;! REF CAIE X2,QREF GOTO FALSE THEN PUTREF ELSE ;! Wrong type puterr 1,Wrong type FI FI FI FI ELSE ;! Not of simple kind, may be array or parameterless procedure CAIN X1,QPROCEDURE GOTO L3 ;! Must be parameterless if proc IF ;! Array CAIE X1,QARRAY GOTO FALSE THEN LI XWAC1,(XCB) HRL XWAC1,nextparam(XCB) EXEC PHFM XWD 0,0 pointers ;! reconstructed putarray ELSE puterr 2,Wrong kind FI FI HRRZ nextparam(XCB) ADDI 2 HRRM nextparam(XCB) CAILE maxoffset GOTO PUTEND ife qpz,< IFOFF ZFIDF(XFIL) GOTO L2 ;! Update word count for Directfile wordcount SETON ZDFMOD(XFIL) ;! Mark buffer as modified > GOTO L2 ;! Fetch next parameter PUTEND: ;! Restore XPDP to stack bottom 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 IMULI 5 ;! Number of char's per word ST count(XCB) ife qpz,< ;! Adjust ZDFLIM for directfile IFOFF ZFIDF(XFIL) ;![130] GOTO L9 pointers wordcount ;! X0 = words written by output in THIS block LF X2,ZDFIML(XFIL) ADDI X2,4 IDIVI X2,5 ;! Number of words per image LF X3,ZDFBLK(XFIL) ;! Current disk block SUBI X3,1 IMULI X3,200 ;! Number of words in all preceding blocks ;! Number of words written in X0 from wordcount call ADD X3 ;![130] ADDI -1(X2) ;! Rounding upwards IDIVI (X2) ;! Gives number of last written image now LF X1,ZDFLIM(XFIL) CAILE (X1) > SF ,ZDFLIM(XFIL) L9():! pointers ;![126] IF ;![126] Byte pointer is too large TLNN XBP,400000 GOTO FALSE THEN ;! Make it point to last word written SUBI XBP,1 HRLI XBP,010700 ST XBP,bup(XBH) FI ;![126] BRANCH CSEP EPROC ;! output or putsiz ife qpz,< SUBTTL pointers pointers: L XFIL,fileref(XCB) LF XBH,ZFIOBH(XFIL) SUBI XBH,1 L XBP,bup(XBH) normalize(XBP) ST XBP,bup(XBH) RETURN SUBTTL wordcount wordcount: LI (XBP) ;! Addr of last written word+1 LF X1,ZBHZBU(XBH) SUBI 2(X1) ;! Length of data in buffer (words) LF X1,ZDFWCT(XFIL) CAIL (X1) SF ,ZDFWCT(XFIL) RETURN SUBTTL putword putword:PROC SKIPG cnt(XBH) NEWBUFFER ST (XBP) ;! Store the word MOVNI 5 ADDM cnt(XBH) AOS XBP,bup(XBH) AOS count(XCB) RETURN EPROC SUBTTL puttext puttext:PROC SAVE LF XLI,ZTVLNG(,XWAC1) L XLI putword ;! Number of characters only IF ;! NOT NOTEXT JUMPLE XLI,FALSE THEN ;! Handle text LF X2,ZTVZTE(,XWAC1) ADDI X2,2 LF XSP,ZTVSP(,XWAC1) IF ;! Non-zero offset JUMPE XSP,FALSE THEN ;! Update adress, offset less than 5 IDIVI XSP,5 ADDI X2,(XSP) L XSP,XSP+1 FI IF ;! Word aligned text and enough to bother JUMPN XSP,FALSE CAIGE XLI,6*5 ;! 6 words enough?? GOTO FALSE THEN ;! Use putmove L XLI IDIVI 5 IMULI 5 ST XLI STACK X1 ;! Number of remaining char's at end putmove UNSTK XLI ;! Remaining number of char's in text JUMPLE XLI,L9 FI LOOP ;! Output characters properly shifted into words L (X2) IF JUMPE XSP,FALSE THEN L X1,1(X2) LSH -1 XCT shift(XSP) TRZ 1 FI CAIG XLI,4 AND mask(XLI) putword AS SUBI XLI,5 ADDI X2,1 JUMPG XLI,TRUE SA FI L9():! RETURN EPROC shift=.-1 LSHC 1*7+1 LSHC 2*7+1 LSHC 3*7+1 LSHC 4*7+1 mask=.-1 q==177 BYTE (7)Q,0,0,0,0(1)0 BYTE (7)Q,Q,0,0,0(1)0 BYTE (7)Q,Q,Q,0,0(1)0 BYTE (7)Q,Q,Q,Q,0(1)0 > ifn qpz,< puttext:LF ,ZTVLNG(,XWAC1) ADDI 1*5+5-1 IDIVI 5 ADDM count(XCB) RETURN > SUBTTL putarray putarray: PROC SAVE LF X2,ZARSUB(XWAC1) IMULI X2,3 ADDI X2,3 ;! Number of words LF XLI,ZARLEN(XWAC1) SUBI XLI,(X2) ADDI X2,(XWAC1) LF ,ZARTYP(XWAC1) IF ;! Value type CAIL QTEXT GOTO FALSE THEN ;! Copy the whole array directly to file ife qpz,< IMULI XLI,5 > putmove ELSE ;! TEXT or REF array CAIE QTEXT GOTO L9 ;! Do not output REF array at all MOVNI XPT,(XLI) MOVSS XPT HRRI XPT,(X2) LOOP LD XWAC1,(XPT) puttext AS AOBJP XPT,.+1 AOBJN XPT,TRUE SA FI L9():! RETURN EPROC ;! putarray SUBTTL putref XREF==XPT;! Points to class object XMP==XM ;! Map pointer XPR==X10;! Prototype pointer putref: PROC IF ;! NONE CAIE XWAC1,NONE GOTO FALSE THEN ;! Just output NONE LI NONE putword GOTO L9 FI 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 output it puterr 5,Class obj contains potected attributes BRANCH L9 FI ST XWAC1,@nextparam(XCB) ;! Save object address L1():! HRRZ XREF,@nextparam(XCB) L XPR ;! Identify by prototype address - to be elaborated putword LF X2,ZCPPRL(XPR) ;! Prefix level LF XK,ZPCNRP(XPR) ;! Number of parameters L XK HRL X2 putword ;! PRL,,NRP IF ;! We have any parameters JUMPE XK,FALSE THEN ;! Output all descriptors (ZFP) except REF LI XL,OFFSET(ZPCZFP)(XPR) LOOP L (XL) LF X1,ZTDTYP IF ;! Not REF CAIN X1,QREF AOJA XL,FALSE ;! Skip extra word also THEN ;! Output putword FI ADDI XL,1 AS SOJG XK,TRUE SA SETZ putword ;! Zero to mark end of parameter descriptors FI ;! Output map for this prefix level LF XMP,ZPRMAP(XPR) ;! Point to map IF ;! [227] No map JUMPN XMP,FALSE THEN ;! Output -1 SETO putword GOTO L2 ;! Directly to prefix if any FI ;! [227] WLF ,ZMPNOV(XMP) putword WLF ,ZMPNTX(XMP) putword ;! Identify arrays WLF XL,ZMPNRV(XMP) IF ;! Any REF and/or ARRAY JUMPE XL,FALSE THEN ;! Find all arrays, output identification for non-REF arrays ADDI XL,(XREF) ;! AOBJN word LOOP L XM,(XL) IF ;! ARRAY CAIN XM,NONE GOTO FALSE LF ,ZDNTYP(XM) CAIE QZAR GOTO FALSE THEN ;! Output size, nsub, type in one word LF ,ZARLEN(XM) HLL OFFSET(ZARSUB)(XM) LF X1,ZARTYP(XM) CAIE X1,QREF ;! Ignore REF array putword FI AS AOBJN XL,TRUE SA FI ;! Final zero closes array specs SETZ putword L2():! ;! Handle prefix chain LF XPR,ZCPZCP(XPR) JUMPN XPR,L1 SETZ putword ;! End of identification list = 0 SUBTTL putref, output of attribute values ;! Output of values for one prefix level ;! ------------------------------------- HRRZ XREF,@nextparam(XCB) LI X1,@nextparam(XCB) LD X0,(X1) LF XPR,ZFLZQU L4():! LF XK,ZPCNRP(XPR) IF ;! Parameters exist JUMPE XK,FALSE THEN ;! Output all but REF MOVNI (XK) LI XK,OFFSET(ZPCZFP)(XPR) HRLM XK LOOP LF X1,ZTDTYP(XK) IF ;! NOT REF CAIN X1,QREF AOJA XK,FALSE ;! Skip one word THEN LF X2,ZFPOFS(XK) ADDI X2,(XREF) LF ,ZPDKND(XK) IF ;! ARRAY CAIE QARRAY GOTO FALSE THEN L XWAC1,(X2) putarray ELSE CAIE QSIMPLE RFAIL putref wrong par kind IF ;! Simple value type CAIL X1,QTEXT GOTO FALSE THEN L (X2) putword IF ;! LONG REAL CAIE X1,QLREAL GOTO FALSE THEN L 1(X2) putword FI ELSE ;! Must be TEXT CAIE X1,QTEXT RFAIL putref wrong par type LD XWAC1,(X2) puttext FI FI FI AS INCR XK,TRUE SA FI ;! Now output attributes according to map ;!--------------------------------------- LF XMP,ZPRMAP(XPR) JUMPE XMP,L8 ;! [227] No output if no map 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 ;! Output them all via putmove LF X2,ZMPDOV(XMP) ADDI X2,(XREF) MOVMS XLI ife qpz,< IMULI XLI,5 ;! Number of characters > putmove FI IF ;! Any TEXT WLF XK,ZMPNTX(XMP) JUMPE XK,FALSE THEN ADDI XK,(XREF) ;! AOBJN word LOOP LD XWAC1,(XK) puttext AS AOBJP XK,.+1 AOBJN XK,TRUE SA FI ;! Output any arrays WLF XL,ZMPNRV(XMP) IF ;! Any REF and/or ARRAY JUMPE XL,FALSE THEN ;! Find all arrays, output values for non-REF arrays ADDI XL,(XREF) ;! AOBJN word LOOP L XWAC1,(XL) IF ;! ARRAY CAIN XWAC1,NONE GOTO FALSE LF ,ZDNTYP(XWAC1) CAIE QZAR GOTO FALSE LF ,ZARTYP(XWAC1) CAIN QREF GOTO FALSE THEN putarray FI AS AOBJN XL,TRUE SA FI ;! Final zero closes array specs SETZ putword L8():! LF XPR,ZCPZCP(XPR) JUMPN XPR,L4 L9():! RETURN EPROC ife qpz,< SUBTTL newbuffer newbuffer: PROC SAVE L XWAC1,fileref(XCB) LI X1,200 IFON ZFIDF(XWAC1) SF X1,ZDFWCT(XWAC1) SKIPG cnt(XBH) ;! IONB returns here! EXEC IONB L XBP,bup(XBH) RETURN EPROC SUBTTL putmove putmove:PROC IF ;! Only one word CAILE XLI,5 GOTO FALSE THEN ;! Use putword L (X2) BRANCH putword FI SAVE L1():! SETZ XJ, ;! No truncation yet L XK,XLI SKIPG cnt(XBH) NEWBUFFER IF ;! Buffer cannot take 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 MOVNS ADDM cnt(XBH) ;! BLT word in X0 L XBP,bup(XBH) normalize(XBP) ST XBP,bup(XBH) LI (XBP) HRLI (X2) ADDI XBP,(XK) ADDI X2,(XK) ST XBP,bup(XBH) BLT -1(XBP) ;! Move info ADDM XK,count(XCB) JUMPL XJ,L1 RETURN EPROC > SUBTTL puterr .puterr:PROC SAVE X1 N==1 ;! One saved value on stack Outstr [ASCIZ/OUTPUT error /] HLRZ X1,@-N(XPDP) Outchr X1 Outstr [ASCIZ/, /] HRRZ X1,@-N(XPDP) Outstr (X1) Outstr [ASCIZ/ /] ERRFILE RTSERR QDSCON,214 ;! ?? AOS -N(XPDP) ;! Skip return HRROS count(XCB) ;! Signal error exit RETURN EPROC LIT END;