|
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: 14166 (0x3756)
Notes: pts_type(SC)
Names: »DEGENE.SC«
└─⟦48601905a⟧ Bits:30009668 Philips computer tape "600121"
└─⟦this⟧ »S:DE/DEGENE.SC«
└─⟦d2a299635⟧ Bits:30009698 Philips computer tape "600415"
└─⟦this⟧ »S:DE/DEGENE.SC«
IDENT DEGENE REL 10.0 80-04-11 80-04-10/DALI * ************************************************************************ * * SUBMODULE TO THE DATA-ENTRY PACKAGE FOR PTS6800 * * AFTER ENTERING AN ELEMENT IN THE PICTURE THIS MODULE * CHECKS IF THERE IS A "FGEN-STRING" ATTACHED TO THAT * ELEMENT AND IF SO EXECUTES THE GENERATION. * * GENERATION CAN BE DONE TO: * - AN ELEMENT IN THE PICTURE * - AN USER-VARIABLE * ************************************************************************ * DDUM DEDDIV PDIV * * ***** ENTRIES ***** * ENTRY DEGEN * * ***** EXTERNALS ***** * EXT GETGEN EXT MSKOUT EXT TYPET EXT EMPTYT EXT DENVAL EXT GETFWD EXT ADJUST EXT CMPIND COMPARE INDEX * INCLUDE DELITT EJECT * * ***** INTERNAL WORK-FORMATS ***** * WFORM FTABLE WF1,WF2,WF3,WF4 * WF1 FRMT FCOPY USEV(BIN10) FMEND * WF2 FRMT FCTL X'C0',X.PSEU1,X.PSEU2,X.WB10,BIN10 FMEND * WF3 FRMT FMEL '+TTTTTTTTTTTTTTTTTTTT9',BCDI21(W1) FMEND * WF4 FRMT FCOPY SYSV(BIN10) FMEND EJECT * ************************************************************************ * * MAIN-ROUTINE FOR GENERATION * ************************************************************************ * DEGEN PROC A000 MOVE BCD2A,='0' CLEAR ERROR INDICATOR CLEAR BOOL1 CLEAR CURRENT-INDICATOR CLEAR BOOL4 CLEAR DUPL-INDICATOR GETABX BIN2 GET CURRENT-FIELD NR SETCUR B EXGEN "PERF" EXGEN A250 CBE BIN1,W0,A900 NO DUPL FOUND ? SET BOOL1 INDICATE CHANGED CURRENT CALL GETFWD,DEBINW4,0,BIN1,BIN4 MAKE DUPL CALL ADJUST,DEBINW4 ITEM CURRENT BERR A800 OUT OF FORMAT ? SET BOOL4 INDICATE DUPL CALL GETGEN,BPOOL(W1),BIN11,BIN12,BIN13 BOK EXGEN * * ***** FORMAT-ERROR DETECTED ***** * A800 * PERF SETERR,W2 * ***** RETURN TO CALLING MODULE ***** * A900 TBF BOOL1,A910 "CURRENT-FIELD" CURRENT ? CALL GETFWD,DEBINW4,0,BIN2,BIN4 MAKE CURRENT CALL ADJUST,DEBINW4 FIELD CURRENT A910 ADD BCD2A,BCD2A RET EJECT * ************************************************************************ * * SUBROUTINE FOR EXAMINATION AND EXECUTION OF THE GEN-STRING * ************************************************************************ * EXGEN B000 SUB BIN12,W1 ADJUST DISPL. ADD BIN13,BIN12 DISPL FOR LAST BYTE IN BIN13 * MOVE BIN1,W0 CLEAR DUPL-FIELD-NR EJECT * * ***** GET RESULT-FIELD ***** * B050 ADD BIN12,W1 INCREASE DISPL. CBG BIN12,BIN13,A250 END 0F STRING ? * B055 MOVE BIN7,W0 CLEAR RESULT-FIELD-NR... MOVE BIN6,W0 ...AND RESET TYPE-INDEX MOVE STR6B,=C'DUFM' MATCH STR6B,BIN6,W4,BPOOL(BIN11),BIN12,W1 IB BIN6,B070,B070,B065 B B070 EJECT * * HANDLE CONDITIONAL GENERATION * B065 MOVE DEBINW1,W0 SET INPUTLENGTH = 0 SUB BIN13,BIN12 PUT DISP INTO BIN13 PERF DENVAL,W2 CLEAR DOOLB BNZ B120 XCOPY BIN12,W1,W1,BIN3,W1 MOVE BIN3,W0 XCOPY BIN3,W1,W1,BPOOL(BIN11),BIN12 MOVE BIN13,=X'3F' CALL MSKOUT,BIN13,BIN3 ADD BIN13,BIN12 B B050 B070 BNOK B120 FORMAT ERROR ? * * ADD BIN12,W1 INCREASE DISPL. XCOPY BIN7,W1,W1,BPOOL(BIN11),BIN12 GET FIELD-NR IB BIN6,B180,B180 JUMP IF USER OR FIELD B B140 B075 CLEAR BOOL2 INDICATE NO ARITHMETIC DONE MOVE BCDI21(W1),='0' CLEAR SUM * ADD BIN12,W1 INCREASE DISPL. MOVE BIN4,W0 NEXT BYTE... MOVE STR1A,=C'=' MATCH STR1A,BIN4,W1,BPOOL(BIN11),BIN12,W1 BOK B100 ..."="-SIGN ? * SUB BIN12,W1 ADJUST DISPL. EJECT * * ***** EXAMINE ***** * B100 CLEAR BOOL6 INDICATE NO ABSOLUTE VALUE MOVE BIN3,W0 RESET SIGN-INDEX (+-SIGN) * B110 MOVE BIN10,W0 CLEAR ACTUAL-FIELD-NR... MOVE BIN9,W0 ...AND RESET TYPE-INDEX ADD BIN12,W1 INCREASE DISPL. CMP BIN12,BIN13 BG B600 MOVE STRG10A,=C'!UF+-*:;AS' MATCH STRG10A,BIN9,W10,BPOOL(BIN11),BIN12,W1 BNOK B200 LITTERAL PREFIX ? IB BIN9 C B300,B300,B170,B170,B170,B170,B600,B300,B300 B B160 * * ***** FORMAT-ERROR DETECTED ***** * B120 PERF SETERR,W2 ERROR-CODE = 2 * * * ***** END OF STRING REACHED ***** * B A250 RETURN TO MAIN-MODULE * * ***** DUPLICATION FOUND ***** * B140 CBL BIN7,W1,B120 DUPL-NR NOT > ZERO ? CBNL BIN7,BIN2,B120 DUPL-NR NOT < "CURRENT" ? MOVE BIN1,BIN7 UPDATE DUPL-FIELD-NR B A250 EJECT * * ***** ABSULUTE VALUE ***** * B160 SET BOOL6 INDICATE ABSOLUTE VALUE SET BOOL2 INDICATE ARITHMETIC B B110 * * ***** ARITHMETIC SIGN ***** * B170 SET BOOL2 INDICATE ARITHMETIC MOVE BIN3,BIN9 MOVE TO SIGN-INDEX SUB BIN3,W3 ADJUST SIGN-INDEX B B110 * * **** OWN FIELD OR USER-VAIABEL **** * B180 CALL EMPTYT,X.PSEU1,X.PSEU2,X.WB10,BIN2 CHECK CURRENT FIELD BZ B075 NOT EMPTY *CURRENT FIELD EMPTY CBNE BIN6,W2,B190 NOT FIELD CBE BIN7,W0,B075 IF CURRENT CBE BIN7,BIN2,B075 IF CURRENT B190 MOVE BIN4,BIN13 CALCULATE LENGTH OF... SUB BIN4,BIN12 ...THE REST OF THE STRING MOVE STR1A,=C';' MATCH BPOOL(BIN11),BIN12,BIN4,STR1A,W0,W1 BNOK A250 NOT FOUND ? B B050 EJECT * * ***** LITTERAL ***** * B200 MOVE DEINPUT,HEX00 CLEAR WORKITEM MOVE BIN10,W0 " XCOPY BIN10,W1,W1,BPOOL(BIN11),BIN12 GET LITTERAL-PREFIX MOVE BIN9,=X'3F' REMOVE... CALL MSKOUT,BIN9,BIN10 ...FLAGGS ADD BIN12,W1 INCREASE DISPL. COPY DEINPUT,W0,BIN9,BPOOL(BIN11),BIN12 GET LITTERAL SUB BIN9,W1 ADJUST INDEX ADD BIN12,BIN9 INCREASE DISPL. B B500 EJECT * * ***** USER- OR FORMAT-VALUE ***** * B300 MOVE DEINPUT,HEX00 CLEAR WORKITEM MOVE BIN10,W0 " ADD BIN12,W1 INCREASE DISPL. XCOPY BIN10,W1,W1,BPOOL(BIN11),BIN12 GET FIELD-NR * IB BIN9,B310,B320 CBE BIN9,W9,B315 JUMP IF SYSTEM VARIABLE HANDLE ACCUMULATORS CALL CMPIND,BIN10,ACK(W1) BNOK B120 OUT OF RANGE MOVE DEINPUT,ACK(BIN10) B B500 B310 HANDLE USERVARIABELS * CALL CMPIND,BIN10,USEV(W1) BOK B350 B B120 * B315 HANDLE SYSTEM VARIABLE CALL CMPIND,BIN10,SYSV(W1) BNOK B120 IF OUT OF RANGE MOVE BIN9,W4 B B350 * ***** FORMAT-FIELD ***** * B320 CBNE BIN10,W0,B330 "CURRENT FIELD" ? MOVE BIN10,BIN2 UPDATE INDEX WITH CURRENT * B330 CALL TYPET,BIN4,X.PSEU1,X.PSEU2,X.WB10,BIN10 F-ITEM IS... CBE BIN4,W3,B350 ...A STRG-ITEM ? * * ***** USER- OR FORMAT-VALUE TO WORKITEM ***** * CON X.MOVE,DEINPUT,X.PSEU1,X.PSEU2,X.WB10,BIN10 BCD-ITEM B B500 * B350 EDIT DEINPUT,WFORM(BIN9) STRG-ITEM EJECT * * ***** EXECUTE ARITHMETIC ***** * B500 MOVE BCDI21(W2),DEINPUT VALUE TO BCD-WORKITEM TBF BOOL6,B510 NO ABSOLUTE VALUE ? COPY BCDI21(W2),W0,W1,D1,W0 "+-SIGN" TO WORKITEM B510 IB BIN3,B520,B530,B540 ADD BCDI21(W1),BCDI21(W2) "+" B B550 B520 SUB BCDI21(W1),BCDI21(W2) "-" B B550 B530 MUL BCDI21(W1),BCDI21(W2) "*" B B550 B540 DIV BCDI21(W1),BCDI21(W2) ":" * B550 BOFL B560 B B100 * B560 PERF SETERR,W3 ERROR-CODE = 3 B B100 EJECT * * ***** UPDATE RESULT-FIELD ***** * B600 TBF BOOL2,B610 NO ARITHMETIC DONE ? MOVE DEINPUT,HEX00 CLEAR STRG-WORK MOVE BIN10,W0 MOVE SUM TO STRG-WORK... EDSUB DEINPUT,BIN10,WF3 ...AND GET LENGTH OF SUM B610 CBE BIN6,W2,B620 FORMAT-FIELD ? USER-VARIABEL CALL CMPIND,BIN7,USEV(W1) BNOK B120 OUT OF RANGE MOVE USEV(BIN7),DEINPUT RESULT TO USER-VARIABLE B B050 * B620 CBNE BIN7,W0,B640 CURRENT FIELD ?? MOVE BIN7,BIN2 UPDATE WITH CURRENT INDEX * B640 CALL GETFWD,BIN4,0,BIN7,BIN9 CALL ADJUST,BIN4 * GETCTL 1,BIN9 GET MAXLENGTH TSTCTL 0 BNZ ALPHA JUMP IF ALPHA MOVE DEINPUT,HEX00 MOVE BIN10,W0 EDSUB DEINPUT,BIN10,WF3 SUB BIN10,W1 ADJUST LENGTH OF SUM CMP BIN10,BIN9 RESULT LEN VS MAXL BE NUM BG B650 GETCTL 2,BIN9 GET MINL CBNL BIN10,BIN9,NUM IF RESULT LEN NOT LESS MINL SUB BIN9,BIN10 CALCULATE MISSING ZEROES MOVE STR64A,=X'30' LOAD ZEROES INSERT DEINPUT,W1,BIN9,STR64A,W0 ADD MISSING ZEROES B NUM B650 SUB BIN10,BIN9 CLEAR BYTE IN... DLETE DEINPUT,W1,BIN10 NUM CBE BCDI21(W1),:FMTITEM,CONT DONT DISPLAY IF EQUAL NUM100 ERASE 1,BIN7,BIN7 ERASE OLD CONTENTS UPDFLD 1,DEINPUT CONT CBE BIN7,BIN2,FINISH JUMP IF NOT OWN FIELD GETFLD 0,BIN2,BIN7 GET OWN FIELD CURRENT FINISH B B050 ALPHA MOVE BIN4,W0 MATCH DEINPUT,BIN4,BIN9,:FMTITEM,W0,BIN9 BOK CONT IF EQUAL CONTENTS B NUM100 * 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