0001 * 0002 * 0003 * EXTRACT COMMAND 0004 * 0005 * WRITTEN: T. FREDENBURG 7/02/77 0006 * MODIFIED: 8/27/77 0007 * MODIFIED: D. RICHARDS 11/8/78 0008 * 0009 * 0010 COPY PTDEFS 0011 ORG 100H 0012 XEQ 100H 0013 * 0014 TRUE EQU 1 FLAG VALUE 0015 FALSE EQU 0 " " 0016 STLEN EQU 100H LENGTH OF STACK 0017 BFLEN EQU 800H LENGTH FILE COPY BUFFER. MAKE >= NAMAX+1AH 0018 NAMAX EQU 10 MAXIMUM LENGTH OF FILE NAMES INCLUDING UNIT 0019 CR EQU 0DH CARRIAGE RETURN 0020 LF EQU 0AH LINE FEED 0021 * 0022 * 0023 ********************************************************** 0024 * 0025 * INITIALIZE 0026 * 0027 INIT LXI SP,STACK+STLEN 0028 LHLD SYSGLO GET CI OUTPUT FILE # 0029 LXI B,GLCOF COMPUTE OFFSET FROM START OF GLOBAL TABLE 0030 DAD B 0031 MOV A,M GET FILE # 0032 STA OUTFN AND STORE IT 0033 * 0034 * SET UP ERROR RETURNS 0035 * 0036 MVI A,-1 NEW VALUE FOR ERROR TRAPS 0037 LHLD SYSGLO GET ERROR TRAP #S AND SAVE THEM 0038 LXI B,GLERH LEVEL 0 (HARD) ERROR TRAP 0039 DAD B 0040 MOV E,M GET PREVIOUS VALUE 0041 MOV M,A NEW VALUE, ERRORS RETURN TO CALL+1 0042 INX H 0043 MOV D,M OLD 0044 MOV M,A NEW 0045 XCHG . PUT PREVIOUS VALUE IN HL 0046 SHLD ERTP0 AND SAVE IT 0047 * 0048 LHLD SYSGLO LEVEL 1 ERROR TRAP 0049 LXI B,GLERM MEDIUM 0050 DAD B 0051 MOV E,M GET PREVIOUS VALUE 0052 MOV M,A NEW VALUE 0053 INX H 0054 MOV D,M OLD 0055 MOV M,A NEW 0056 XCHG . SAVE OLD VALUE 0057 SHLD ERTP1 0058 * 0059 LHLD SYSGLO LEVEL 2 ERROR TRAP 0060 LXI B,GLERS SOFT 0061 DAD B 0062 MOV E,M GET PREVIOUS VALUE 0063 MOV M,A NEW VALUE 0064 INX H 0065 MOV D,M OLD 0066 MOV M,A NEW 0067 XCHG . SAVE NEW VALUE 0068 SHLD ERTP2 0069 * 0070 * 0071 ********************************************************** 0072 * 0073 * READ IN COMMAND 0074 * 0075 * 0076 * READ IN FILE NAME 0077 * 0078 LXI D,BUFF BUFFER FOR PSCAN 0079 MVI A,01H OPEN, DON'T CREATE 0080 CALL PSCAN 0081 CC PSCER 0082 PUSH PSW SAVE LAST CHAR READ 0083 MOV A,E SAVE POSSIBLE FILE # 0084 MVI E,0 CLEAR E FOR POSSIBLE ABORT DUE TO NO CHARS READ 0085 CZ PSCER NO CHARS READ 0086 CPI 0FFH SEE IF A FILE WAS OPENED 0087 CZ OPNER FILE NOT OPENED 0088 STA FILEN STORE FILE NUMBER 0089 * 0090 * CHECK IF FILE IS TYPE IMAGE 0091 * 0092 LXI D,BUFF WHERE FILE NAME IS 0093 LXI H,BUFF+NAMAX+1 WHERE INFO WILL GO 0094 CALL SYS GET INFO 0095 DB INFOP 0096 CALL ABORT 0097 LDA BUFF+NAMAX+1+0BH GET FILE TYPE; TYPE IS B BYTES IN 0098 ORA A SET FLAGS 0099 CM TYPER IF HIGH BIT IS 1 FILE IS NOT IMAGE 0100 * 0101 * READ IN AND SET SCRUNCH AND LIST FLAGS 0102 * 0103 FLAGS POP PSW CHECK IF END OF COMMAND WAS READ 0104 CPI ';' SEMI-COLON IS COMMAND SEPARATOR 0105 JZ SCRUN ALL OF COMMAND READ 0106 CPI CR CR IS ALSO END OF COMMAND 0107 JZ SCRUN DONE READING 0108 * 0109 LXI D,BUFF SET UP FOR PSCAN READ OF FLAGS 0110 MVI A,05H DON'T OPEN, DON'T CREATE 0111 CALL PSCAN 0112 CC PSCER 0113 JZ SCRUN NO MORE FLAGS 0114 PUSH PSW SAVE LAST CHAR READ 0115 * 0116 LXI D,BUFF SET VALUES OF FLAGS SPECIFIED 0117 FLOOP MVI B,TRUE INITIALIZE POSSIBLE VALUE OF FLAG 0118 FREAD LDAX D GET A CHAR 0119 INX D ADVANCE BUFFER POINTER 0120 ORA A SET FLAGS FOR TEST OF END OF INPUT CHARS 0121 JZ FLAGS 0122 CPI '-' SEE IF FLAG IS TO BE FALSE 0123 JNZ SFLAG 0124 MVI B,FALSE IF SO, ADJUST FLAG VALUE 0125 JMP FREAD AND GO GET NEXT CHAR 0126 * 0127 SFLAG CPI 'a' UPSHIFT FLAG 0128 JC SFL1 0129 XRI 20H 0130 SFL1 CPI 'S' SEE IF SCRUNCH FLAG IS SPECIFIED 0131 JNZ LFLAG 0132 MOV A,B IF SO, SET FLAG 0133 STA SCRNF 0134 JMP FLOOP AND CHECK FOR NEXT FLAG 0135 * 0136 LFLAG CPI 'L' SEE IF LIST FLAG MENTIONED 0137 CNZ FLGER UNRECOGNIZED FLAG 0138 MOV A,B SET VALUE OF FLAG 0139 STA LISTF 0140 JMP FLOOP NEXT FLAG 0141 * 0142 * 0143 ********************************************************** 0144 * 0145 * SCRUNCH ROUTINE 0146 * 0147 * 0148 * CHECK IF WE ARE SCRUNCHING 0149 * 0150 SCRUN LDA SCRNF GET SCRUNCH FLAG 0151 CPI FALSE 0152 JZ LIST IF NOT THEN GO TO LIST ROUTINE 0153 * 0154 * READ IN FIRST HEADER AND CHECK IT FOR STARTING BLOCK 0155 * 0156 LDA FILEN GET FIRST HEADER 0157 LXI B,4 0158 LXI D,HEAD1 WHERE HEADER GOES 0159 CALL SYS 0160 DB RBLOP 0161 CALL ENDTS EOF ERROR IS OK; CHECK FOR IT 0162 LHLD HEAD1 SEE IF STARTING BLOCK WAS READ 0163 MOV A,H BY CHECKING IF THE BYTE COUNT IS ZERO 0164 ORA L 0165 JZ LIST IF IT WAS STARTING BLOCK THEN NO SCRUNCH 0166 * 0167 * LOOP BACK HERE AFTER EACH BLOCK 0168 * 0169 * SPACE TO NEXT HEADER 0170 * 0171 SKIP CALL INTST CHECK FOR QUIT CHAR FROM CONSOLE 0172 LDA FILEN GET FILE # TO SPACE TO NEXT HEADER 0173 LHLD HEAD1 GET BYTE COUNT 0174 MOV B,H AND PUT IT IN BC 0175 MOV C,L 0176 MVI D,1 SPACE FORWARD 0177 CALL SYS 0178 DB SPAOP 0179 CALL SPCER 0180 * 0181 * READ SECOND HEADER AND CHECK FOR STARTING BLOCK 0182 * 0183 LDA FILEN GET FILE # 0184 LXI B,4 4 BYTES 0185 LXI D,HEAD2 WHERE SECONDARY HEADER GOES 0186 CALL SYS 0187 DB RBLOP 0188 CALL ENDTS 0189 LHLD HEAD2 SEE IF STARTING BLOCK WAS READ 0190 MOV A,H WITH BYTE COUNT ZERO 0191 ORA L 0192 JZ LIST STARTING BLOCK, SO DONE SCRUNCHING 0193 * 0194 * CHECK IF SCRUNCH IS POSSIBLE 0195 * 0196 LXI H,HEAD2+2 ADDR OF 2ND LOAD ADDR 0197 MOV A,M SEE IF IT EQUALS 1ST LOAD ADDR + 1ST BYTE COUNT 0198 CMA 0199 MOV C,A DO COMPARISON BY COMPLEMENTING 2ND LOAD ADDR 0200 INX H AND ADDING IT TO THE OTHER 2 NUMBERS 0201 MOV A,M 0202 CMA 0203 MOV B,A 0204 INX B 0205 LHLD HEAD1 CALCULATE SUM FROM 1ST HEADER 0206 XCHG . BYTE COUNT INTO DE 0207 LHLD HEAD1+2 LOAD ADDRESS INTO HL 0208 DAD D ADD IN BYTE COUNT 0209 DAD B SUBTRACT 2ND LOAD ADDRESS 0210 MOV A,H IF RESULT IS NON-ZERO THEN WE CAN'T SCRUNCH 0211 ORA L 0212 JNZ DONT CANT SCRUNCH 0213 LHLD HEAD2 NOW COMPUTE POSSIBLE NEW BYTE COUNT 0214 DAD D ADD HEADER1 BYTE COUNT TO HEADER2 BYTE COUNT 0215 JNC SCRCH IF COUNT <= FFFF THEN WE CAN SCRUNCH 0216 * 0217 * CAN'T SCRUNCH SO PUT HEADER2 INTO HEADER1 AND LOOP BACK 0218 * 0219 DONT LXI B,HEAD1 IN MEMORY, MOVE TO HEAD1 0220 LXI D,HEAD2 FROM HEAD2 0221 MVI L,4 L IS COUNTER FOR LOOP 0222 MOVLP LDAX D 4 BYTES ARE MOVED FROM HEADER2 ... 0223 STAX B TO HEADER 1 0224 INX B 0225 INX D 0226 DCR L ADJUST AND CHECK COUNTER 0227 MOV A,L 0228 ORA A SET FLAGS 0229 JNZ MOVLP 0230 JMP SKIP WHEN HEADER IS TRANSFERED, LOOP BACK 0231 * 0232 * WE CAN SCRUNCH. FIRST ADJUST BYTE COUNT IN FILE 0233 * 0234 SCRCH LDA FILEN SCRUNCH; MOVE BACK TO ADJUST BYTE COUNT 0235 PUSH H PRESERVE NEW BYTE COUNT 0236 LHLD HEAD1 MUST MOVE BACK BYTE COUNT FROM HEADER1 0237 LXI B,8 PLUS 8 BYTES (BOTH HEADERS) 0238 DAD B 0239 MOV B,H COUNT IN BC FOR SPACE 0240 MOV C,L 0241 MVI D,128 SPACE BACK 0242 CALL SYS 0243 DB SPAOP 0244 CALL ABORT 0245 * 0246 LHLD HEAD1 GET OLD BYTE COUNT FOR LATER SPACE 0247 XCHG . SAVE IT IN DE 0248 POP H GET BACK NEW BYTE COUNT 0249 SHLD HEAD1 PUT NEW COUNT IN HEADER 1 0250 XCHG . PUT OLD BYTE COUNT BACK IN HL 0251 LDA FILEN GET FILE # TO PUT NEW COUNT ON FILE 0252 LXI B,2 TRANSFER COUNT 0253 LXI D,HEAD1 GET NEW COUNT FROM HEADER 1 0254 CALL SYS 0255 DB WBLOP 0256 CALL ABORT 0257 * 0258 * MOVE TO END OF 1ST BLOCK (START OF HEADER2) 0259 * 0260 PUSH H INITIALIZE BACKCOUNT 0261 LXI H,-2 WE WANT TO RETURN TO JUST PAST HEADER 1 0262 SHLD BACKCOUNT WHICH IS -2 BACK FROM LOAD ADDRESS 0263 POP H RESTORE HL 0264 LXI D,2 HEADER2 IS 2 BYTES PLUS 0265 DAD D OLD BYTE COUNT AWAY 0266 MOV B,H TRANSFER COUNT IN BC 0267 MOV C,L 0268 CALL UPBACK UPDATE BACKCOUNT 0269 LDA FILEN FILE # 0270 MVI D,1 SPACE FORWARD 0271 CALL SYS 0272 DB SPAOP 0273 CALL ABORT 0274 * 0275 * SHRINK FILE BY 4 BYTES TO ELIMINATE OLD HEADER2. 0276 * THIS IS DONE BY COPYING THE ENTIRE REST OF THE FILE 0277 * BACK INTO ITSELF 4 BYTES EARLIER VIA A MEMORY BUFFER. 0278 * THIS IS DONE SO THAT IF AN ERROR OCCURS OR THE COMMAND 0279 * IS INTERRUPTED THEN THE FILE WILL STILL BE IN IMAGE 0280 * FORMAT (UNLESS AN ERROR OCCURS DURING THE COPY). 0281 * 0282 * SPACE FORWARD 4 BYTES TO NEW INFO 0283 * 0284 COPY LXI B,4 COUNT FOR SPACE 0285 MVI D,1 FORWARD 0286 LDA FILEN FILE # 0287 CALL SYS SPACE TO NEW INFO 0288 DB SPAOP 0289 CALL SPCER 0290 * 0291 * READ NEW INFO INTO BUFFER 0292 * 0293 LDA FILEN FILE # FOR READ 0294 LXI B,BFLEN TRANSFER MAXIMUM # OF BYTES OF NEW INFO 0295 LXI D,BUFF INTO BUFFER 0296 CALL SYS READ NEW INFO 0297 DB RBLOP 0298 CALL RDERR EOF IS VALID, CHECK FOR IT 0299 * 0300 * SPACE BACK TO WHERE INFO GOES 0301 * 0302 LXI B,BFLEN+4 COUNT FOR SPACE 0303 LDA FILEN FILE # 0304 MVI D,128 SPACE BACK 0305 CALL SYS 0306 DB SPAOP 0307 CALL ABORT 0308 * 0309 * WRITE NEW INFO 0310 * 0311 LDA FILEN FILE # 0312 LXI B,BFLEN TRANSFER COUNT 0313 CALL UPBACK UPDATE BACKCOUNT 0314 LXI D,BUFF CURRENT LOCATION OF NEW INFO 0315 CALL SYS WRITE 0316 DB WBLOP 0317 CALL ABORT 0318 * 0319 JMP COPY LOOP BACK FOR MORE NEW INFO 0320 * 0321 * FINISH WRITING NEW INFO 0322 * 0323 RDERR CPI EREOF CHECK FOR END OF FILE 0324 JNZ ABORT IF NOT THEN REAL LIVE ERROR 0325 POP H GET RID OF RETURN ADDRESS 0326 MOV A,B COMPUTE # OF BYTES ACTUALLY TRANSFERED 0327 CMA . WHICH IS BFLEN - BC 0328 MOV B,A SO COMPLEMENT BC AND ADD IT TO BFLEN 0329 MOV A,C 0330 CMA 0331 MOV C,A 0332 INX B 0333 LXI H,BFLEN LENGTH OF BUFFER 0334 DAD B HL HAS # OF BYTES TRANSFERED 0335 MOV D,H PUT COPY IN DE 0336 MOV E,L 0337 * 0338 LXI B,4 WE MUST SPACE BACK THIS # +4 0339 DAD B 0340 MOV B,H SPACE COUNT INTO BC 0341 MOV C,L 0342 XCHG . SAVE # TRANSFERED IN HL 0343 MVI D,128 SPACE BACKWARD 0344 LDA FILEN FILE # 0345 CALL SYS 0346 DB SPAOP 0347 CALL ABORT 0348 * 0349 MOV B,H PUT # OF BYTES TO BE WRITTEN IN BC 0350 MOV C,L 0351 CALL UPBACK UPDATE BACKCOUNT 0352 LDA FILEN FILE # 0353 LXI D,BUFF INFO IN BUFFER 0354 CALL SYS WRITE REST OF NEW INFO 0355 DB WBLOP 0356 CALL ABORT 0357 * 0358 * PUT NEW EOF IN FILE 0359 * 0360 LDA FILEN FILE # SO TO PUT NEW EOF ON FILE 0361 CALL SYS 0362 DB EOFOP 0363 CALL ABORT 0364 * 0365 * RETURN TO BEGINNING OF SCRUNCHED BLOCK BY SPACING 0366 * BACK THE AMOUNT IN BACKCOUNT. 0367 * 0368 LDA FILEN FILE # TO REWIND FILE 0369 MVI D,128 SPACE BACKWARD 0370 LHLD BACKCOUNT GET SPACE COUNT 0371 MOV B,H INTO BC FOR TRANSFER COUNT 0372 MOV C,L 0373 CALL SYS 0374 DB SPAOP 0375 CALL ABORT 0376 JMP SKIP LOOP BACK AND DO IT ALL OVER AGAIN 0377 * 0378 * 0379 UPBACK PUSH H MAKE SOME ROOM TO UPDATE BACKCOUNT 0380 LHLD BACKCOUNT GET CURRENT VALUE 0381 DAD B NEXT MOVEMENT IS IN BC 0382 SHLD BACKCOUNT STORE UPDATED 0383 POP H RESTORE HL 0384 RET . SIMPLE! 0385 * 0386 * 0387 * CHECK IF ERROR ON READING NEW HEADER WAS OK 0388 * 0389 ENDTS CPI EREOF CHECK FOR EOF 0390 JNZ ABORT ANYTHING ELSE IS BAD 0391 POP H GET RID OF RETURN ADDRESS 0392 MVI A,4 SEE IF NO BYTES WERE READ 0393 CMP C 0394 JZ LIST THAT'S OK, NO STARTING ADDRESS 0395 MVI A,2 CHECK IF JUST STARTING ADDR WAS READ 0396 CMP C 0397 JZ LIST OK ALSO 0398 CALL IMGER ANYTHING ELSE IS WRONG 0399 * 0400 * 0401 ********************************************************** 0402 * 0403 * LIST ROUTINE 0404 * 0405 * 0406 * CHECK IF WE ARE LISTING 0407 * 0408 LIST LDA LISTF LIST FLAG 0409 CPI FALSE 0410 JZ RETRN IF NOT, THAT'S IT 0411 * 0412 * REWIND FILE 0413 * 0414 LDA FILEN 0415 MVI D,0 REWIND 0416 CALL SYS 0417 DB SPAOP 0418 CALL ABORT 0419 * 0420 * MAIN LIST LOOP 0421 * 0422 * READ HEADER 0423 * 0424 LLOOP CALL INTST CHECK FOR QUIT INPUT FROM CONSOLE 0425 LXI B,4 4 BYTES IN HEADER 0426 LXI D,HEAD1 READ BLOCK HEADER INTO HEAD1 0427 LDA FILEN 0428 CALL SYS READ HEADER 0429 DB RBLOP 0430 CALL TEST CHECK IF ERROR IS A VALID EOF 0431 * 0432 * CHECK FOR STARTING ADDRESS BLOCK 0433 * 0434 LHLD HEAD1 GET BYTE COUNT 0435 MOV A,H IF IT IS ZERO 0436 ORA L 0437 JZ START THEN THIS IS START BLOCK 0438 * 0439 * REGULAR BLOCK; OUTPUT LOCATION AND LENGTH 0440 * 0441 LXI D,MES1 PRINT 'SEGMENT LOADED AT ' 0442 CALL MESG 0443 LHLD HEAD1+2 LOAD ADDRESS 0444 CALL NMOUT PRINT LOAD ADDR 0445 LXI D,MES2 PRINT ' IS ' 0446 CALL MESG 0447 LHLD HEAD1 BYTE COUNT 0448 CALL NMOUT PRINT BYTE COUNT 0449 LXI D,MES3 PRINT ' BYTES LONG' 0450 CALL MESG 0451 * 0452 * SPACE FORWARD TO NEXT HEADER 0453 * 0454 LHLD HEAD1 SPACE FORWARD BYTE COUNT OF CURRENT HEADER 0455 MOV B,H COUNT IN BC 0456 MOV C,L 0457 LDA FILEN FILE # 0458 MVI D,1 SPACE FORWARD 0459 CALL SYS 0460 DB SPAOP 0461 CALL LSPER 0462 * 0463 JMP LLOOP GO BACK AND READ HEADER 0464 * 0465 * 0466 * CHECK IF ERROR ON READ OF HEADER WAS OK 0467 * 0468 TEST CPI EREOF SEE IF ERROR WAS EOF (WE HOPE) 0469 JNZ ABORT TOO BAD 0470 POP H GET RID OF RETURN ADDRESS 0471 MVI A,4 SEE IF NO STARTING ADDRESS PRESENT 0472 CMP C 0473 JZ RETRN IF NONE THEN DONE 0474 MVI A,2 CHECK FOR BLOCK WITH ONLY 2 BYTES 0475 CMP C 0476 CNZ IMAER IF NOT THEN UNKNOWN CONFIGURATION 0477 LHLD HEAD1 LOAD ADDRESS IS FIRST WORD OF HEADER 0478 JMP STOUT 0479 * 0480 * PRINT STARTING ADDRESS 0481 * 0482 START LHLD HEAD1+2 LOAD ADDRESS IN SECOND WORD OF HEADER 0483 STOUT LXI D,STMES OUTPUT MESSAGE WITH STARTING ADDRESS 0484 CALL MESG 0485 CALL NMOUT ADDRESS OUT 0486 LXI D,CARET CARRIAGE RETURN AND LINE FEED TO FINISH LINE 0487 CALL MESG 0488 JMP RETRN ALL DONE 0489 * 0490 * 0491 MES1 ASC 'Segment loaded at ' 0492 DB 0 0493 MES2 ASC ' is ' 0494 DB 0 0495 MES3 ASC ' bytes long' 0496 DB CR 0497 DB LF 0498 DB 0 0499 STMES ASC 'Starting address is ' 0500 DB 0 0501 CARET DB CR 0502 DB LF 0503 DB 0 0504 * 0505 * 0506 ********************************************************** 0507 * 0508 * CHECK IF COMMAND IS TO BE INTERRUPTED 0509 * 0510 INTST CALL CONTST CHECK FOR A KEY PRESSED 0511 RZ . RETURN IF NO KEY PRESSED 0512 CALL CONIN GET CHAR 0513 ANI 7FH SET FLAGS /// CHANGED FROM ORA A 0514 JZ RSET IF NULL CHAR (MODE SELECT) THEN QUIT 0515 LHLD SYSGLO PUT UNUSED CHAR BACK 0516 LXI D,GLFLG 0517 DAD D 0518 MOV M,A WE KNOW CHAR IS NON-ZERO, SO WILL SET FLAG 0519 RET . OTHERWISE CONTINUE 0520 * 0521 * 0522 ********************************************************** 0523 * 0524 * RETURNS TO CI 0525 * 0526 * 0527 * NORMAL RETURN 0528 * 0529 RETRN LDA FILEN MUST CLOSE FILE 0530 CALL SYS 0531 DB CLOOP 0532 CALL ABORT ERROR 0533 CALL ERRST RESET ERROR TRAPS TO PREVIOUS VALUES 0534 CALL SYS AND RETURN 0535 DB RETOP 0536 * 0537 * RETURN AFTER ERROR MESSAGE PRINTED 0538 * 0539 RSET CALL CLOSE TRY TO CLOSE FILE 0540 CALL ERRST RESET ERROR TRAPS TO PREVIOUS VALUES 0541 CALL SYS RETURN 0542 DB RESOP 0543 * 0544 * 0545 * SUBROUTINE TO TRY TO CLOSE FILE 0546 * 0547 CLOSE LDA FILEN GET FILE # 0548 CALL SYS 0549 DB CLOOP 0550 RET . NO ERROR HANDLING SINCE WE ALREADY HAD AN ERROR 0551 NOP 0552 NOP 0553 RET 0554 * 0555 * ERROR TRAP RESET 0556 * 0557 ERRST LHLD SYSGLO RESET ERROR TRAPS TO PREVIOUS VALUES 0558 LXI B,GLERH LEVEL 0 ERROR TRAP 0559 DAD B 0560 XCHG . ADDR INTO DE 0561 LHLD ERTP0 GET OLD VALUE 0562 XCHG . ADDR IN HL, VALUE IN DE 0563 MOV M,E PUT BACK OLD VALUE 0564 INX H 0565 MOV M,D 0566 * 0567 LHLD SYSGLO RESET LEVEL 1 ERROR TRAP 0568 LXI B,GLERM MEDIUM 0569 DAD B 0570 XCHG . ADDR IN DE 0571 LHLD ERTP1 OLD VALUE 0572 XCHG . ADDR IN HL; VALUE IN DE 0573 MOV M,E REPLACE OLD VALUE 0574 INX H 0575 MOV M,D 0576 * 0577 LHLD SYSGLO RESET LEVEL 2 ERROR TRAP 0578 LXI B,GLERS SOFT 0579 DAD B 0580 XCHG . ADDR IN DE 0581 LHLD ERTP2 GET OLD VALUE 0582 XCHG . ADDR IN HL; VALUE IN DE 0583 MOV M,E REPLACE OLD VALUE 0584 INX H 0585 MOV M,D 0586 * 0587 RET 0588 * 0589 * 0590 ********************************************************** 0591 * 0592 * ERROR ROUTINES 0593 * 0594 PSCER MOV A,E PARAMETER SCANNER DETECTED AN ERROR 0595 ORA A SET FLAGS 0596 JNZ GENER IF E WAS NOT 0, THEN PTDOS ERROR 0597 LXI D,PSCMS ELSE FIELD ERROR 0598 CALL ERRMESG 0599 JMP RSET 0600 * 0601 PSCMS ASC 'Argument field error' 0602 DB 0 0603 * 0604 * 0605 OPNER LXI D,OPNMS FILE NOT OPENED BY PSCAN (?) 0606 CALL ERRMESG PRINT ERROR MESSAGE 0607 JMP RSET AND RETURN 0608 * 0609 OPNMS ASC 'File not opened' 0610 DB 0 0611 * 0612 * 0613 FLGER LXI D,FLGMS UNRECOGNIZED FLAG ERROR ROUTINE 0614 CALL ERRMESG PRINT MESSAGE 0615 JMP RSET AND RETURN TO CI 0616 * 0617 FLGMS ASC 'Unrecognized flag' 0618 DB 0 0619 * 0620 * 0621 TYPER LXI D,TYPMS PRINT FILE NOT IMAGE MESSAGE 0622 CALL ERRMESG 0623 JMP RSET AND RETURN 0624 * 0625 TYPMS ASC 'File not image type' 0626 DB 0 0627 * 0628 * 0629 SPCER CPI EREOF IF ERROR FROM SPACING IS EOF 0630 JZ IMGER THEN ERROR IN IMAGE FILE FORMAT 0631 JMP ABORT ELSE OTHER PTDOS ERROR 0632 * 0633 * 0634 IMGER LXI D,IMGMS FILE NOT IMAGE FORMAT 0635 CALL ERRMESG PRINT MESSAGE 0636 JMP RSET AND RETURN 0637 * 0638 IMGMS ASC 'Abort: Bad image file --' 0639 ASC ' may be partially scrunched' 0640 DB 0 0641 * 0642 * 0643 LSPER CPI EREOF FIRST SEE IF ERROR IS EOF 0644 JZ IMAER IF SO THEN IMAGE ERROR 0645 JMP ABORT ELSE REAL LIVE PTDOS ERROR 0646 * 0647 IMAER LXI D,IMAMS ERROR IN IMAGE FORMAT DURING LIST 0648 CALL ERRMESG PRINT MESSAGE 0649 JMP RSET AND RETURN 0650 * 0651 IMAMS ASC 'Bad image file' 0652 DB 0 0653 * 0654 * 0655 * 0656 GENER STA ERMCD STORE ERROR NUMBER 0657 JMP DOERROR 0658 * 0659 * 0660 ABORT STA ERMCD STORE ERROR NUMBER 0661 POP H GET RETURN ADDRESS 0662 DCX H MOVE BACK TO COMMAND CODE 0663 DCX H 0664 DCX H 0665 DCX H 0666 MOV A,M GET COMMAND CODE 0667 STA COMCD AND STORE IT 0668 * 0669 DOERROR CALL CLOSE TRY TO CLOSE FILE 0670 CALL ERRST RESET ERROR TRAPS TO OLD VALUES 0671 LXI H,EXTRACT PRINT 'CALLED FROM EXTRACT' 0672 MVI A,2 UTILITY OP 0673 CALL UTIL GO EXPLAIN ERROR AND RETURN TO SYSTEM 0674 DB UXOP 0675 JMP SHOULDNT 0676 COMCD DB -1 COMMAND CODE 0677 ERMCD DB -1 ERROR # 0678 SHOULDNT CALL SYS 0679 DB ABTOP 0680 * 0681 EXTRACT ASC "EXTRACT" 0682 DB 0 0683 * 0684 * 0685 * 0686 ERRMESG LDAX D GET A CHAR FROM THE MESSAGE 0687 ORA A TEST FOR END OF MESSAGE 0688 JZ ENDMESG 0689 CALL CONOUT PRINT IT ON THE CONSOLE 0690 INX D MOVE TO NEXT CHAR 0691 JMP ERRMESG 0692 * 0693 ENDMESG MVI A,CR FOLLOW MESSAGE WITH A CRLF 0694 CALL CONOUT 0695 MVI A,LF 0696 CALL CONOUT 0697 RET 0698 * 0699 * 0700 ********************************************************** 0701 * 0702 * SUBROUTINE OUTPUTS ASCII MESSAGE WHOSE ADDR IS IN DE 0703 * 0704 MESG LDA OUTFN OUTPUT ASCII MESSAGE 0705 LXI B,0FFFFH MESSAGE DELIMITED BY A ZERO BYTE 0706 PUSH H PRESERVE HL 0707 MVI L,0 DELIMETER 0708 CALL SYS 0709 DB DWROP DELIMITED WRITE 0710 CALL ABORT 0711 POP H RESTORE H 0712 RET 0713 * 0714 * SUBROUTINE OUTPUTS 4 HEX DIGITS FOUND IN HL AS ASCII 0715 * 0716 NMOUT MOV B,H GET 1ST 2 DIGITS 0717 CALL HEX2A CONVERT THEM TO ASCII 0718 CALL W2OUT AND PRINT THEM 0719 MOV B,L GET SECOND 2 DIGITS 0720 CALL HEX2A CONVERT TO ASCII 0721 CALL W2OUT OUTPUT THEM 0722 RET 0723 * 0724 * SUBROUTINE CONVERTS 2 HEX DIGITS IN B TO ASCII IN DE 0725 * 0726 HEX2A MVI A,0F0H HIGH DIGIT MASK 0727 ANA B 0728 RRC . PUT DIGIT IN LOW BYTE 0729 RRC 0730 RRC 0731 RRC 0732 CALL ASCII 0733 MOV D,A 0734 MVI A,0FH LOW DIGIT MASK 0735 ANA B 0736 CALL ASCII 0737 MOV E,A DIGITS ARE NOW IN DE 0738 RET 0739 * 0740 * SUBROUTINE CONVERTS A HEX DIGIT IN A TO ASCII 0741 * 0742 ASCII CPI 0AH SEE IF DIGIT IS TO BE LETTER OR NUMBER 0743 JNC LTTR 0744 ORI 30H MAKE NUMBER DIGIT ASCII 0745 RET 0746 LTTR SBI 9 TURN DIGIT INTO ASCII LETTER 0747 ORI 40H 0748 RET 0749 * 0750 * SUBROUTINE OUTPUTS (TO COFILE) 2 ASCII CHARS IN DE 0751 * 0752 W2OUT LDA OUTFN GET FILE # 0753 PUSH H PRESERVE HL 0754 PUSH D PRESERVE DE 0755 MOV B,D 1ST CHAR 0756 CALL WB 0757 CALL GENER 0758 LDA OUTFN 0759 POP D GET BACK OLD DE 0760 MOV B,E 2ND CHAR 0761 CALL WB 0762 CALL GENER 0763 POP H RESTORE HL 0764 RET 0765 * 0766 * 0767 ********************************************************** 0768 * 0769 * STORAGE AREA 0770 * 0771 STACK DS STLEN 0772 BUFF DS BFLEN ALL-PURPOSE BUFFER 0773 HEAD1 DS 4 PRIMARY BLOCK HEADER 0774 HEAD2 DS 4 2ND BLOCK HEADER 0775 OUTFN DS 1 CI OUTPUT FILE # 0776 FILEN DS 1 EXTRACTEABLE FILE # 0777 ERTP0 DS 2 OLD VALUE OF LEVEL 0 ERROR TRAP 0778 ERTP1 DS 2 " LEVEL 1 0779 ERTP2 DS 2 " LEVEL 2 0780 BACKCOUNT DS 2 COUNT TO SPACE BACK TO HEADER 1 0781 SCRNF DB FALSE SCRUNCH FLAG 0782 LISTF DB TRUE LIST FLAG 0783 * 0784 END