|
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: 16874 (0x41ea)
Notes: pts_type(SC)
Names: »FSNAME.SC«
└─⟦f45ea3bc3⟧ Bits:30009713 Philips computer tape "WSM"
└─⟦this⟧ »WSM:CREA/FSNAME.SC«
IDENT FSNAME REL=2.3,850606,870155940230 *********************************************************************** * * LATEST UPDATE 850606 MADE BY JE * * HISTORY= * 850606/JE CHECK OVFL-ENTRIES IN ATTAB 'SEATAB' * 850419/CJ MUL&DIV DONE BY ASSRUT * 850313/JE PERFORMANCE INDICATE IF DYN FIELD WAS CHANGED * 841120/CJ MUL&DIV DONE BY ASSRUT * 840925/CJ ADJUSTMENT FOR CANCEL-KEY IN NAMESET * 831208/CJ ADAPTION TO "NEW" POLICE * 831114/CJ NOT OK IF <CAN> ON EMPTY SCREEN - SOLVED * 830923/CJ STPBLK ON MAIN SCREEN IMPL. * 830718/CJ NEW ATTRIBUTES IN FNAMES * 830426/CJ ADAPTION OF SYS.LINE FOR VD81 * ********************************************************************** DDUM WSMDDV PDIV ENTRY FSNAME EXPROC READIN,PKTAB,PKTAB,PKTAB,PLIT ***READ IN ONE FIELD EXPROC WSMERR,PKTAB,PLIT ***(ERROR-)MESSAGE ROUTINE EXPROC POLICE,PBIN,PBOOL,PBOOL,PSTRG ***POOL-LIMIT-CONTROLLER EXPROC DISPLY,PBIN ***DISPLAY FORMAT SECTION EXPROC CURSET,PBIN,PBIN,PDSET ***CURSOR SETTING EXPROC STPBLK ***STOP BLOCKING EXPROC STABLK ***START BLOCKING EXT ICLEAR ---ASSRUT:CLEAR ITEM EXT EMPTYT ---EMPTY ITEM EXT CHANFC ---CHANGE FILE CODE EXT WXDIV ---DIVISION EXT WXMUL ---MULTIPLICATION * CED EQU X'B7' CHANGE ECHO-DEVICE BRW EQU X'85' BASIC WRITE ERS EQU X'B1' ERASE EJECT INCLUDE WSMKEY,LIST EJECT INCLUDE KEYT5,LIST INCLUDE KEYT9,LIST INCLUDE KEYT10,LIST INCLUDE KEYT11,LIST INCLUDE KEYT3,LIST EJECT FSNAME PROC PERF STPBLK ***STOP BLOCKING ON MAIN SCREEN BG FSN982 JUMP IF MEMORY OVERFLOW ATTFMT FHOME THOME MOVE LBIN11,W0 ATTRIBUTE-TABLE-POINTER:=0 CLEAR LBOOL3 FALSE = FORWARD SEARCH CLEAR LBOOLA FALSE=EOI KEY CBNE GBIN2,W1,FSN032 JMP IF NOT RETURN TBT VD82,FSN020 ERASE 0,W1,W0 FSN020 XCOPY GBIN4,W1,W1,GBIN8,W0 RESTORE RETURN-ADRESS BUFFIND XCOPY GBIN5,W1,W1,GBIN8,W1 RESTORE RETURN-ADRESS POINTER MOVE LBIN10,GBIN8 RESTORE STATIC FIELD DISPL. MOVE LBIN16,W1 MOVE LBIN4,=X'0101' MOVE LBIN14,W0 PERF CURSET,LBIN4,LBIN1,SCRN ***CURSOR SETTING TBF VD82,FSN025 JMP IF NOT VD82 MOVE LBIN2,W3 BUFFERLENGTH:=3 MOVE LSTR9A,=X'9B324A00' CONTROL-CODE ERASE DISPLAY DSC SCRN,BRW,LBIN1,LSTR9A,LBIN2 ERASE DISPLAY FSN025 MOVE LBIN1,W0 PERF DISPLY,LBIN8 ***DISPLAY FORMAT SECTION FSN032 TBT LBOOL8,FSN040 JUMP IF UPD OLD CBE GBIN2,W1,FSN040 JMP IF RETURN-KEY FSN030 PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN038 JUMP IF END OF TABLE FOUND ADD LBIN11,W2 ADJUST TO REACH SEQ. NO XCOPY ATTAB,LBIN11,W1,W0,W0 CLEAR SEQ NO ADD LBIN11,W2 ADJUST POINTER B FSN030 FSN038 MOVE LBIN11,W0 ATTRIBUTE-TABLE POINTER:=0 FSN040 DSC KEYB,CED,SYSLFC CHANGE ECHO-DEVICE CALL CHANFC,SCRN,SYSLFC CHANGE FILE CODE ATTFMT FNAMES MOVE LBIN18,=X'0101' CURSOR POS:=0101 TBT VD82,FSN041 JMP IF VD82/83 MOVE LBIN18,=X'1801' CURSOR POS:=2401 FSN041 PERF CURSET,LBIN18,LBIN2,SYSL ***CURSOR SET DSC SYSL,2,COLS ERASE SYSTEMLINE MOVE LBIN18,W1 LOAD FOR DISP. LAST LINE TBT VD82,FSN050 JMP IF VD82/83 MOVE LBIN18,W24 LOAD FOR DISP SYSLINE VD47/81 EJECT * * INITIAL VALUES * FSN050 MOVE LBIN13,W0 FIELD-ID-TABLE-POINTER:=0 TBT LBOOL8,FSN060 JUMP IF UPD OLD CBE GBIN2,W1,FSN065 JUMP IF RETURN-KEY CALL ICLEAR,FIDTAB ---CLEAR FIELD-ID-TABLE B FSN065 FSN060 MOVE LBIN13,GBIN15 LOAD FIRST FREE POS OF FID-TAB FSN065 MOVE GBIN2,W0 CLEAR RETUR-CODE PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBF LBOOL4,FSN095 JUMP IF END OF TABLE FOUND B FSN260 FSN095 CALL CHANFC,SCRN,SYSLFC CHANGE FILE CODE DISPLAY 4,LBIN18,LBIN18 DISPLAY FORMAT ON LAST ROW FSN098 CALL CHANFC,SCRN,SYSLFC CHANGE FILE CODE ERASE 2,W1,W1 ERASE/CLEAR FIELD-ID CBE LBIN12,W0,FSN099 JUMP IF NEW DYN FIELD MOVE LBIN6,LBIN12 LOAD SEQ.NO CALL WXMUL,LBIN6,W5,LBIN6 SUB LBIN6,W5 CALC ELEMENT ADRESS XCOPY LSTR4A,W0,W4,FIDTAB,LBIN6 STORE OLD CONTENTS DISPLAY 1,W1,W1 DISPLAY OLD FIELD-ID FSN099 CALL CHANFC,SCRN,SCRNFC CHANGE FILE CODE DSC1 SCRN,6,LBIN7 SET CURSOR FSN100 MOVE LBIN3,W1 EXPECTED LENGTH KI .NE,KEYB,LSTR81,KEYT9,LBIN3,LBIN2 BL FSN150 ERROR OR MAX SIZE REACHED CBE LBIN2,W0,FSN110 JUMP IF POWER OFF IB LBIN2,FSN100,FSN100, CLR,CAN C FSN300,FSN260,FSN120, RET,ENT,PLS C FSN130 BTB EJECT * * POWER OFF * FSN110 CALL CHANFC,SCRN,SCRNFC CHANGE FILE CODE MOVE LBIN16,W1 1ST ROW MOVE LBIN4,=X'0101' ROW:=1 COL:=1 MOVE LBIN14,W0 ATTR.TAB POINTER:=0 MOVE LBIN1,W0 PERF DISPLY,LBIN8 ***EDIT AND WRITE TO E-O-S CALL CHANFC,SCRN,SYSLFC CHANGE FILE CODE B FSN095 EJECT * * FORWARD TABULATION * FSN120 ADD LBIN11,W4 NEXT DYN FIELD CLEAR LBOOL3 FALSE = FORWARD SEARCH PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN260 JUMP IF END OF TABLE FOUND B FSN098 GO ON EJECT * * BACKWARD TABULATION * FSN130 CBE LBIN11,W0,FSN135 JUMP IF BEGINOFTAB SUB LBIN11,W4 PREVIOUS DYN FIELD FSN135 SET LBOOL3 TRUE = BACKWARD SEARCH PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN260 JUMP IF END OF TABLE FOUND B FSN098 GO ON EJECT * * CHANGE MODE * FSN150 MOVE LSTR2,='++' XCOPY LSTR1,W0,W1,LSTR81,W0 COPY 1ST CHAR. CBL LSTR1,=C'A',FSN100 JMP IF NOT ALPHABETIC CBG LSTR1,=C'Z',FSN100 JMP IF NOT ALPHABETIC CALL CHANFC,SCRN,SYSLFC CHANGE FILE CODE MOVE LBIN3,=X'181E' CURSOR POSITION TBF VD82,FSN160 MOVE LBIN3,=X'011E' SYSTEM LINE FSN160 PERF CURSET,LBIN3,LBIN2,SYSL CALL ICLEAR,LSTR4A ---CLEAR ITEM HEX-00 MOVE LBIN2,W3 INSRT LSTR81,W0,W2,LSTR2,W0 PUT IN "++" WRITE SYSL,LSTR81,LBIN2 DLETE LSTR81,W0,W2 DELETE "++" CBE LBIN12,W0,FSN200 JMP IF NEW FIELD-ID XCOPY LSTR4A,W0,W4,FIDTAB,LBIN6 STORE OLD CONTENTS MOVE LSTR9A,=X'2000' LOAD WORKITEM SPACE & EMPTY MOVE LBIN4,W0 POINTER:=0 MATCH LSTR4A,LBIN4,W4,LSTR9A,W0,W1 SEARCH 1ST SPACE BNOK FSN200 JMP IF NO SPACES MOVE LBIN3,W4 LOAD LENGTH OF ITEM SUB LBIN3,LBIN4 CALC NUMB OF H-00 TO PAD SUB LBIN3,W1 ADJUST XCOPY LSTR4A,LBIN4,LBIN3,LSTR9A,W1 LOAD EMPTY POSITIONS EJECT FSN200 THOME GETABX LBIN4 PERF READIN,KEYT10,KEYT11,KEYT3,=W'37' ***READ IN ONE FIELD IB LBIN2,FSN220,FSN215, ENT OR EOI,CAN C FSN300,FSN110 RET,POF EJECT * * CANCEL - KEY * FSN215 SUB LBIN11,W4 ADJUST FOR CANCEL-KEY * * END-OF-ITEM-KEY * FSN220 BNZ FSN221 EOI-KEY SET LBOOLA ENTER-KEY MOVE LBIN2,W4 4=ENTER KEY-INDEX EJECT FSN221 ADD LBIN11,W2 ADJUST TO REACH SEQNO-POS CBE LBIN1,W0,FSN228 JMP IF SAME FID ENTERED (NO INPUT) CBNE LBIN12,W0,FSN222 JUMP IF OLD ENTRY MOVE LBIN6,LBIN13 STORE 1ST FREE ENTRY ADRESS FSN222 CMP LBIN6,LFBIN JUMP IF BE FSN984 MEMORY OVERFLOW XCOPY FIDTAB,LBIN6,W4,LSTR4A,W0 STORE FIELD-ID CBNE LBIN12,W0,FSN225 JUMP IF OLD ENTRY ADD LBIN6,W5 CALL WXDIV,LBIN6,W5,LBIN6 CALC SEQ.NO OF FIDTAB XCOPY ATTAB,LBIN11,W1,LBIN6,W1 STORE SEQ.NO OF FIDTAB ADD LBIN13,W5 ADJUST 1ST FREE ENTRY ADRESS FSN225 CBE LBIN12,W0,FSN228 JMP IF NEW FID WAS INSERTED SET CMBOOL T=DYN FIELD-ID WAS CHANGED FSN228 TBT LBOOLA,FSN260 JUMP IF ENTER-KEY ADD LBIN11,W2 NEXT DYN FIELD CLEAR LBOOL3 FALSE = FORWARD SEARCH PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN260 B FSN098 GO ON IF E-O-TABLE NOT FOUND EJECT * * CHECK IF ANY EMPTY FIELD-ID * FSN260 CLEAR LBOOL3 FALSE = FORWARD SEARCH MOVE LBIN11,W0 ATTRIBUTE-TABLE-POINTER:=0 FSN265 PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN400 JUMP IF END OF TABLE FOUND CBE LBIN12,W0,FSN275 JUMP IF EMPTY FID FOUND MOVE LBIN6,LBIN12 LOAD SEQ.NO CALL WXMUL,LBIN6,W5,LBIN6 SUB LBIN6,W5 CALC ELEMENT ADRESS XCOPY LSTR4A,W0,W4,FIDTAB,LBIN6 STORE OLD CONTENTS CALL EMPTYT,LSTR4A EMPTY ? BNOK FSN275 JUMP IF EMPTY ADD LBIN11,W4 NEXT DYN FIELD B FSN265 GO ON FSN275 CLEAR LBOOLA CLEAR ENT ERR.FLAG MOVE LBIN1,W0 NO CLEAR MOVE LBIN4,W5 MESSAGE NO 5 PERF WSMERR,KEYT5,=W'37' ***(ERROR-)MESSAGE ROUTINE CBE LBIN2,W0,FSN270 JUMP IF POWER OFF IB LBIN2,FSN098,FSN098, CLR,CAN C FSN300 RET,ENT B FSN098 FSN270 MOVE LBIN16,W1 1ST ROW MOVE LBIN4,=X'0101' ROW:=1 COL:=1 MOVE LBIN14,W0 ATTR.TAB POINTER:=0 MOVE LBIN1,W0 PERF DISPLY,LBIN8 ***EDIT AND WRITE TO E-O-S B FSN275 FSN280 CBE LBIN11,W0,FSN285 JMP IF ATTAB=0000 0000 ... SUB LBIN11,W4 ADJUST POINTER FSN285 SET LBOOL3 TRUE = BACKWARD SEARCH PERF SEATAB ***SEARCH NEXT DYN.FIELD POS TBT LBOOL4,FSN400 JUMP IF END OF TABLE FOUND B FSN098 EJECT * * RETUR-KEY * FSN300 MOVE GBIN15,LBIN13 LOAD NEW ADRESS MOVE GBIN2,W1 INDICATE RETUR KEY B FSN999 * * NORMAL END * FSN400 CBE LBIN2,W4,FSN420 JMP IF ENTER AND NOT E-O-F MOVE LBIN1,W0 NO CLEAR MOVE LBIN4,W7 MESSAGE NO 7 PERF WSMERR,KEYT5,=W'37' ***(ERROR-)MESSAGE ROUTINE CBE LBIN2,W0,FSN410 JUMP IF POWER OFF IB LBIN2,FSN280,FSN280, CLR,CAN C FSN300,FSN420 RET,ENT POWER OFF FSN410 MOVE LBIN16,W1 1ST ROW MOVE LBIN4,=X'0101' ROW:=1 COL:=1 MOVE LBIN14,W0 ATTR.TAB POINTER:=0 MOVE LBIN1,W0 PERF DISPLY,LBIN8 ***EDIT AND WRITE TO E-O-S B FSN400 EJECT * * FIELD-NAME TABLE STORAGE * FSN420 MOVE LBIN11,W0 ATTRIBUTE-TABLE-POINTER:=0 MOVE LBIN3,W0 NUMB OF DYN. FIELDS:=0 MOVE LBIN2,W8 NUMB OF CHAR TO CONTROL MOVE LSTR6A,=X'00FBFCFDFEFF' STATIC FIELD OBJECT CODES CLEAR LBOOL3 FALSE = NO SPLITT OF OBJECT CLEAR VBOOL8 FALSE = NO COMP POOL-DELIMITER FSN430 PERF SEATAB ***SEARCH NEXT DYNAMIC FIELD TBT LBOOL4,FSN440 JMP IF E-O-TABLE CALL WXMUL,LBIN12,W5,LBIN12 SUB LBIN12,W5 CALC ATTR ELEMENT ADRESS PERF POLICE,LBIN2,LBOOL3,VBOOL8,LSTR81 ***POOL-LIMIT-CONTROLER BG FSN982 JUMP IF MEMORY OVERFLOW XCOPY BPOOL(GBIN4),GBIN5,W4,FIDTAB,LBIN12 STORE FID ADD GBIN5,W8 ADJUST POOL-POINTER LEAVING 4 BYTES EMPTY ADD LBIN11,W4 ADJUST TABLE POINTER ADD LBIN3,W1 INCREMENT NUMB OF DYN FIELDS B FSN430 GO ON FSN440 * * STORE NUMBER OF DYNAMIC FIELDS * MOVE LBIN1,=W'37' POINTER TO BBUFFERPOOL XCOPY BPOOL(W1),LBIN1,W1,LBIN3,W1 STORE NUMB OF D.FIELDS MOVE LSTR6A,=X'0000' LOAD EMPTY-VALUE MOVE GBIN15,W0 MATCH-POINTER:=0 MATCH FIDTAB,GBIN15,LFBIN,LSTR6A,W0,W5 MATCH 1ST FREE POSITION ADD GBIN15,W1 ADJUST CALL WXDIV,GBIN15,W5,GBIN15 CALL WXMUL,GBIN15,W5,GBIN15 CALC EVEN 5-MULTIPEL-POS XCOPY GBIN9,W0,W1,GBIN4,W1 STORE RETURN-ADRESS BUFFINDEX XCOPY GBIN9,W1,W1,GBIN5,W1 STORE RETURN-ADRESS POINTER B FSN999 EJECT * * WORKING AREA <DATA-ITEM> EXCEEDED * FSN982 MOVE LBIN5,W2 BPOOL DIMENSION OVERFLOW B FSN988 * FSN984 MOVE LBIN5,W4 FIDTAB OVERFLOW FSN988 MOVE LBIN1,W0 NO CLEAR MOVE LBIN4,W2 ERRORMESSAGE NO:=2 PERF WSMERR,KEYT5,=W'37' ***(ERROR-)MESSAGE ROUTINE B FSN300 * * EXIT * FSN999 DSC KEYB,CED,SCRNFC CHANGE ECHO DEVICE CALL CHANFC,SCRN,SCRNFC CHANGE FILE CODE PERF STABLK RET PEND EJECT * * SEARCH ATTRIBUTE-TABLE TO FIND ITS ATTRIBUTE -POSITION * * INPUT : LBIN11 = CURRENT DYNAMIC FIELD POSITION * LBOOL3 = FALSE => FORWARD SEARCH * TRUE => BACKWARD SEARCH * OUTPUT : LBIN11 = POINTER ADRESS TO NEXT OR PREVIOUS * DYNAMIC FIELD POSITON * LBOOL4 = FALSE = DYNAMIC FIELD ENTRY WAS FOUND * = TRUE = E-O-TABLE WAS FOUND * LBIN12 = SEQ. NO OF DYNAMIC FIELD (=0 NEW DYN FI * LBIN7 = CURSOR-POSITION OF FOUND DYNAMIC FIELD * ************************************************************************ SEATAB PROC MOVE LBIN12,W0 WORKITEM:=0 CLEAR LBOOL4 FALSE = DYN FIELD ENTRY FOUND TBT LBOOL3,SEA300 JUMP IF BACKWARD SEARCHING * * FORWARD SEARCHING * SEA100 CBE LBIN11,LABIN,SEA200 JUMP IF END OF TABLE XCOPY LBIN1,W0,W2,ATTAB,LBIN11 FETCH ATTRIBUTE-POS. CBE LBIN1,W0,SEA200 JUMP IF END-OF-TABLE ADD LBIN11,W2 NEXT SEQ. NO-POS XCOPY LBIN12,W1,W1,ATTAB,LBIN11 FETCH SEQ. NO-POS. ADD LBIN11,W2 ADJUST FOR NEXT ELEMENT-POS CBE LBIN12,=X'00FF',SEA100 GO ON IF STATIC FIELD MOVE LBIN7,LBIN1 LOAD CURSERPOS FOR DYN-FIELD XCOPY LBIN1,W0,W1,W0,W0 DELETE ROW NO CBG LBIN1,LBIN9,SEA100 GO ON IF OVFL ENTRY SUB LBIN11,W4 ADJUST FOR THIS ELEMENT-POS B SEA999 EXIT SEA200 SET LBOOL4 TRUE E-O-T/B-O-T/NO ROW ENTRY B SEA999 * * BACKWARD SEARCHING * SEA300 CBE LBIN11,W0,SEA100 BEGIN OF TABLE REACHED ADD LBIN11,W2 NEXT SEQ. NO-POS XCOPY LBIN12,W1,W1,ATTAB,LBIN11 FETCH SEQ. NO-POS. SUB LBIN11,W6 NEXT ATTRPOS CBE LBIN12,=X'00FF',SEA300 GO ON IF STATIC FIELD ADD LBIN11,W4 ADJUST FOR THIS ELEMENT-POS XCOPY LBIN1,W0,W2,ATTAB,LBIN11 LOAD CURSORPOS DYN FIELD-POS. MOVE LBIN7,LBIN1 LOAD CURSERPOS FOR DYN-FIELD XCOPY LBIN1,W0,W1,W0,W0 DELETE ROW NO CBNG LBIN1,LBIN9,SEA999 EXIT IF NOT OVFL ENTRY <= SUB LBIN11,W4 ADJUST WHEN OVFL ENTRY B SEA300 EXIT SEA999 RET PEND EJECT INCLUDE FNAMES,LIST * * FORMAT HOME CONTROLLED CURSER * FHOME FRMT FSL FKI 1 FCOPY LSTR1 FMEND END