|
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: 30228 (0x7614)
Notes: pts_type(SC)
Names: »WSMAPP.SC«
└─⟦f45ea3bc3⟧ Bits:30009713 Philips computer tape "WSM"
└─⟦this⟧ »WSM:CREA/WSMAPP.SC«
IDENT WSMAPP REL=2.3,851025,870155940230 ******************************************************************* * * LATEST UPDATE=851025 BY CJ * * HISTORY= * 851025/CJ SECTION NAME CHECK CORRECTED - APP26 * 850508/JE FIELD-ID INPUT NO CHCK OF FUNCTION WHEN # 3 NO=18 * 850313/JE INDICATE 'NO INPUT' WHEN EQUAL FID ENTERED NO=18 * 841120/CJ MUL&DIV NOW FROM ASS.ROUTINE * 841101/CJ APP NO28 IMPLEMENTED - USED BY "GO DIRECT" * 840924/CJ ILLEGAL NAMESETTING NEAR BASICVERB APP185 * ******************************************************************* DDUM WSMDDV PDIV ENTRY WSMAPP EXPROC SYNVAL ***SYNTAX-CONTROL VALIDATION EXPROC BSVSEA,PBIN,PBIN ***BASIC VERB SEARCH EXT GETIND ---ASSRUT:GET ITEM LENGTH EXT CHANFC ---ASSRUT:CHANGE FILE CODE EXT GETVOL ---ASSRUT:GET VOLUME NAME EXT EMPTYT ---ASSRUT:CECK IF EMPTY EXT ICLEAR ---ASSRUT:CLEAR ITEM EXT TESTB ---ASSRUT:TEST BIT POSITION EXT CLEARB ---ASSRUT:CLEAR BIT POSITION EXT POPEN ---ASSRUT:OPEN DISC FILE EXT PCLOSE ---ASSRUT:CLOSE DISC FILE EXT PSEARC ---ASSRUT:SEARCH SECTION NAME EXT WXDIV ---ASSRUT:DIVISION EJECT ************************************************************************ * * APPLICATION HANDLING MODULE * PERFORMS CORRESPONDING APPLICATION- * ROUTINE DEPENDING ON ROUTINE-NUMBER * * INPUT: LBIN1 = NUMBER OF INPUT CHARACTERS * LBIN2 = EOI-KEY INDEX * LBIN3 = APPLICATION ROUTINE NUMBER * * OUTPUT:LBIN1 = CURSOR-POSITION AT 'NOT OK' (4) * LBIN2 = EOI-KEY INDEX * LBIN3 = 0 = OK 'REWRITE' DISPLAY * = 1 = OK UNCONDITIONAL DISPLAY * = 2 = OK NO DISPLAY * = 3 = NOT OK => ERROR MESSAGE * = 4 = NOT OK => EDIT MODE 'LBIN1' CONTAIN CURSOR-POS * * LBIN4 = 0 'BELL'-MESSAGE AT ERROR * > 0 ERROR MESSAGE-NUMBER AT ERROR * ************************************************************************ EJECT WSMAPP PROC IB LBIN3,APP010,APP020, 1-2 C APP030,APP040,APP050, 3-5 C APP060,APP070,APP080, 6-8 C APP090,APP100,APP110, 9-11 C APP120,APP130,APP140, 12-14 C APP150,APP160,APP170, 15-17 C APP180,APP190,APP200, 18-20 C APP210,APP220,APP230, 21-23 C APP240,APP250,APP260, 24-26 C APP270,APP280 27-28 APPOK0 MOVE LBIN3,W0 OK RET APPOK1 MOVE LBIN3,W1 OK UNCOND DISPLAY RET APPOK2 MOVE LBIN3,W2 OK NO DISPLAY RET APNOK3 MOVE LBIN3,W3 NOT OK ERROR MESSAGE RET APNOK4 MOVE LBIN3,W4 NOT OK EDIT-MODE RET EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=1 * WSMENU FUNCTION VALUE * ************************************************************************ APP010 PERF RANGE,W1,W4 ***RANGE 1-4 BOK APPOK0 OK MOVE LBIN4,W6 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=2 * SECTION NAME CONTROL * -ALREADY DEFINED? * -NOT FOUND? * -1ST POSITION ALPHABETIC * ************************************************************************ APP020 MOVE LSTR1,LSTR81 MOVE LBIN3,W6 FIELD LENGTH:=6 CBL LSTR1,=C'A',APP029 CBG LSTR1,=C'Z',APP029 PERF SPCPAD ***SPACE PADDING CALL ICLEAR,LSTR16 ---ASSRUT:CLEAR ITEM MOVE LSTR6A,=C' DSDS' TYPE = D(EFINITION) TYPE = S(ECTION) INSRT LSTR81,W0,W6,LSTR16,W0 NAME=> POS 6-11 XCOPY LSTR81,W5,W1,LSTR6A,GBIN1 STORE TYPE OF DATA = S MOVE LBIN1,W24 WORKPOINTER:=24 ADD LBIN1,W2 GIVING 26 XCOPY LSTR81,LBIN1,W8,GSTR8A,W0 STORE FILENAME ADD LBIN1,W8 ADJUST POINTER XCOPY LSTR81,LBIN1,W6,GSTR6C,W0 STORE VOLUME ID CLEAR LBOOLA FALSE=DISC-ERROR (IF ANY) CALL PSEARC,LSTR81,BPOOL(W1) ---SEARCH SECTION ON DISC BOK APP028 BL APP022 JMP IF CR=2 (DISC-ERROR) SET LBOOLA TRUE=POOL-ERROR APP022 CALL PCLOSE,LSTR81,BPOOL(W1) ---CLOSE DISC FILE CBL GBIN1,W3,APP027 JMP IF NEW TBT LBOOL4,APP027 JMP IF DUPLICATION TBT LBOOL8,APP027 JMP DUPL CH. SECT.NAME EJECT * * ERROR AT SEARCH * XCOPY LBIN3,W0,W2,LSTR81,W20 UNPACK RETCODE BIN CBE LBIN3,W1,APP02B JMP IF NOT FOUND MOVE LBIN4,W0 BIT-INDEX:=0 MOVE LSTR1,=X'31' LOAD '1' MOVE LSTR16,=X'30' LOAD WITH '0':S APP025 CALL TESTB,LBIN3,LBIN4 ---TEST BIT (INDEX) BOK APP026 JMP IF FALSE = 0 XCOPY LSTR16,LBIN4,W1,LSTR1,W0 LOAD '1' WHEN TRUE = 1 APP026 ADD LBIN4,W1 NEXT BITINDEX CBNG LBIN4,W15,APP025 GO ON UNTIL > 15 MOVE LBIN4,W8 ERRORMESSAGE NO:8 B APNOK3 APP027 DLETE LSTR81,W0,W6 DELETE PREVIOUS INSERTION B APPOK0 OK APP028 CALL PCLOSE,LSTR81,BPOOL(W1) ---CLOSE DISC FILE TBT LBOOL4,APP02A JMP IF DUPLICATION MOVE LBIN3,W6 POINTER:=6 MATCH LSTR81,LBIN3,W6,GSTR6A,W0,W6 MATCH IF SAME NAME BOK APP027 JMP IF SAME NAME TBT LBOOL8,APP02A JMP IF OLD CBG GBIN1,W2,APP027 OK IF UPDATE APP02A MOVE LBIN3,=W'28' '.......ALREADY DEFINED' B APP02C APP02B MOVE LBIN3,=W'26' '......NOT FOUND' APP02C DLETE LSTR81,W0,W6 DELETE PREFIX DLETE LSTR81,W20,W14 DELETE OVERFLOW INFO MOVE LBIN4,GBIN1 LOAD FUNCTION NUMBER CBL LBIN4,W3,APP02D SUB LBIN4,W2 CALC FOR DEF. OR SECTION APP02D ADD LBIN4,LBIN3 CALC PROPER ERROR-NUMBER B APNOK3 APP029 MOVE LBIN4,W9 ERROR MESSAGE NO=9 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=3 * SECTION TYPE CONTROL * ************************************************************************ APP030 PERF RANGE,W1,W6 ***RANGE 1-6 BOK APPOK0 MOVE LBIN4,W10 ERROR-MESSAGE NO=10 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=4 * SECTION SIZE ROWS 1-23 * ************************************************************************ APP040 MOVE VBIN5,W15 INDEX:=15 MOVE LBIN4,GBCD3I(VBIN5) LOAD EFFEKTIV ROW SIZE PERF RANGE,LBIN4,ROWS ***RANGE X-23 BOK APPOK0 OK MOVE LBIN4,W11 ERROR MESSAGE NO=11 MOVE LBCD3A,ROWS LOAD HIGH LIMITFOR ERR-TEXT B APNOK3 EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=5 * SECTION SIZE COLUMNS 1-80 * ************************************************************************ APP050 MOVE VBIN5,W16 INDEX:=16 MOVE LBIN4,GBCD3I(VBIN5) LOAD EFFEKTIV COLUMN SIZE PERF RANGE,LBIN4,COLS ***RANGE X-80 BOK APPOK0 MOVE LBIN4,W11 ERROR MESSAGE NO=11 MOVE LBCD3A,COLS LOAD HIGH LIMIT FOR ERR-TEXT B APNOK3 EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=6 * YES OR NO * ************************************************************************ APP060 PERF YESVNO ***YES AND NO CHECK BOK APPOK0 OK Y OR N MOVE LBIN4,W12 ERROR MESSAGE NO=12 B APNOK3 EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=7 * SCREEN BACKGROUND DECORATION * -N. NORMAL VIDEO -R. REVERSED IMAGE * -L. LOW INTENSITY * -H. HIGH INTENSITY * ************************************************************************ APP070 MOVE LSTR4A,=C'RH' DECORATION CODES MOVE LBIN3,W0 POINTER:=0 MATCH LSTR4A,LBIN3,W4,LSTR81,W0,W1 BNOK APP079 ILLEGAL DEC. CODE * * FURTHER CONTROLS TO BE SOLVED * B APPOK0 OK APP079 MOVE LBIN4,W6 ERROR-MESSAGE NO-6 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=8 * STATIC FIELD DECORATION DEFAULT * -N. NORMAL VIDEO -R. REVERSED IMAGE * -L. LOW INTENSITY * -H. HIGH INTENSITY * -U. UNDERLINE * -B. BLINKING * ************************************************************************ APP080 MOVE LSTR6A,=C'RHUB' DECORATION CODES MOVE LBIN3,W0 POINTER:=0 MATCH LSTR6A,LBIN3,W6,LSTR81,W0,W1 BNOK APP089 ILLEGAL DEC. CODE * * FURTHER CONTROLS TO BE SOLVED * B APPOK0 OK APP089 MOVE LBIN4,W6 ERROR-MESSAGE NO-6 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=9 * NUMBER OF HEADLINES * MUST NOT EXCEED MAX ROW NO * ************************************************************************ APP090 PERF RANGE,W0,LBIN8 ***RANGE 0-MAX ROW NO BOK APP092 OK MOVE LBIN4,W20 ERROR-MESSAGE NO-20 MOVE LBCD3A,LBIN8 LOAD MAX ROW NO B APNOK3 NOT OK APP092 MOVE LBIN1,W0 ATTAB-POINTER:=0 APP094 XCOPY LBIN4,W1,W1,ATTAB,LBIN1 STORE ROW NO CBE LBIN4,W0,APP099 END-OF-TABLE OK CBG LBIN4,LBIN3,APP099 JMP IF GR NO OF HLINES ADD LBIN1,W2 ADJUST POINTER XCOPY LBIN4,W1,W1,ATTAB,LBIN1 STORE SEQ NO CBNE LBIN4,=X'00FF',APP098 JMP IF ERR NOT STATIC ADD LBIN1,W2 ADJUST POINTER B APP094 GO ON APP098 MOVE LBIN4,W21 ERROR MESSAGE NO:21 B APNOK3 APP099 B APPOK0 OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=10 * CONTROL OF DEFAULT GUIDING MESSAGE * POS 1-2 MUST BE 'S:' FOR A SECTION MESSAGE * POS 1-2 MUST BE 'M:' FOR A LINE MESSAGE * NUMBER OF INPUT CHARACTERS MUST BE 1- 6 FOR A SECTION * NUMBER OF INPUT CHARACTERS MUST BE 1-78 FOR A LINE MESSAGE * POS 1 OF SECTION NAME MUST BE ALPHABETIC A-Z * ************************************************************************ APP100 MOVE LBIN4,W1 LOAD INDEX NUMB-OF-CHARS-TAB APP101 SUB LBIN1,W2 LENGTH ADJUSTMENT MOVE GBINIA(LBIN4),LBIN1 SAVE NUMB OF CHARACTERS MOVE LSTR4A,=C'S:M:' LOAD MESSAGE TYPES MOVE LBIN1,W0 WORKITEM:=0 MATCH LSTR4A,LBIN1,W4,LSTR81,W0,W2 WHAT TYPE? BNOK APP109 ERROR CBL GBINIA(LBIN4),W1,APP108 INCORRECT LENGTH CBE LBIN1,W2,APP105 JUMP IF LINE MESSAGE CBG GBINIA(LBIN4),W6,APP108 INCORRECT LENGTH XCOPY LSTR1,W0,W1,LSTR81,W2 COPY 1ST CHARACTER TO CHECK MOVE LBIN1,GBINIA(LBIN4) RELOAD NUMB OF INP CHARS ADD LBIN1,W2 ADJUST MOVE GBINIA(LBIN4),W6 SECTION NAME:=6 CHARACTERS MOVE LBIN3,W8 FIELD LENGTH:=8 B APP188 OK CHECK 1ST CHARACTER APP105 CBG GBINIA(LBIN4),=W'78',APP108 INCORRECT LENGTH B APPOK0 OK APP108 MOVE LBIN4,W6 ERROR-MESSAGE NO 6 B APNOK3 NOT OK APP109 MOVE LBIN4,W14 ERROR-MESSAGE NO 14 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=11 * ORIGIN-MEDIA TYPE CONTROL * 0=NO INPUT MEDIA * 1=KEYBOARD INPUT * >1=OTHER MEDIA * ************************************************************************ APP110 PERF RANGE,W0,W9 ***RANGE 0-9 BOK APPOK0 MOVE LBIN4,W6 ERROR-MESSAGE NO=6 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=12 * DUPLICATION REFERENCES * * FIELD NAME MUST BE DEFINED * -WS99 0<99<10 * -WA99 0<99<100 * -WN99 0<99<100 * ************************************************************************ APP120 MOVE LSTR6A,=C'WSWAWN' LOAD WSM WORK ITEM PREFIX MOVE LBIN4,W0 WORKPOINTER:=0 MATCH LSTR6A,LBIN4,W6,LSTR81,W0,W2 SEARCH WSMWORK BOK APP122 JMP IF WSM WORK ITEM CBG LBIN1,W4,APP129 NUMB OF CHARS > 4 MOVE LBIN3,W4 FIELD LENGTH:=4 PERF SPCPAD ***SPACE PADDING MOVE LBIN4,W0 WORKPOINTER:=0 MATCH FIDTAB,LBIN4,LFBIN,LSTR81,W0,W4 SERCH FIELD NAME BOK APPOK0 FIELD NAME FOUND OK B APP129 BRANCH ON ERROR * * CHECK UP DATA TABLE T99:99 * APP122 CBE LBIN1,W4,APP123 JMP IF 4 INP CHARS MOVE LBIN4,W1 ERROR MESSAGE NO:=1 B APNOK3 APP123 DLETE LSTR81,W0,W2 DELETE WSM WORK ITEM PREFIX MOVE LBIN1,W9 HIGH-LIMIT FOR WS09 CBL LBIN4,W2,APP124 JMP IF WS MOVE LBIN1,=W'99' HIGH-LIMIT FOR WA99 WN99 APP124 PERF RANGE,W0,LBIN1 ***RANGE 0-9/99 BNOK APP128 JMP IF ERROR COPY LSTR1,W0,W1,LSTR81,W0 1ST DIGIT-POS CBG LSTR1,=C'9',APP137 JMP IF NOT DIGIT CBL LSTR1,=C'0',APP137 JMP. IF NOT DIGIT INSRT LSTR81,W0,W2,LSTR6A,LBIN4 INSERT WSMWORKITEM PREFIX B APPOK0 APP128 INSRT LSTR81,W0,W2,LSTR6A,LBIN4 INSERT WSMWORKITEM PREFIX APP129 MOVE LBIN4,W17 ERRORMESSAGE NO=17 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=13 * AUTO SKIP/DUP OR BYPASS * ************************************************************************ APP130 MOVE LSTR1,LSTR81 CBE LSTR1,DUPL,APP132 JMP IF 'D' OK CBE LSTR1,BYPASS,APP138 JMP IF B' OK CBE LSTR1,SKIP,APP138 JMP IF 'S' OK CBE LSTR1,NO,APP138 JMP IF 'N' OK B APP139 APP132 CALL EMPTYT,GSTR1I(W24) ---CHECK IF EMPTY BNOK APP137 JMP IF EMPTY = N(O) DUPL CBE GSTR1I(W24),YES,APP138 JMP IF Y(ES) DUPL OK APP137 MOVE LBIN4,W6 ERROR-MESSAGE NO=6 B APNOK3 NOT OK APP138 B APPOK0 APP139 MOVE LBIN4,W18 ERROR-MESSAGE NO-18 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=14 * L(EFT) OR R(IGHT) ADJUSTED ? * ************************************************************************ APP140 MOVE LSTR1,LSTR81 CBE LSTR1,LEFT,APP145 CBE LSTR1,RIGHT,APP145 MOVE LBIN4,W19 ERROR MESSAGE NO=19 B APNOK3 NOT OK APP145 OK B APPOK0 OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=15 * PRINTOUT POSITION CONTROL * ************************************************************************ APP150 MOVE LBIN4,=W'127' HIGHLIMIT=127 PERF RANGE,W1,LBIN4 ***RANGE 1-127 BNOK APP169 NOK XCOPY LBIN4,W1,W1,GBINIA(W7),W0 ROW NO CBL LBIN3,LBIN4,APP159 B APPOK0 OK APP159 MOVE LBIN4,=W'25' ERROR-MESSAGENO=25 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=16 * PRINTOUT POSITION CONTROL * ************************************************************************ APP160 MOVE LBIN4,=W'127' HIGHLIMIT=127 PERF RANGE,W1,LBIN4 ***RANGE 1-127 BNOK APP169 NOK MOVE LBIN4,GBCD3I(W8) ROW NO XCOPY LBIN3,W0,W1,LBIN4,W1 ROW NO CBNG LBIN3,GBINIA(W7),APP159 B APPOK0 APP169 MOVE VBIN5,W12 INDEX:=12 MOVE GBCD3I(VBIN5),W1 LOAD EFFEKTIV ROW SIZE MOVE LBCD3A,LBIN4 MOVE LBIN4,W11 ERROR-MESSAGE NO=11 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=17 * DEFAULT VALUE * ************************************************************************ APP170 MOVE GBINIA(W2),LBIN1 SAVE NUMB OF CHARS B APPOK0 OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=18 * FIELD NAME CONTROL * ************************************************************************ APP180 MOVE LSTR9A,=C' ' SPACE MOVE LBIN20,W0 CLEAR POINTER MATCH LSTR81,LBIN20,LBIN1,LSTR9A,W0,W1 SPACE IN FIELD ID ? BNE APP180A NOT FOUND ADD LBIN20,W1 ADJUST FOUND SPACE POSITION CBNL LBIN20,LBIN1,APP180A JMP IF NOT LESS MOVE LBIN3,LBIN1 LOAD NUMB OF INPUT CHARACTERS SUB LBIN3,LBIN20 CALC REST TO INVESTIGATE MATCH LSTR81,LBIN20,LBIN3,LSTR9A,W0,LBIN3 MATCH IF REST = SPACE BOK APP180A OK IF REST = SPACES MOVE LBIN4,=W'32' ERROR MESSAGE:=32 B APNOK3 APP180A CALL GETIND,STMTS,VBIN8,LBIN3 ---GET ITEM LENGTH MOVE LBIN4,W0 INPUT BUFFER POINTER:=0 PERF BSVSEA,LBIN1,VBIN5 ***BASIC VERB SEARCH BNOK APP185 NO BASIC VERB GO ON APP183 MOVE LBIN4,=W'31' ERROR-MESSAGE:=31 B APNOK3 APP185 CBNE LBIN1,W3,APP186 JMP IF INPUTLENGTH /= 3 CALL GETIND,OPRTS,VBIN8,LBIN3 ---GET ITEM LENGTH MOVE LBIN3,=W'29' POINTER:=29 SUB VBIN8,LBIN3 CALC LENGTH TO MATCH MATCH OPRTS,LBIN3,VBIN8,LSTR81,W0,W3 MATCH FUNCTION BNOK APP187 NO FUNCTION OK XCOPY LBIN4,W1,W1,OPRVAL,LBIN3 GET OPERATION CODE CBNE LBIN4,=X'00FF',APP183 JMP IF OPERATION CODE=FUNCTION APP187 MOVE LBIN3,W20 POINTER:=20 MATCH OPRTS,LBIN3,W3,LSTR81,W0,W3 BOK APP183 NOT OK IF STR FUNCTION APP186 MOVE LBIN3,W4 FIELD LENGTH:=4 PERF SPCPAD ***SPACE PADDING MOVE LBIN4,W0 WORKPOINTER:=0 MATCH FIDTAB,LBIN4,LFBIN,LSTR81,W0,W4 SERCH FIELD NAME BNOK APP182 FIELD NAME NOT FOUND OK ADD LBIN4,W4 ADJUST POINTER TO REACH SEQ.NO XCOPY LBIN3,W1,W1,FIDTAB,LBIN4 GET SEQ NO CBE LBIN3,W0,APP181 NEW FIELD NOT OK WITH SAME ID CBE LBIN3,LBIN12,APP18B SAME SEQ.NO & F-ID => OK APP181 SUB LBIN4,W4 ADJUST CALL WXDIV,LBIN4,W5,LBIN4 CALC SEQ NO ADD LBIN4,W1 ....WHEN NEW FIELD CBE LBIN4,LBIN12,APP18B JMP IF SAME SEQ NO MOVE LBIN4,W15 ERROR MESSAGE NO=15 B APNOK3 NOT OK APP18B MOVE LBIN1,W0 =NO INPUT CALL ICLEAR,LSTR81 ---CLEAR ITEM B APPOK0 APP182 MOVE LSTR6A,=C'WSWAWN' LOAD WSM WORK ITEM PREFIX MOVE LBIN4,W0 WORKPOINTER:=0 MATCH LSTR6A,LBIN4,W6,LSTR81,W0,W2 SEARCH WSMWORK BNOK APP184 WSM WORK ITEM NOT FOUND OK MOVE LBIN4,W16 ERROR MESSAGE NO=16 B APNOK3 NOT OK APP184 MOVE LSTR1,LSTR81 MOVE LBIN3,W4 FIELD LENGTH:=4 APP188 CBL LSTR1,=C'A',APP189 CBG LSTR1,=C'Z',APP189 PERF SPCPAD ***SPACE PADDING B APPOK0 1ST CHARACTER OK APP189 MOVE LBIN4,W9 ERROR MESSAGE NO=9 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=19 * VOLUME NAME CONTROL * ************************************************************************ APP190 MOVE LBIN3,W6 FIELD LENGTH:=6 PERF SPCPAD ***SPACE PADDING MOVE LBIN3,W0 WORKITE=0 APP192 XCOPY LBIN4,W1,W1,DUNIT,LBIN3 GET FILE CODE CALL CHANFC,DISC,LBIN4 ---CHANGE FILE CODE CALL GETVOL,DISC,BPOOL(W1),LSTR6A,LBIN4 ---GET VOLUME NAME CALL CLEARB,LBIN4,W4 ---CLEAR BIT NO:=4 1MB-BIT CMP LBIN4,W0 CHECKRETURN CODE BNOK APP194 JUMP IF ERROR MATCH LSTR6A,LBIN4,W6,LSTR81,W0,W6 VOLUME NAME EQUAL ? BOK APPOK0 FOUND OK APP194 ADD LBIN3,W1 NEXT FILE CODE CBL LBIN3,W17,APP192 GO ON IF LESS 17 MOVE LBIN4,W23 ERROR-MESSAGE /NOT LOADED' B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=20 * FILENAME CONTROL * ************************************************************************ APP200 MOVE LBIN3,W8 FIELD LENGTH :=8 PERF SPCPAD ***SPACE PADDING CALL ICLEAR,LSTR16 ---ASSRUT:CLEAR ITEM MOVE LSTR6A,=C' DSDS' TYPE = D(EFINITION) TYPE = S(ECTION) INSRT LSTR81,W0,W16,LSTR16,W0 FILENAME=> POS 16-23 INSRT LSTR81,W16,W10,LSTR16,W0 FILENAME=> POS 26-33 XCOPY LSTR81,W5,W1,LSTR6A,GBIN1 STORE TYPE OF DATA = S MOVE LBIN1,W24 WORKPOINTER:=24 ADD LBIN1,W10 GIVING 34 XCOPY LSTR81,LBIN1,W6,GSTR6C,W0 STORE VOLUME ID CALL POPEN,LSTR81,BPOOL(W1) ---OPEN DISC FILE BNOK APP208 JMP IF NOT FOUND CALL PCLOSE,LSTR81,BPOOL(W1) ---CLOSE DISC-FILE SUB LBIN1,W8 ADJUST NUMBER TO DELETE DLETE LSTR81,W0,LBIN1 DELETE OVERFLOW INFO B APPOK0 JMP OK APP208 CALL PCLOSE,LSTR81,BPOOL(W1) ---CLOSE DISC-FILE SUB LBIN1,W8 ADJUST NUMBER TO DELETE DLETE LSTR81,W0,LBIN1 DELETE OVERFLOW INFO DLETE LSTR81,W8,W6 DELETE OVERFLOW INFO MOVE LBIN4,W24 ERROR MESSAGENO:=24 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=21 * (.) OR (,) ? * ************************************************************************ APP210 MOVE LSTR1,LSTR81 CBE LSTR1,=C'.',APP215 CBE LSTR1,=C',',APP215 MOVE LBIN4,W13 ERROR-MESSAGE NO 13 B APNOK3 NOT OK APP215 OK B APPOK0 OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=22 * GUIDING MESSAGE * ************************************************************************ APP220 MOVE LBIN4,W3 LOAD INDEX NUMB-OF-CHARS-TAB B APP101 CHECK MESSAGE TYPE EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=23 * APPLICATION MESSAGE * ************************************************************************ APP230 MOVE GBINIA(W4),LBIN1 LOAD NUMB OF CHARS B APPOK0 EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=24 * VALIDATION CONTROL * ************************************************************************ APP240 PERF SYNVAL ***SYNTAX-CONTROL VALIDATION BNOK APP248 JMP IF NOT OK MOVE GBINIA(VBIN1),LBIN1 SAVE NUMB CHARS OF BASIC LINE B APPOK0 APP248 MOVE LBCD3A,LBIN4 SYNTAX ERROR NUMBER MOVE LBIN4,=W'26' ERROR-MESSAGE NO=26 B APNOK3 NOT OK EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=25 * DUPLICATION * ************************************************************************ APP250 PERF YESVNO ***YES AND NO CHECK BNOK APP259 JMP IF NOT OK CBE LSTR1,YES,APP254 JMP IF Y OK CBE GSTR1I(W16),DUPL,APP258 JMP IF SKP.DUP.BYP =D APP254 OK B APPOK0 APP258 GETABX LBIN4 GET CURRENT FIELD NUMBER ADD LBIN4,W2 FIELDNUMBER:=FIELDNUMBER+2 GETFLD 0,LBIN4,LBIN3 MAKE FIELD CURRENT MOVE LBIN4,W6 ERROR-MESSAGE=& B APNOK3 APP259 MOVE LBIN4,W12 ERRORMESSAGE=12 B APNOK3 EJECT ************************************************************************ * * APPLICATION-ROUTINE NO=26 * SECTION NAME * ************************************************************************ APP260 MOVE LSTR1,LSTR81 MOVE LBIN3,W6 LENGTH=6 B APP188 ************************************************************************ * * APPLICATION-ROUTINE NO=27 * PRINT-DEVICE * ************************************************************************ APP270 MOVE LSTR2,LSTR81 CBE LSTR2,='LP',OKDEV CBE LSTR2,='GP',OKDEV MOVE LBIN4,=W'35' B APNOK3 OKDEV B APPOK1 EJECT ********************************************************************* * * APPLICATION-ROUTINE NO=28 * OVER-RIDE * ********************************************************************* APP280 MOVE LBIN3,W4 PERF SPCPAD ***SPACE PADDING MOVE LBIN4,W0 WORKPOINTER:=0 MATCH FIDTAB,LBIN4,LFBIN,LSTR81,W0,W4 SEARCH FIELD NAME BNOK APP282 MOVE LBIN3,W0 WORKPOINTER:=0 MATCH FIDTAB,LBIN3,LFBIN,GSTR4A,W0,W4 SEE IF BACKWARD CBL LBIN4,LBIN3,APP286 JMP IF BACKWARD MOVE LBIN4,W0 WORKPOINTER:=0 MATCH GSTR4A,LBIN4,W4,LSTR81,W0,W4 SEE IF SAME FIELD BOK APP284 B APPOK0 FIELD NAME FOUND EJECT APP282 MOVE LBIN4,=W'38' "FIELD NAME NOT FOUND" B APNOK3 APP284 MOVE LBIN4,=W'39' "YOU ARE ALREADY THERE!!" B APNOK3 APP286 MOVE LBIN4,=W'40' "ILLEGAL DIRECTION TO WANTED FIELD-NAME" B APNOK3 PEND EJECT ************************************************************************ * * RANGE CONTENT OF 'LBIN3' * INPUT FORMAL PARAMETERS * -LLIMIT = LOWLIMIT * -HLIMIT = HIGHLIMIT * ************************************************************************ RANGE PROC LLIMIT,HLIMIT PBIN LLIMIT PBIN HLIMIT PERF STRBIN ***CONVERT TO BINARY CBL LBIN3,LLIMIT,RANGE9 LESS LOWLIMIT CBG LBIN3,HLIMIT,RANGE9 GREATER HIGHLIMIT CMP W0,W0 CLEAR COND.REG. RET RANGE9 CMP W0,W1 SET COND.REG. RET PEND EJECT ************************************************************************ * * CONVERT NUMERIC STRING VALUE INTO BINARY * ************************************************************************ STRBIN PROC MOVE LBCD3A,LSTR81 LOAD INPUT DECIMAL MOVE LBIN3,LBCD3A LOAD DECIMAL TO BINARY RET PEND ************************************************************************ * * CONTROL IF INPUT IS Y(ES) OR N(O) * ************************************************************************ YESVNO PROC MOVE LSTR1,LSTR81 CBE LSTR1,NO,YESOK0 CBE LSTR1,YES,YESOK0 CMP W0,W1 SET COND-REG=1 RET YESOK0 CMP W0,W0 CLEAR COND-REG=0 RET PEND EJECT ************************************************************************ * * PAD REST OF INPUT BUFFER (LSTR81) ,UP TO ACTUAL FIELD LENGTH * WITH X'20':S * * INPUT LBIN1 = NUMBER OF INPUT CHARACTERS OF INPUT BU * LBIN3 = ACTUAL FIELD LENGTH * LSTR81 = INPUT BUFFER * * OUTPUT LBIN1 = ACTUAL FIELD LENGTH (MAX-LENGTH) * LSTR81 = INPUT BUFFER PADDED WITH X'20':S * ************************************************************************ SPCPAD PROC MOVE LSTR9A,=X'20' LOAD SPACE-STRING SUB LBIN3,LBIN1 CALC NUMBER OF EMPTY POSITIONS BZ SPC999 JUMP IF NO EMPTY POS XCOPY LSTR81,LBIN1,LBIN3,LSTR9A,W0 COPY X'20':S ADD LBIN1,LBIN3 :=MEX FIELD LENGTH SPC999 RET PEND END