|
DataMuseum.dkPresents historical artifacts from the history of: Philips Data Systems |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Philips Data Systems Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 10064 (0x2750)
Notes: pts_type(SC)
Names: »DEACCU.SC«
└─⟦5c22ed822⟧ Bits:30009675 Philips computer tape "600209"
└─⟦this⟧ »DEN10/DEACCU.SC«
└─⟦79fbed147⟧ Bits:30009697 Philips computer tape "600414"
└─⟦this⟧ »S:DE/DEACCU.SC«
└─⟦bf903a231⟧ Bits:30009665 Philips computer tape "600109"
└─⟦this⟧ »DEN10/DEACCU.SC«
IDENT DEACCU REL 10.0 80-04-11 UPD 80-10-28/DALI UPD 80-03-05/DALI * ************************************************************************ * * SUBMODULE TO THE DATA-ENTRY PACKAGE FOR PTS6800 * * AFTER ENTERING A PICTURE (I.E. RECORD) THIS MODULE * SEARCHES FOR AND EXECUTES THE "FACC"-STRINGS IN * THE FORMAT. * * AT DELETION OF A RECORD THIS MODULE REVERSES THE * ACCUMULATIONS DONE BY THAT RECORD. * * THE MODULE IS ENTERED WHITH THE STATEMENT: * * * PERF DEACC,OPTION * * * WHERE: * * - OPTION = BIN-ITEM TELLING WANTED FACILITY * - 0 = NORMAL ACC * - 1 = REVERSED ACC * -2 = CORRECTION,IGNORE ZEROIZING ************************************************************************ * DDUM DEDDIV PDIV * * ***** ENTRIES * ENTRY DEACC ENTRY SETERR * * ***** EXTERNALS * EXT GETACC EXT MSKOUT EXT EMPTYT EXT GETFWD EXT ADJUST EXT CMPIND COMPARE INDEX EXT DEFIND FIELD ADRESS ROUTINE EXT DENVAL INCLUDE DELITT EJECT * ************************************************************************ * * MAIN-ROUTINE FOR ACCUMULATION * ************************************************************************ * DEACC PROC OPTION A000 CLEAR BOOL9 MOVE BCD2A,='0' CLEAR ERROR-INDICATOR MOVE DEBINW3,W0 CLEAR CURRENT-FIELD-NR TBF DBOACC,A900 NO ACC IN FORMAT ? SET BOOL1 INDICATE NORMAL ACC IB OPTION,A100,A050 A050 CLEAR BOOL1 INDICATE REVERSED ACC * * ***** SEARCH ACC-FIELD ***** * A100 ADD DEBINW3,W1 INCREASE CURRENT-FIELD-NR CALL GETFWD,DEBINW4,3,DEBINW3,BIN11 GET NEXT ACC-FIELD CALL ADJUST,DEBINW4 BERR A900 END OF FORMAT ? ..."CURRENT-FIELD" CURRENT * * ***** GET ACC-STRING ***** * A200 CALL GETACC,BPOOL(W1),BIN11,BIN12,BIN13 BNOK A800 STRING NOT FOUND ? TBF BOOL9,A210 CALL GETFWD,DEBINW4,0,DEBINW3,BIN7 CALL ADJUST,DEBINW4 CLEAR BOOL9 A210 CALL EMPTYT,:FMTITEM BNZ A800 IF EMPTY FIELD * * ***** EXECUTE ACC-STRING ***** * B EXACC "PERF" EXACC A250 CBE BIN1,W0,A100 NO DUPL IN LAST STRING ? SET BOOL9 * CALL GETFWD,DEBINW4,0,BIN1,BIN7 MAKE DUPPL-FIELD CURRENT CALL ADJUST,DEBINW4 BOK A200 'DUPL-FIELD' FOUND EJECT * * ***** SET ERROR-CODE ***** * A800 PERF SETERR,W2 ERROR-CODE = 2 B A100 * * * ***** RETURN TO CALLING MODULE ***** * A900 ADD BCD2A,BCD2A SET CONDITION-CODE * RET EJECT * ************************************************************************ * * SUB-ROUTINE FOR EXAMINATION AND EXECUTION OF THE ACC-STRING * ************************************************************************ * EXACC B000 SUB BIN12,W1 ADJUST DISPL. ADD BIN13,BIN12 DISPL. FOR LAST BYTE IN BIN13 * MOVE BIN1,W0 CLEAR DUPL-FIELD-NR EJECT * * *****GET ACCUMULATOR-NR ***** * B100 ADD BIN12,W1 INCREASE DISPL. CBG BIN12,BIN13,A250 END OF STRING ? * B103 MOVE BIN6,W0 CLEAR ACC-NR MOVE BIN7,W0 MOVE STR6A,=C'MDA' MATCH STR6A,BIN7,W3,BPOOL(BIN11),BIN12,W1 NEXT BYTE... BNOK B120 ...NOT D OR A ? IB BIN7,B105,B105 EJECT * * HANDLE CONDITIONAL ACCUMULATION * MOVE DEBINW1,W0 SET INPUTLENGT = 0 SUB BIN13,BIN12 PUT DISP INTO BIN13 PERF DENVAL,W1 EXECUTE VALIDATIONSTRING GETABX DEBINW3 MAKE ORIGINATE FIELD CURRENT AGAIN CLEAR DOOLB ERROR-FLAG BNZ B120 ERROR IN FORMAT GET THE ACCUMULATION STRING XCOPY BIN12,W1,W1,BIN3,W1 STARTPOINT MOVE BIN3,W0 GET THE LENGTH OF ACC.STRING XCOPY BIN3,W1,W1,BPOOL(BIN11),BIN12 MOVE BIN13,=X'3F' CALL MSKOUT,BIN13,BIN3 ADD BIN13,BIN12 PUT END OF ACC.STRING INTO 13 B B100 B105 * ADD BIN12,W1 INCREASE DISPL. PERF DEFIND,BIN6,DEBINW4 CBL BIN6,W1,B120 ACC-/DUPL-NR < 1 ? CBE BIN7,W1,B140 DUPL-FIELD ? * CBNE BIN7,W2,B120 NOT ACC ? CALL CMPIND,BIN6,ACK(W1) BNOK B120 OUT OF RANGE * CLEAR BOOL2 INDICATE PLUS-SIGN CLEAR BOOL6 INDICATE NO ABSOLUTE-VALUE CLEAR BOOL8 INDICATE DEFAULT NOT USED EJECT * * ***** EXAMINE ***** * B110 ADD BIN12,W1 INCREASE DISPL. CBG BIN12,BIN13,B190 END OF STRING ? MOVE BIN7,W7 MATCH VALSTR,BIN7,W18,BPOOL(BIN11),BIN12,W1 NEXT BYTE = ? BNOK B250 LITTERAL PREFIX ? SUB BIN7,W6 ADJUST INDEX IB BIN7 C B160,B120,B120,B120 "!,A,S,U" C B200,B120,B120,B120 "F,T,C,E" C B175,B170,B120,B120 "+,-,*,:" C B190,B120,B120,B120 ";,&,V,?" C B120,B180 "',Z" * * ***** FORMAT-ERROR DETECTED ***** * B120 PERF SETERR,W2 SET ERROR-CODE = 2 * * ***** DUPLICATE-FIELD-NR ***** * B140 MOVE BIN1,BIN6 UPDATE DUPL-FIELD-NR B A250 EJECT * * ***** ABSOLUTE-VALUE ***** * B160 SET BOOL6 INDICATE ABSOLUTE-VALUE B B110 * * ***** MINUS-SIGN ***** * B170 SET BOOL2 INDICATE MINUS-SIGN * * ***** PLUS-SIGN ***** * B175 B B110 * * ***** ZEROISE ***** * B180 CBG OPTION,W0,B390 JUMP IF CORR MOVE ACK(BIN6),='0' ZEROISE ACCUMULATOR B B390 * * ***** DEFAULT ***** * B190 SET BOOL8 INDICATE DEFAULT USED B B210 EJECT * * ***** FORMAT-FIELD ***** * B200 ADD BIN12,W1 INCREASE DISPL. PERF DEFIND,BIN7,DEBINW4 CBNE BIN7,W0,B220 JUMP IF NOT CURRENT B210 MOVE BIN7,DEBINW3 CURRENT FIELD B220 CON X.MOVE,STR64A,X.PSEU1,X.PSEU2,X.WB10,BIN7 MOVE BCDI21(W1),STR64A B B300 * * ***** LITTERAL ***** * B250 XCOPY BIN7,W1,W1,BPOOL(BIN11),BIN12 MOVE PREFIX TO WORKITEM CBL BIN7,W64,B120 NO LITTERAL ? MOVE BIN9,=X'3F' REMOVE... CALL MSKOUT,BIN9,BIN7 ...FLAGGS MOVE DEINPUT,HEX00 ADD BIN12,W1 INCREASE DISPL. COPY DEINPUT,W0,BIN9,BPOOL(BIN11),BIN12 GET LITTERAL MOVE BCDI21(W1),DEINPUT MOVE TO WORKITEM SUB BIN9,W1 ADJUST INDEX ADD BIN12,BIN9 INCREASE DISPL. EJECT * * ***** EXECUTE ACCUMULATION ***** * B300 TBF BOOL6,B310 NO ABSOLUTE-VALUE ? COPY BCDI21(W1),W0,W1,D1,W0 PLUS-SIGN TO WORKITEM B310 TBT BOOL2,B330 MINUS-SIGN ? TBT BOOL1,B340 REVERSED ACC ? B320 ADD ACK(BIN6),BCDI21(W1) ADD TO ACCUMULATOR B B350 * B330 TBT BOOL1,B320 REVERSED ACC ? B340 SUB ACK(BIN6),BCDI21(W1) SUBTRACT FROM ACCUMULATOR * B350 BOFL B360 B B380 B360 PERF SETERR,W3 SET ERROR-CODE = 3 * B380 TBT BOOL8,B395 DEFAULT USED ? B390 ADD BIN12,W1 INCREASE DISPL. CMP BIN12,BIN13 BG A250 END OF STRING REACHED MOVE BIN7,W19 MATCH VALSTR,BIN7,W1,BPOOL(BIN11),BIN12,W1 NEXT BYTE... BNOK B120 B395 B B100 * PEND EJECT * ************************************************************************ * * SUB-ROUTINE FOR SETTING THE ERROR-CODE * ************************************************************************ * SETERR PROC ERRIND X000 IB ERRIND,X100,X200,X300 * X100 MOVE BCD2A,D1 UNDEFINED ERROR B X900 * X200 MOVE BCD2A,='-1' FORMAT-ERROR B X900 * X300 MOVE BCD2A,='9' OVERFLOW * * X900 RET * PEND * END