NAM HUMBUG / 68K (R)
          OPT PAG
          PAG

********************************************************
* 68K HUMBUG FOR THE PERIPHERAL TECH PT-68K-2
* WITH THE WD1002A-WX1 CONTROLLER
* INCLUDES UBASIC
* COPYRIGHT (C) 1987-90 BY PETER A. STARK
* STAR-K SOFTWARE SYSTEMS CORP.
********************************************************

* MOD 10-26-86 TO INCLUDE WINCHESTER BOOT COMMAND
* MOD 2-5-87 TO FIX ADDRESS OF FORMAT ERROR VECTOR AND
*    PROPERLY SET UP STACK FRAME
* MOD >>A<< 3-27-87 TO SLOW DOWN 1772 STEP RATE, ALLOW
*    LOWER CASE COMMANDS, RETRY WD BOOT IF IT FAILS
* MOD >>B<< 4-15-87 TO CORRECT STACK FRAME ERROR AND ALLOW
*    LOWER CASE HEX LETTERS
* MOD >>C<< 4-19-87 TO ALLOW LOWER CASE ALSO IN RC COMMAND
*    AND ALLOW 19200 BAUD AUTO-SENSE
* MOD >>D<< 5-16-87 TO FIX PROBLEMS WITH PAUSE AND PORT P
* MOD 6-23-87 TO CHANGE MOVEM FOR MULTIPLE REGISTERS
* MOD 6-23-87 FOR PT-68K-2, INCLUDING >>E<< IRQ CHANGES
* MOD 10-1-87 FOR WX1 CONTROLLER AND FAST CGA SCROLL
* MOD 10-4-87 TO INCLUDE IO CONTROL AND FIX CURSOR
* MOD 12-6-87 (VER 1.3) TO FIX IBM MDA REST PROBLEM, AUTOBOOT,
*             AND OPTIONAL BOOT
* MOD 12-13-87 (VER 1.4) TO FIX PROBLEM WITH FLOPPY BOOT
*             (VER 1.5) FOR AUTOBOOT ETC; NOT FINISHED
* MOD 4-16-88 (VER 1.6) FOR 68000/68020, FINISH AUTOBOOT <<F>>
* MOD 4-28-88 (VER 1.7) TO CHANGE KBD CODES 2A 08 09 0A 0B
* MOD 5-28-88 (VER 1.8) TO FIX 68000/68020 STACK PROBLEM
* MOD 2-20-89 (VER 1.9) TO FIX CPUTYP WITH NO RAM AT 0
*     AND ADD BOOT FROM WX1 DRIVE B
* MOD 7-06-90 (VER 2.0) MODIFIED FOR PT68K-4: ADD SETUP COMMAND,
*     LENGTHEN 1772 WAIT LOOP, ADD 37C65
* MOD 9-22-90 (VER 2.1) CORRECTED 37C65 PAL ADDRESSING ERROR,
*     AND FIXED PROBLEM WITH JUST ONE 37C65 DRIVE

* EQUATES

RAM       EQU $FF0000              STATIC RAM IN PT68K-2
ROM       EQU $F80000

* BASIC DATA GOES AT START OF RAM; NOT NEEDED IF RUNNING HUMBUG
* SO THIS AREA CAN BE USED BY OTHER PROGRAMS AS WELL

          ORG.L RAM                BEG OF STATIC RAM

INDEX1    DS.L 1
INDEX3    DS.L 1
INDEX4    DS.L 1
NEXTBA    DS.L 1                   PTR TO NEXT EMPTY
WORKBA    DS.L 1                   PTR TO LOC OF CURRENT LINE
SOURCE    DS.L 1                   PTR TO BEG OF BASIC SOURCE
PACKLN    DS.W 1                   PACKED LINE NUMBER WORKED ON
HIGHLN    DS.W 1                   HIGHEST LINE NUMBER IN SOURCE
BASPNT    DS.L 1
BASLIN    DS.L 1
PUSHTX    DS.L 1
DATPNT    DS.L 1                   PTR TO NEXT DATA ITEM
PRCNT     DS.B 1                   PRINT COUNT
BAFLAG    DS.B 1                   1=BASIC, 0=HUMBUG RUNNING
MEMENB    DS.L 1                   BASIC'S MEMEND
ARRTAB    DS.L 1
KEYWD     DS.L 1
TSIGN     DS.B 1                   TEMPORARY SIGN OF QUOTIENT/PROD
EXP       DS.B 1
SIGDIG    DS.B 1
DECFLG    DS.B 1
TOGGLE    DS.B 1
NCMPR     DS.B 1
TNUMB     DS.B 1
ANUMB     DS.B 1
BNUMB     DS.B 1
LRNINE    DS.B 1
ONLOOP    DS.B 1
NORSGN    DS.B 1
XLONG     DS.L 1
MPYXX     DS.L 1
BASNUM    DS.L 1                   CURRENT LINE BEING INTERPRETED
AESTK     DS.L 1
FORPNT    DS.L 1                   FOR STACK POINTER
FORNOW    DS.L 1
VARPNT    DS.L 1
SBRPNT    DS.L 1                   SUBROUTINE STACK POINTER
RANNUM    DS.B 6
FORTMP    DS.B 6
SBRSTK    DS.L 8                   SUBROUTINE STACK
BUFNXT    DS.L 1
ENDBUF    DS.L 1
BASBUF    DS.B 80
ASTACK    DS.B 18*7                ARITH EXPR STACK
FORSTK    DS.B 128                 FOR-NEXT STACK
          DS.B 256
XSTACK    EQU *                    X (A2) STACK

FILE      EQU *                    BEGINNING OF SOURCE CODE

* HUMBUG DATA AREA GOES AT END OF RAM, EXCEPT FOR HD BUFFER
* AND 37C65 DATA AREA WHICH ARE JUST BEFORE THAT

          ORG.L RAM+$09E8

SBUFFR    DS.B 512                 SECTOR BUFFER

* DRIVE DATA AREA FOR F0 DRIVE. WE STORE THE FOLLOWING IN THE
* HD SECTOR BUFFER AREA TO SAVE ROOM

COMMAND   EQU SBUFFR               COMMAND BUFFER
ST0       EQU SBUFFR+10            RESULTS BUFFER
ST1       EQU SBUFFR+11
ST2       EQU SBUFFR+12
C         EQU SBUFFR+13
H         EQU SBUFFR+14
R         EQU SBUFFR+15
N         EQU SBUFFR+16
PRETRK    EQU SBUFFR+17            PREVIOUS TRACK NUMBER
DRVPTR    EQU SBUFFR+18
DSKSEQ    EQU SBUFFR+22            BITS 1 AND 2 SELECT 1 OF 4 DISK FMTS
DRVDAT    EQU SBUFFR+24            LINE FROM DRIVE TYPE TABLE
MFBIT     EQU SBUFFR+40            MF BIT IN BIT #6
RETRCT    EQU SBUFFR+41            RETRY COUNTER
DRTYPE    EQU SBUFFR+42            DRIVE TYPE 0-5
TRKSEC    EQU SBUFFR+44
NOWLIN    EQU SBUFFR+46            OUTPUT LINE BUFFER DURING IS COMMAND

          ORG.L RAM+$0BE8

FILTOP    EQU *                    TOP OF BASIC DATA SPACE

* THE FOLLOWING DRIVE TABLE SPECIFIES THE CONTROLLER AND DRIVE
* TYPE FOR UP TO SIX FLOPPY DRIVES. CONTROLLER IS EITHER 17 (FOR
* THE 1772) OR 37(FOR THE 37C65). DRIVE TYPE IS 0=NONE,
* 1=360K, 2=720K, 3=1.2 MEG, 4=1.44 MEG, 5=8"
* ONLY ODD BYTES ARE USED SINCE THEY'RE IN THE BATTERY-BACKED RAM;
* THE BYTES IN BETWEEN ARE AVAILABLE; THE EVEN BYTES ARE USED FOR
* OTHER STORAGE

          EVEN
          DS.B 1
FL0C      DS.B 1                   FLOPPY LOGICAL 0 CONTROLLER
          DS.B 1
FL0D      DS.B 1                   FLOPPY LOGICAL 0 DRIVE TYPE
          DS.B 1
FL1C      DS.B 1                   DRIVE 1
          DS.B 1
FL1D      DS.B 1
          DS.B 1
FL2C      DS.B 1                   DRIVE 2
          DS.B 1
FL2D      DS.B 1
          DS.B 1
FL3C      DS.B 1                   DRIVE 3
          DS.B 1
FL3D      DS.B 1
          DS.B 1
FL4C      DS.B 1                   DRIVE 4
TEMP1     DS.B 1
FL4D      DS.B 1
TEMP2     DS.B 1
FL5C      DS.B 1                   DRIVE 5
TEMP3     DS.B 1
FL5D      DS.B 1

PORADM    DS.L 1 CONTROL PORT
PORADP    DS.L 1 PRINTER PORT
DVECTR    DS.L 1 USER PORT X VECTOR
PORECH    DS.B 1 ECHO IS <> 0
HARDWE    DS.B 1 TELLS US WHAT HARDWARE IS INSTALLED
REGERS    DS.L 15 A AND D REGISTER STORAGE
REGA7     DS.L 1 REGISTER A7
USERPC    DS.L 1 USER PROGRAM COUNTER
USERSR    DS.W 1 USER STATUS REGISTER
SYSTSR    DS.W 1 SYSTEM SR DURING TRACING/BREAKPOINTS >>E<<
USERSP    DS.L 1 USER STACK POINTER
SYSTSP    DS.L 1 SYSTEM STACK POINTER
TRAVEC    DS.L 1 TRACE VECTOR TEMPORARY
BKTAB     DS.L 6 BP TABLE (LOC1, OP1,...
STATSI    DS.B 1 INPUT STATUS: 0,0,0,0,0,0,IBMKB,SERKB
STATSO    DS.B 1 OUTPUT STATUS: P0,P1,MON,COL,FAST,X,PD,PAUSE
CATTR     DS.B 1 COLOR ATTRIBUTE (NORMALLY 1E)
MATTR     DS.B 1 MONOCHROME ATTRIBUTE (NORMALLY 07)
CCURV     DS.B 1 COLOR CURSOR VERT POS
CCURH     DS.B 1 COLOR CURSOR HORIZ POS
MCURV     DS.B 1 MONOCHROME CURSOR VERT POS
MCURH     DS.B 1 MONOCHROME CURSOR HORIZ POS
MCURSZ    DS.B 1 MONOCHROME CURSOR SIZE
CCURSZ    DS.B 1 COLOR CURSOR SIZE
PAUCTR    DS.B 1 PAUSE FEATURE LINE COUNTER
FRSTIM    DS.B 1 =1 WHEN VERY FIRST INITIALIZATION
BEGA      DS.L 1 BEGINNING ADDRESS
BOODRI    EQU BEGA  BOOT DRIVE A=0 B=20
ENDA      DS.L 1 ENDING ADDRESS
SP        DS.L 1 STACK PTR
FINDNO    DS.B 1 NUMBER OF BYTES IN FI
WHAT      DS.B 5 WHAT TO FIND IN FI
NEWLOC    DS.L 1 USED IN MO
KBS       DS.B 1 KEYBOARD STATUS BYTE
KBA       DS.B 1 KEYBOARD ACTIVITY BYTE
INQFLG    DS.B 1 01=CHAR READY IN INQCHR, ELSE 00
INQCHR    DS.B 1 CHAR RCV'D FROM CLONE KEYBOARD
T15VEC    DS.L 1 TRAP 15 VECTOR
BERVEC    DS.L 1 BUS ERROR VECTOR
ICTCHR    DS.W 1 ICNTRL KBD CHARACTER
ICTFLG    DS.B 1 ICNGTL KBD FLAG
CPUTYP    DS.B 1 CPU TYPE 00=68000, 01=10, 02=20 >>F<<
ABFLAG    DS.L 1 AUTOBOOT FLAG
S1BAUD    DS.B 1 SERIAL 1 BAUD RATE >>F<<
          DS.B 1 UNUSED

* THE FOLLOWING USED IN HARD BOOT ONLY; IT SLIGHTLY OVERLAPS
* SUPERVISOR STACK, BUT NO PROBLEM AS BOOT IS ONLY RUN WHILE
* USING HUMBUG STACK

* THE FOLLOWING MUST STAY TOGETHER IN ORDER
WX1CYL    DS.W 1                   WX1 CYLINDER NUMBER - HD ONLY
WX1HD     DS.B 1                   HEAD NUMBER
WX1SEC    DS.B 1                   LOGICAL SECTOR NUMBER
          EVEN
OURWIN    DS.B 16
DBUFFR    DS.B 256                 DIRECTORY BUFFER

SSTACK    EQU RAM+$0E00            SUPERVISOR STACK
USTACK    EQU RAM+$0F00            USER STACK
BSTACK    EQU USTACK               BASIC'S STACK
MSTACK    EQU RAM+$0FE0            HUMBUG STACK

* PROGRAM BEGINNING

          ORG.L ROM

********************************************************
* VECTORS TO GO AT THE BEGINNING OF MEMORY
********************************************************

VECTRS DC.L MSTACK-8             0 INITIAL SUPERVISOR STACK POINTER >>F<<
       DC.L HSTART               4 RESET VECTOR
       DC.L PRBERR               8 BUS ERROR
       DC.L ADDERR               C ADDRESS ERROR
       DC.L ILLINS              10 ILLEGAL INSTRUCTION
       DC.L ZERDIV              14 ZERO DIVIDE
       DC.L CHKINS              18 CHK INSTRUCTION
       DC.L TRAPVI              1C TRAPV INSTR
       DC.L PRIVIO              20 PRIVILEGE VIOLATION
       DC.L TRARET              24 TRACE
       DC.L LN1010              28 LINE 1010
       DC.L LN1111              2C LINE 1111
       DC.L UNASSI              30 UNASSIGNED
       DC.L UNASSI              34 "
       DC.L FORERR              38 FORMAT ERROR ON 68010/20
       DC.L UNASSI              3C UNASSIGNED
       DC.L UNASSI              40 "
       DC.L UNASSI              44 "
       DC.L UNASSI              48 "
       DC.L UNASSI              4C "
       DC.L UNASSI              50 "
       DC.L UNASSI                 "
       DC.L UNASSI                 "
       DC.L UNASSI                 "
       DC.L SPURIO              60 SPURIOUS INTERRUPT
       DC.L LVL1IA                 LEVEL 1 INTERRUPT AUTOVECTOR
       DC.L LVL2IA                 LEVEL 2 "
       DC.L LVL3IA                 LEVEL 3 "
       DC.L LVL4IA              70 LEVEL 4 "
       DC.L KBISS                  LEVEL 5 " IS CLONE KBD
       DC.L LVL6IA                 LEVEL 6 "
       DC.L LVL7IA                 LEVEL 7 "
       DC.L TRAP0V              80 TRAP 0
       DC.L TRAP1V                 TRAP 1
       DC.L TRAP2V                 TRAP 2
       DC.L TRAP3V                 TRAP 3
       DC.L TRAP4V              90 TRAP 4
       DC.L TRAP5V                 TRAP 5
       DC.L TRAP6V                 TRAP 6
       DC.L TRAP7V                 TRAP 7
       DC.L TRAP8V              A0 TRAP 8
       DC.L TRAP9V                 TRAP 9
       DC.L TRAPAV                 TRAP 10
       DC.L TRAPBV                 TRAP 11
       DC.L TRAPCV              B0 TRAP 12
       DC.L TRAPDV                 TRAP 13
       DC.L TRAPEV                 TRAP 14
       DC.L TRAPFV                 TRAP 15

*******************************************************
* ENTRY POINT JUMP TABLE
*******************************************************
HSTART    JMP.L COLDST
          JMP.L WARMST
          JMP.L INEEE              MASK PARITY, ECHO, CHK ^S
          JMP.L INCH7              MASK PARITY, NO ECHO
          JMP.L INCH8              KEEP PARITY, NO ECHO
          JMP.L INCHEK             CHECK CURRENT INPUT STATUS
          JMP.L OUTCHX             WITHOUT CHECK FOR ^S
          JMP.L OUTEEE             WITH CHECK FOR ^S
          JMP.L OUTCHM             MAIN W/O CHECK
          JMP.L OUTCHP             PRINTER W/O CHECK
          JMP.L OUTCHB             B&W W/O CHECK
          JMP.L PSTRNG             USES OUTEEE
          JMP.L OUT4HS
          JMP.L OUT8HS
          JMP.L OUTCHC             COLOR W/O CHECK
          JMP.L ICTRNL             DO I CONTROL
          JMP.L ICCHEK             CHECK ICNTRL STATUS
VECTEN EQU *
INZFLG    EQU VECTEN-ROM           WILL BE IN RAM JUST ABOVE

*******************************************************
* INITIAL COLD START ROUTINE.
*******************************************************

* FIRST DO SOME VERY BASIC INITIALIZATION

COLDST    CLR.B BAFLAG             BASIC IS NOT RUNNING
          CLR.B FRSTIM             ASSUME ZERO FLAG
          MOVEM.L D0-D7/A0-A6,REGERS PUSH ALL REGISTERS

* FIRST CHECK WHETHER THIS IS INITIAL POWER UP
          MOVE.L INZFLG,D0         IS IT INITIALIZED?
          CMP.L #$AA5555AA,D0
          BEQ.S COLD1              NOT THE VERY FIRST TIME
          MOVE.B #1,FRSTIM         YES, THIS IS VERY FIRST TIME

* MOVE VECTORS FROM ROM INTO RAM

COLD1     LEA VECTRS,A0            POINT TO VECTORS
          MOVE.L #0,A1             WHERE TO PUT THEM
          LEA VECTEN,A2            POINT PAST ALL VECTORS
VECMOV    MOVE.W (A0)+,(A1)+       MOVE ONE WORD AT A TIME
          CMP.L A0,A2              DONE?
          BNE.S VECMOV             NO, DO MORE

* NOW SET CPU TYPE FLAG >>F<<
          MOVE.L #$D7123456,D7     SET SOME FLAGS SO WE KNOW WHERE WE ARE
          MOVE.L #$A1987654,A1
          MOVE.L #$A2A2A2A2,A2
          MOVE.L #$A3A3A3A3,A3
          MOVE.L #$A4A4A4A4,A4
          CLR.B CPUTYP             START ASSUMING 68000
          DC.L $4E7A0001           MOVEC SFC TO D0
          MOVE.B #$01,CPUTYP       IF OK, TRY 68010
          DC.L $4E7A0002           MOVEC CACR TO D0
          MOVE.B #$02,CPUTYP       IF OK, IS 68020
CPUTRE    MOVE.L #MSTACK-6,A7      RESET STACK
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S CPUT00             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      AND ALSO STACK

* INITIALIZE PORTS, PARITY MEMORY, SET USER STACK POINTER AND
* USER REGISTERS

CPUT00    LEA WARMST(PC),A0
          MOVE.L A0,T15VEC         INIT TRAP 15 VECTOR
          LEA BUSERR(PC),A0
          MOVE.L A0,BERVEC         INIT BUS ERROR VECTOR
          BSR.L INIPOR             INITIALIZE PORTS
          BSR.L MEMRD              READ ALL OF MEMORY
          MOVE.L #USTACK-4,A0
          MOVE.L A0,USP            INITIALIZE USER STACK POINTER
          TST.B FRSTIM             CHECK WHETHER 1ST TIME
          BEQ.S RESET              NO
          MOVE.L #REGERS,A0        POINT TO REGISTER STORAGE
          MOVE.B #8,D1             COUNTER
          MOVE.L #$D0,D0
DLOOP     MOVE.L D0,(A0)+          SET DATA REGISTERS
          ADD.B #1,D0
          SUB.B #1,D1              DECR COUNTER
          BNE.S DLOOP
          MOVE.B #7,D1             COUNTER AGAIN
          MOVE.L #$A0,D0
ALOOP     MOVE.L D0,(A0)+          SET ADDRESS REGISTERS
          ADD.B #1,D0
          SUB.B #1,D1              DECR COUNTER
          BNE.S ALOOP
          MOVE.L #USTACK-4,(A0)+   A7=USER STACK POINTER
          MOVE.L #WARMST,(A0)+     PS=DEFAULT TO WARMSTART
          MOVE.W #$0000,(A0)+      SR=USER STATUS REGISTER >>E<<
          MOVE.L #USTACK-4,(A0)+   US=USER STACK POINTER
          MOVE.L #USTACK-4,(A0)    SS=SYST STACK POINTER

* ERASE BREAKPOINT TABLE

RESTRT    LEA BKTAB,A0             NOW ERASE BRK TABLE
          MOVE.B #$FF,D0           FILL WITH FF'S
          MOVE.B #24,D1            24 BYTES IN TABLE
BKERAS    MOVE.B D0,(A0)+          ERASE BREAKPOINT TABLE
          SUB.B #01,D1
          BNE.S BKERAS             REPEAT IF NOT FINISHED

* AND FINALLY JUST RESTART ALL IN SUPERVISOR MODE

RESET     MOVE.L #RTSAD,DVECTR     POINT D VECTOR TO AN RTS
          TRAP #15                 GO TO SUPERVISOR AND WARMST
RTSAD     RTS

*******************************************************
* WARMSTART INITIALIZATION
*******************************************************

WARMST    CLR.B BAFLAG             BASIC IS NOT RUNNING
          MOVE.L #MSTACK-6,A7      RESET STACK
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S WARM00             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      SET STACK PTR TO MON AREA >>F<<
WARM00    EOR.W #$1000,SR          FLIP TO OTHER SSR
          MOVE.L #MSTACK-6,A7      OTHER STACK TOO
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S WARM01             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      SET OTHER STACK POINTER TOO >>F<<
WARM01    EOR.W #$1000,SR          RETURN TO ORIG SSR
          BSR.L PARON              TURN ON PARITY MEMORY
          MOVE.L T15VEC,A0         TEMP SAVE TRAP 15 VECTOR
          LEA WARMS1(PC),A1
          MOVE.L A1,T15VEC         PUT IN NEW VECTOR
          TRAP #15                 FORCE SUPERVISOR STATE
WARMS1    AND.W #$F8FF,SR           ENABLE INTERRUPTS >>E<<
          MOVE.W SR,SYSTSR         AND SAVE IT
          MOVE.L A0,T15VEC         RESTORE TRAP 15 VECTOR
          MOVE.L #MSTACK-6,A7      RESET STACK
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S WARM02             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      SET STACK PTR TO MON AREA >>F<<
WARM02    MOVE.B #$0F,PAUCTR       INIT PAUSE LINE COUNTER
          MOVE.B #$FF,PORECH       CTRL PORT ECHO ON
          CLR.L D0
          MOVE.L #$AA5555AA,INZFLG SET INITIALIZED FLAG
          BSR.L CRLF

* CHECK WHETHER AUTOBOOT IS REQUESTED
          MOVE.L ABFLAG,D7         GET AUTOBOOT FLAG
          CMP.L #$41554244,D7      FD?
          BEQ.L FLBOOT
          CMP.L #$41554241,D7      WA?
          BEQ.L WABOOT
          CMP.L #$41554242,D7      WB?
          BEQ.L WBBOOT
          CMP.L #$41554248,D7      WH?
          BEQ.L WHBOOT
          CMP.L #$41554231,D7      X1?
          BEQ.L X1BOOT

          MOVE.L #H68MSG,A4
          BSR.L PDATA              PRINT SIGN-ON

*******************************************************
* NXTCMD - INITIALIZATION COMPLETE. READY FOR COMMAND
*******************************************************

NXTCMD    MOVE.L #MSTACK-6,A7      RESET STACK
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S NXTCM1             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      RESET STACK PTR TO MON AREA >>F<<
NXTCM1    JSR CRLF                 PRINT CR/LF
          MOVE.B #'*',D4           PRINT PROMPT
          JSR OUTEEE
          JSR INEEE                GET FIRST COMMAND CHARACTER
          LSL.W #8,D5              MOVE INTO SECOND BYTE
          JSR INEEE                GET SECOND COMMAND CHARACTER
          AND.W #$DFDF,D5          CVT TO UPPER CASE >>A<<
          JSR OUTS

* CHECK COMMAND

COMAND    LEA COMTAB-6,A0          GET ADDR OF COMMAND TABLE-6
          LEA TABEND,A1            AND END OF TABLE
LOOKUP    ADD.L #6,A0              POINT TO NEXT ENTRY
          CMP.L A0,A1              END OF TABLE?
          BEQ.S COMEND             YES
          CMP.W (A0),D5            CHECK THE COMMAND AGAINST TABLE
          BNE.S LOOKUP             WRONG
          MOVE.L 2(A0),A0          GET ADDRESS IF OK
          JSR OUTS                 PRINT A SPACE
          JSR (A0)                 JUMP TO APPROP COMMAND ROUTINE
          BRA.S NXTCMD
COMEND    MOVE.B #$3F,D4           PRINT ? IF NOT FOUND
          BSR.L OUTEEE
          BRA.S NXTCMD

*******************************************************
* COMMAND TABLE
*******************************************************

COMTAB    FCC 'AD' FORMATTED ASCII DUMP
          DC.L ASCDMP
          FCC 'AI' ASCII INPUT
          DC.L ASCIN
          FCC 'AO' ASCII OUT
          DC.L ASCOUT
          FCC 'BA' BASIC
          DC.L UBASIC
          FCC 'BP' PRINT BP LOCATIONS
          DC.L BPRINT
          FCC 'BR' SET/RESET BPS
          DC.L BREAK
          FCC 'CO' CONTINUE AFTER BP
          DC.L CONT
          FCC 'CS' FOUR-BYTE CHECKSUM
          DC.L SUM
          FCC 'FD' REGULAR DISK BOOT
          DC.L FLBOOT
          FCC 'FI' FIND BYTES COMMAND
          DC.L FIND
          FCC 'FM' FILL MEMORY
          DC.L FILL
          FCC 'HA' COMBINED HEX AND ASCII DUMP
          DC.L HEXASC
          FCC 'HD' HEX DUMP ROUTINE
          DC.L HEXDMP
          FCC 'HE' HELP
          DC.L HELP
          FCC 'IS' SETUP FDC AND DRIVE DATA
          DC.L ISETUP
          FCC 'JS' JUMP TO SYSTEM PROGRAM
          DC.L JUMPS
          FCC 'JU' JUMP TO USER PROGRAM
          DC.L JUMPU
          FCC 'LO' LOAD S1S9 FORMAT TAPE
          DC.L LOAD
          FCC 'MC' MEMORY COMPARE
          DC.L COMPAR
          FCC 'ME' MEMORY EXAMINE
          DC.L CHANGE
          FCC 'MO' MOVE MEMORY CONTENTS
          DC.L MOVE
          FCC 'MS' MEMORY STORE W/O READING
          DC.L MSTORE
          FCC 'MT' MEMORY TEST
          DC.L MTEST
          FCC 'RC' REGISTER CHANGE
          DC.L REGCHG
          FCC 'RD' RETURN TO DOS
          DC.L RETDOS
          FCC 'RE' REGISTER EXAMINE
          DC.L REGIST
          FCC 'SS' SINGLE-STEP
          DC.L STEP
          FCC 'ST' START SINGLE-STEPPING
          DC.L STRTSS
          FCC 'WA' WINCHESTER WX1 DRIVE A
          DC.L WABOOT
          FCC 'WB' WINCHESTER WX1 DRIVE B
          DC.L WBBOOT
          FCC 'WH' WINCHESTER HDO CONTROLLER
          DC.L WHBOOT
          DC.W $5811 OPTIONAL DISK 1
          DC.L X1BOOT
          DC.W $0101 !!=FORCE POWERUP INITIALIZATION
          DC.L RESTRT
TABEND    DC.W 0 MARKS END OF TABLE

*******************************************************
* 'MS' - MEMORY STORE WITHOUT READING
*******************************************************

MSTORE    LEA ADMSG,A4
          JSR PDATA                PRINT "ADDRESS: "
          BSR.L BADDR              GET ADDRESS
          MOVE.L D5,A0
          SUB.L #1,A0              BACKUP 1
          MOVE.L BERVEC,A2         TEMP SAVE BUS ERROR VECTOR
          MOVE.L #MSBERR,BERVEC    REPLACE WITH NEW VECTOR
MSTOR1    ADD.L #1,A0              THEN GO FORWARD
MSTOR2    MOVE.L A0,D4             PREPARE TO PRINT
          JSR CRLF
          JSR OUT8HS               PRINT ADDRESS
MSTOR3    JSR INEEE                INPUT COMMAND CHAR
          CMP.B #$0D,D5
          BEQ.S MSEXIT             QUIT ON CR
          CMP.B #$5E,D5            UP ARROW?
          BNE.S MSTOR4             NO
          SUB.L #1,A0              YES, STEP BACK
          BRA.S MSTOR2             AND REPEAT
MSTOR4    JSR CVTHEX               PROCESS THE DIGIT
          BEQ.S MSTOR1             ON SPACE GO TO NEXT
          MOVE.B D5,D0             SAVE FIRST DIGIT
          LSL.B #4,D0              IN LEFT NYBBLE
          BSR.L IN1HEX             GET SECOND DIGIT
          BEQ.S MSTOR1             ON SPACE GO TO NEXT
          ADD.B D5,D0              COMBINE THE TWO DIGITS
          MOVE.B D0,(A0)           STORE NEW NUMBER
          BRA.S MSTOR1             AND THEN DO THE NEXT
MSBERR    LEA MEBMSG(PC),A4
          JSR PDATA                PRINT "BUSS ERROR"
          BRA.S MSTOR1
MSEXIT    MOVE.L A2,BERVEC         RESTORE BUS ERROR VECTOR
          JMP NXTCMD               THEN DO NEXT COMMAND

*******************************************************
* 'ME' - MEMORY EXAMINE AND CHANGE FUNCTION
*******************************************************

CHANGE    LEA ADMSG,A4
          JSR PDATA                PRINT "ADDRESS: "
          BSR.L BADDR              GET ADDRESS
          MOVE.L D5,A0
          SUB.L #1,A0              BACKUP 1
CHANG0    MOVE.L BERVEC,A2         TEMP SAVE BUS ERROR VECTOR
          MOVE.L #MEBERR,BERVEC    REPLACE WITH NEW VECTOR
CHANG1    ADD.L #1,A0              THEN GO FORWARD
CHANG2    MOVE.L A0,D4             PREPARE TO PRINT
          JSR CRLF
          JSR OUT8HS               PRINT ADDRESS
          MOVE.B (A0),D4           GET THE OLD DATA
          JSR OUT2HS               PRINT IT
          JSR OUTS                 SPACE
CHANG3    JSR INEEE                INPUT COMMAND CHAR
          CMP.B #$0D,D5
          BEQ.S MEEXIT             QUIT ON CR
          CMP.B #$5E,D5            UP ARROW?
          BNE.S CHANG4             NO
          SUB.L #1,A0              YES, STEP BACK
          BRA.S CHANG2             AND REPEAT
CHANG4    JSR CVTHEX               PROCESS THE DIGIT
          BEQ.S CHANG1             ON SPACE GO TO NEXT
          MOVE.B D5,D0             SAVE FIRST DIGIT
          LSL.B #4,D0              IN LEFT NYBBLE
          BSR.S IN1HEX             GET SECOND DIGIT
          BEQ.S CHANG1             ON SPACE GO TO NEXT
          ADD.B D5,D0              COMBINE THE TWO DIGITS
          MOVE.B D0,(A0)           STORE NEW NUMBER
          CMP.B (A0),D0            CMPA -1,X CHECK IT
          BEQ.S CHANG1             STORED OK, DO NEXT
          LEA NOCMSG(PC),A4        ERROR IF NOT STORED OK
          JSR PDATA                PRINT "DID NOT STORE"
          BRA.S CHANG2             DO SAME ONE AGAIN
MEBERR    LEA MEBMSG(PC),A4
          JSR PDATA                PRINT "BUSS ERROR"
MEEXIT    MOVE.L A2,BERVEC         RESTORE BUS ERROR VECTOR
          JMP NXTCMD               THEN DO NEXT COMMAND

*******************************************************
* VARIOUS ROUTINES NEEDED TO SUPPORT ABOVE ETC.
*******************************************************

* BUILD ADDRESS. BUILDS AN ADDRESS IN D5; UNLIMITED NUMBER OF
* DIGITS ACCEPTED UNTIL A SPACE IS ENTERED.
* ANY OTHER NON-HEX CHARACTER ABORTS AND RETURNS TO NXTCMD

BADDR     CLR.L D6
BADDR1    BSR.S IN1HEX             GET 1 HEX DIGIT
          BEQ.S BADEXI             EXIT IF A SPACE
          LSL.L #4,D6              MOVE PREVIOUS NUMBER LEFT
          ADD.B D5,D6              COMBINE WITH LATEST DIGIT
          BRA.S BADDR1             AND REPEAT
BADEXI    MOVE.L D6,D5             ANSWER INTO D5
          RTS

* INPUT BYTE (TWO HEX DIGITS)
* ANY NON-HEX CHARACTER EXCEPT SPACE ABORTS AND RETURNS TO COMEND

BYTE      BSR.S IN1HEX             GET ONE HEX DIGIT
          BEQ.S BYTE               SKIP SPACE
BYTE1     LSL.B #4,D5
          MOVE.B D5,D6             TEMP SAVE IT
BYTE2     BSR.S IN1HEX             GET SECOND HEX DIGIT
          BEQ.S BYTE2              SKIP SPACE
          ADD.B D6,D5              COMBINE
          ADD.B D5,D1              ADD TO CHECKSUM (IN LOAD S1)
          RTS

* INPUT 1 HEX DIGIT
* ANY NON-HEX CHARACTER ABORTS AND RETURNS TO COMEND

IN1HEX    BSR.L INEEE
CVTHEX    CMP.B #$20,D5            IS IT A SPACE?
          BEQ.S IHEXIT             YES, EXIT WITH EQUALS
          SUB.B #$30,D5            CVT FROM ASCII
          CMP.B #$A,D5             CHECK IF 0-9
          BCS.S IHEXIT             YES, EXIT
          AND.B #$DF,D5            CVT TO UPPER >>B<<
          CMP.B #$11,D5            CHECK IF <A
          BCS.L COMEND             YES, ERROR
          SUB.B #7,D5              TAKE A CHANCE THAT IT'S A-F
          CMP.B #$10,D5            CHECK IF IT'S VALID
          BCC.L COMEND             ERROR IF 10 OR ABOVE
IHEXIT    RTS                      RTS

* OUTHL AND R - OUTPUT ONE HEX DIGIT

OUTHL     LSR.B #4,D4              OUTPUT LEFT DIGIT ENTRY
OUTHR     AND.B #$F,D4             OUTPUT HEX RIGHT DIGIT ENTRY
          ADD.B #$30,D4
          CMP.B #$39,D4            0-9?
          BLS.L OUTEEE             YES, OUTPUT IT
          ADD.B #$7,D4             ELSE CONVERT FOR A - F
          BRA.L OUTEEE             AND OUTPUT

* OUT2, 4, AND 8 HEX ROUTINES

OUT2H     MOVE.B D4,D5             SAVE BYTE IN D5
          BSR.S OUTHL              OUTPUT LEFT HEX CHAR
          MOVE.B D5,D4             RESTORE BYTE
          BRA.S OUTHR              OUTPUT RIGHT HEX CHAR

OUT8HS    SWAP D4
          BSR.S OUT4H              LEFT 4 DIGITS FIRST
          SWAP D4
          BSR.S OUT4H              RIGHT 4 DIGITS NEXT
          BRA.S OUTS               FOLLOW WITH SPACE

OUT4H     MOVE.W D4,D6             SAVE WORD IN D6
          LSR.W #8,D4
          BSR.S OUT2H              LEFT BYTE FIRST
          MOVE.W D6,D4             RESTORE WORD
          BRA.S OUT2H              RIGHT BYTE NEXT
          RTS

OUT4HS    BSR.S OUT4H
          BRA.S OUTS

OUT2HS    BSR.S OUT2H
OUTS      MOVE.B #$20,D4           SPACE
          BSR.L OUTEEE
          RTS                      AND RETURN

*******************************************************
* JUMP TO USER PROGRAM COMMAND; PUT RETURN ADDRESS ON HIS STACK
* SO HE'LL RETURN TO WARM START IF HE DOES RTS
*******************************************************

JUMPU     LEA STMSG,A4
          JSR PDATA                PRINT "FROM ADDRESS"
* USE -8 IN FOLLOWING INSTRUCTION FOR 68010/68020
          MOVE.L #MSTACK-6,A7      RESET STACK >>F<<
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S JUMP00             -6 IF 68000, -8 IF 68010/20
          MOVE.L #MSTACK-8,A7      RESET STACK >>F<<
JUMP00    BSR.L BADDR              GET ADDRESS TO JUMP TO
          BTST #0,D5
          BNE.L ODDADD             IF NOT EVEN
          MOVE.L D5,2(A7)          PUT ON STACK
          BEQ.L COMEND             NG IF ZERO
          MOVE.W #$0000,(A7)       SET SR >>E<<
* INCLUDE FOLLOWING INSTRUCTION FOR 68010/68020
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S JUMP01             CLEAR IF 68010/20, ELSE SKIP
          CLR.W 6(A7)              CLEAR 68010/20 FORMAT CODE >>F<<
JUMP01    MOVE.L #USTACK-4,A6
          MOVE.L A6,USP            SET USER STACK REGISTER
          LEA WARMST(PC),A6        POINT TO WARMSTART
          MOVE.L A6,USTACK-4       PUT IT ON USER STACK
          MOVEM.L REGERS,D0-D7/A0-A6 RESET A&D REGISTERS
          RTE                      GO TO USER


*******************************************************
* JUMP TO SYSTEM PROGRAM COMMAND; PUT RETURN ADDRESS ON STACK
* SO HE'LL RETURN TO WARM START IF HE DOES RTS
*******************************************************

JUMPS     LEA STMSG,A4
          JSR PDATA                PRINT "FROM ADDRESS"
          BSR.L BADDR              GET ADDRESS TO JUMP TO
          BTST #0,D5
          BNE.L ODDADD             IF NOT EVEN
          MOVE.L #SSTACK,A7        INITIALIZE STACK TO SYST AREA
          LEA WARMST,A0
          MOVE.L A0,-(A7)          WARMST ADDR ON STACK
          MOVE.L D5,-(A7)          AND GO TO ADDRESS ON STACK
          BEQ.L COMEND             NG IF ZERO
          MOVEM.L REGERS,D0-D7/A0-A6 RESET A&D REGISTERS
          RTS                      GO TO SYST PROGRAM

*******************************************************
* PSTRNG AND PCRLF
*******************************************************

* CRLF - PRINT CR/LF
CRLF      MOVEM.L A4-A4,-(A7)
          MOVE.L #CRLFST,A4        POINT TO CRLF STRING
          BSR.S PDATA              PRINT AND RETURN
          MOVEM.L (A7)+,A4-A4
          RTS
CRLFST    FCB $0D,$0A,4

* PSTRNG - CRLF FOLLOWED BY PDATA
PSTRNG    BSR.S CRLF

* PDATA - PRINT DATA STRING
PDATA     MOVEM.L D4-D4,-(A7)
PDATA1    MOVE.B (A4)+,D4          GET CHARACTER
          CMP.B #4,D4              END?
          BEQ.S PDEXIT
          BSR.L OUTEEE
          BRA.S PDATA1             AND REPEAT
PDEXIT    MOVEM.L (A7)+,D4-D4
          RTS

*******************************************************
* CONSOLE I/O ROUTINES
*******************************************************

* INEEE - CHARACTER INPUT ROUTINE
INEEE     EQU *
INRPT     BSR.L INCH7              GET INPUT CHARACTER
          CMP.B #$13,D5            IS IT CONTROL-S?
          BEQ.S GOTCS              YES
          TST.B PORECH             ECHO?
          BEQ.S NOECHO             NO
          MOVEM.L D4-D4,-(A7)      YES
          MOVE.B D5,D4
          BSR.L OUTEEE
          MOVEM.L (A7)+,D4-D4
NOECHO    RTS

* CONTROL-S DETECTED. GET AND INTERPRET COMMAND
GOTCS     BSR.S GETCMD             DO COMMAND
          BRA.S INRPT

* SUBR TO GET AND DO COMMAND
GETCMD    MOVE.B D4,D5             SAVE CHARACTER BEING OUTPUT
          MOVE.B #$07,D4
          JSR OUTCHX               ECHO BELL TO CURRENT PORT
          MOVE.B D5,D4             RESTORE CHARACTER
          BSR.L INCH7              GET SECOND CHARACTER OF CMD
          CMP.B #$60,D5            CHECK FOR LOWER CASE
          BCS.S NOTLCS             NOT LOWER
          SUB.B #$20,D5            ELSE CHANGE TO UPPER CASE
NOTLCS    CMP.B #'P',D5            P = PRINTER COMMAND?
          BNE.S NOTP               NO
          EOR.B #$80,STATSO        FLIP PRINTER BIT
          RTS                      AND RETURN
NOTP      CMP.B #'R',D5            R = RS-232C COMMAND?
          BNE.S NOTR               NO
          EOR.B #$40,STATSO        FLIP PORT R
          RTS
NOTR      CMP.B #'C',D5            C = COLOR BOARD?
          BNE.S NOTC               NO
          EOR.B #$10,STATSO        FLIP CGA PORT
          RTS
NOTC      CMP.B #'B',D5            B = MONOCHROME?
          BNE.S NOTB               NO
          EOR.B #$20,STATSO        FLIP MONOCHROME
          RTS
NOTB      CMP.B #'X',D5            X - PORT X COMMAND?
          BNE.S NOTX               NO
          EOR.B #$02,STATSO        FLIP PORT X
          RTS
NOTX      CMP.B #'F',D5            F - FAST CGA SCROLL?
          BNE.S NOTF               NO
          EOR.B #$08,STATSO        FLIP FAST FLAG
          RTS
NOTF      CMP.B #'W',D5            W - PAUSE COMMAND?
          BNE.S NOTW               NO
          EOR.B #$01,STATSO        FLIP PAUSE
          MOVE.B #$F,PAUCTR        RESET PAUSE LINE CNTR
          RTS
NOTW      CMP.B #$0D,D5            CR COMMAND TO QUIT?
          BEQ.S HBQUIT             YES, QUIT
          CMP.B #$18,D5            ^X COMMAND TO QUIT?
          BEQ.S HBQUIT             YES, QUIT
NOTCR     RTS                      RETURN W/O DOING ANYTHING

HBQUIT    TST.B BAFLAG             IS BASIC RUNNING?
          BEQ.L WARMST             NO, SO JUST QUIT
          BRA.L BASOFT             YES, SO RETURN TO BASIC

* ACTUAL CONTROL PORT INPUT ROUTINES
INCH7     BSR.L INCH8              GET 7-BIT CHARACTER
          AND.B #$7F,D5            MASK OUT PARITY
          RTS

* OUTEEE - CHARACTER OUTPUT ROUTINE HAS TWO ENTRY POINTS:
* OUTEEE IS USED INTERNALLY, AND CHECKS FOR CONTROL-S, WHILE
* OUTCHX IS USED BY SK*DOS AND DOES NOT

OUTCHX    MOVEM.L A6-A6,-(A7)      ETNRY W/O ^S CHECK
          BRA.S NOTEST

OUTEEE    MOVEM.L A6-A6,-(A7)      ENTRY WITH ^S CHECK
OUTEE1    BSR.L INCHEK             CHECK FOR INPUT CHARACTER
          BEQ.S NOTEST             NO CHARACTER
          BSR.S INCH7              GET CHARACTER
          CMP.B #$13,D5            IS IT CONTROL-S?
          BNE.S NOTEST             NO
          BSR.L GETCMD             YES; GET COMMAND AND DO IT
* CHECK FOR PAUSE
NOTEST    BTST #0,STATSO           PAUSE ON?
          BEQ.S NOPAUS             NO
          CMP.B #$0D,D4            CR? >>D<<
          BNE.S NOPAUS             ONLY PAUSE AT END OF LINE
          SUB.B #1,PAUCTR          DECR PAUSE LINE CNTR
          BNE.S NOPAUS             AND CHECK IT
* LINE DELETED HERE BY >>D<<
          MOVE.B #$0F,PAUCTR       MUST PAUSE. RESET CNTR
          BSR.S INCH7              WAIT FOR RESTART CHAR
          CMP.B #$0D,D5            QUIT IF IT'S A CR
          BEQ.L NXTCMD
NOPAUS    TST.B STATSO             PRINT ON PORT P?
          BPL.S NOTPT0             NO
          BSR.L OUTCHP             YES
NOTPT0    BTST #6,STATSO           PRINT ON SER PORT?
          BEQ.S NOTPTR             NO
          BSR.L OUTCHM             YES
NOTPTR    BTST #5,STATSO           PRINT ON B&W BOARD?
          BEQ.S NOTPTB             NO
          BSR.L OUTCHB             YES
NOTPTB    BTST #4,STATSO           PRINT ON COLOR BOARD?
          BEQ.S NOTPTC             NO
          BSR.L OUTCHC             YES
NOTPTC    BTST #1,STATSO           OUTPUT ON X?
          BEQ.S NOTPTX             NO
          MOVEM.L D4-D4,-(A7)         SAVE CHAR
          MOVE.L DVECTR,A6
          JSR (A6)                 YES
          MOVEM.L (A7)+,D4-D4      RESTORE CHAR
NOTPTX    MOVEM.L (A7)+,A6-A6
          RTS

* ALTERNATE OUTEEE ENTRY W/O CTRL-S TEST

OUTNOT    MOVEM.L A6-A6,-(A7)      SAVE REGISTER
          BRA.L NOTEST

*******************************************************
* 'RC' - REGISTER CHANGE
*******************************************************

REGCHG    MOVE.L #WHMESG,A4
          JSR PDATA                ASK WHICH REGISTER
          JSR INEEE                GET FIRST LETTER
          MOVE.B D5,D0             MOVE INTO D0
          LSL.W #8,D0              MOVE LEFT 1 BYTE
          JSR INEEE                GET SECOND
          MOVE.B D5,D0             COMBINE WITH FIRST
          OR.W #$2020,D0           UPPER TO LOWER CASE >>C<<
          CMP.W #$7573,D0          IS IT 'US'? >>C<<
          BEQ.S RCUS               YES
          CMP.W #$7373,D0          IS IT 'SS'? >>C<<
          BEQ.S RCSS               YES
          MOVE.B #18,D1            COUNT 18 REG NAMES
          LEA REGERS-1,A0          POINT TO REGISTERS
          LEA RNAMES(PC),A1        POINT TO NAME TABLE
RCLOOP    CMP.W (A1)+,D0           COMPARE NAME
          BEQ.S RCOK               IF LETTER FOUND
          ADD.L #4,A0              POINT TO NEXT REGISTER
          SUB.B #1,D1              CHECK COUNTER
          BNE.S RCLOOP             LOOP TIL DONE
          JMP COMEND               QUIT WITH '?' IF NG
RCSS      LEA SYSTSP-1,A0
          JMP CHANG0               GO TO 'ME' IF OK
RCUS      LEA USERSP-1,A0
RCOK      JMP CHANG0               GO TO 'ME' IF OK
RNAMES    FCC 'd0d1d2d3d4d5d6d7a0a1a2a3a4a5a6a7'    >>C<<
          FCC 'pcsr'               REGISTER NAMES   >>C<<

********************************************************
* "IS" COMMAND - INITIAL SYSTEM SETUP
*      LETS USER SET UP WHICH CONTROLLER (1772 OR 3765)
*      AND WHAT KINDS OF FLOPPY DRIVES HE HAS
********************************************************

ISETUP    LEA ISMSG(PC),A4         PRINT EXPLANATION
          JSR PSTRNG
          JSR SHOWIS               DISPLAY CURRENT CONFIGURATION
ISCONT    LEA ISDOIS(PC),A4
          JSR ASKYN                ASK WHETHER Y OR N
          BEQ.S ISYESG             YES, CONTINUE
          BRA.L NXTCMD             OTHERWISE QUIT
* FIND OUT ABOUT CONTROLLERS FIRST
ISYESG    MOVE.B #0,TEMP1          INITIALLY ASSUME 0 CONTROLLERS
          LEA TEMP2,A0
          MOVE.B #0,(A0)
          MOVE.B #0,2(A0)          ERASE CONTROLLER NAMES
          LEA DY3765(PC),A4
          JSR ASKYN                ASK "DO YOU HAVE 3765
          BNE.S NO3765             NO
          MOVE.B #1,TEMP1          1 CONTROLLER
          MOVE.B #$37,(A0)
          LEA 2(A0),A0             AND BUMP TO POINT TO TEMP3
NO3765    LEA DY1772(PC),A4
          JSR ASKYN                ASK "DO YOU HAVE 1772
          BNE DOSETP               NO
          MOVE.B TEMP1,D7
          ADD.B #1,D7              INCREMENT NUMBER OF CONTROLLERS
          MOVE.B D7,TEMP1
          MOVE.B #$17,(A0)
          CMP.B #$31,D5
          MOVE.B TEMP1,D7          LOOK AT NUMBER OF CONTROLLERS
          CMP.B #2,D7              IS IT 2?
          BCS.S DOSETP             NO, JUST 0 OR 1
* IF THERE ARE TWO DRIVES, FIND OUT WHICH TO BOOT FROM
ASKBOO    LEA BOOMSG(PC),A4
          JSR PSTRNG
          JSR INEEE
          CMP.B #$33,D5
          BEQ.S DOSETP             3765, USE SETUP AS IS
          CMP.B #$31,D5
          BNE.S ASKBOO             NEITHER, ASK AGAIN
          MOVE.B #$17,TEMP2        ELSE SWITCH THEM
          MOVE.B #$37,TEMP3

* POINT TO TABLE ETC.
DOSETP    LEA FL0C,A0              POINT TO FIRST ENTRY IN TABLE
          MOVE.B #0,D0             AND F0 LOGICAL NUMBER
          MOVEP.L D0,0(A0)
          MOVEP.L D0,8(A0)         ERASE TABLE (ODD ONLY)
          MOVEP.L D0,16(A0)
          MOVE.B TEMP2,D1          FIRST CONTROLLER TYPE
          BEQ.S ISDONE             NOTHING THERE
          MOVE.B #0,D2             DRIVE NUMBER ON CONTROLLER
          JSR DODRIV
          JSR DODRIV               DO FIRST TWO DRIVES
          CMP.B #$17,D1            CHECK CONTROLLER TYPE
          BNE.S DO2ND              SKIP 3&4 IF NOT 1772
          JSR DODRIV
          JSR DODRIV
DO2ND     MOVE.B TEMP3,D1          SECOND CONTROLLER TYPE
          BEQ.L ISDONE             IF NOTHING THERE
          MOVE.B #0,D2             DRIVE NUMBER ON CONTROLLER
          JSR DODRIV
          JSR DODRIV               DO UP TO FOUR 1772 DRIVES
          CMP.B #$17,D1            CHECK CONTROLLER TYPE
          BNE.S ISDONE             SKIP 3&4 IF NOT 1772
          JSR DODRIV
          JSR DODRIV
ISDONE    LEA ISFMSG(PC),A4        PRINT "SETUP FINISHED"
          JSR PSTRNG
          JMP NXTCMD

* ROUTINE TO ENTER DATA FOR ONE LOGICAL FLOPPY DRIVE. THE FORMAT IS
*    17 OR 37 TO DENOTE CONTROLLER TYPE
*    00XX0BBB WHERE XX IS PHYSICAL NUMBER OF DRIVE ON CONTROLLER,
*               AND BBB IS THE DRIVE TYPE. THIS BYTE IS 0 IF NONE

DODRIV    LEA D1MSG1(PC),A4
          CMP.B #$37,D1            CHECK IF 37C65
          BNE.S DODRV1
          LEA D3MSG1(PC),A4        ELSE SWITCH
DODRV1    JSR PSTRNG               ASK FOR D2TH DRIVE ON CONTR
          MOVE.B D2,D4
          ADD.B #$30,D4            CVT TO ASCII
          JSR OUTEEE
          JSR CRLF                 PRINT DRIVE NO ON CTRLR
DDAGN     LEA DDMSG2(PC),A4
          JSR PSTRNG               ASK FOR DRIVE DETAIL
          CMP.B #$37,D1
          BNE.S ASKDD              SKIP D. AND E. IF 1772
          LEA DDMSG4(PC),A4
          JSR PSTRNG               ASK FOR DRIVE DETAIL
ASKDD     LEA DDMSG5(PC),A4
          JSR PSTRNG
          JSR INEEE
          AND.B #$DF,D5            CVT TO UPPER
          SUB.B #$41,D5            CVT FROM ASCII
          BEQ.S NONEDR             IF DRIVE-NONE
          CMP.B #6,D5
          BCC.S DDAGN              AGAIN IF >F
          MOVE.B D1,0(A0)          STORE CTRLR TYPE
          MOVE.B D2,D6             NUMBER OF DRV ON CONTROLLER
          ASL.B #4,D6              MOVE INTO LEFT NIBBLE
          ADD.B D6,D5              COMBINE WITH DRIVE TYPE
          MOVE.B D5,2(A0)          STORE INTO TABLE
          LEA DDMSG6(PC),A4
          JSR PSTRNG               PRINT "THIS IS LOG DR"
          MOVE.B D0,D4
          ADD.B #$30,D4            CVT TO ASCII
          JSR OUTEEE               PRINT F NUMBER
          MOVE.B #'.',D4
          JSR OUTEEE               PRINT PERIOD
NONEDR    LEA 4(A0),A0             POINT TO NEXT DRIVE
          ADD.B #1,D0              INCREMENT F NUMBER
          ADD.B #1,D2              INCREMENT DR # ON CONTROLLER
          JSR CRLF
          RTS                      AND EXIT

* ROUTINE TO ASK A QUESTION, RETURN BEQ IF YES, BNE IF NO
ASKYN     JSR PSTRNG               ASK
          LEA ASKYNM,A4            IN CASE HE ANSWERS WRONG
          JSR INEEE                GET ANSWER
          AND.B #$DF,D5            CVT TO UPPER
          CMP.B #$59,D5            YES?
          BEQ.S ASKYNX             EXIT WITH BEQ IF YES
          CMP.B #$4E,D5            NO?
          BNE.S ASKYN              NEITHER, ASK AGAIN
          MOVE.B #$4E,D5           CHANGE TO BNE
ASKYNX    RTS                      THEN EXIT
ASKYNM    DC.B 'Y or N? '
          DC.B 4

* ROUTINE TO DISPLAY CURRENT SETUP CONFIGURATION

SHOWIS    MOVE.B FL0C,D7           CHECK FIRST DRIVE
          CMP.B #$17,D7
          BEQ.S SHOWOK             OK IF 17 OR 37
          CMP.B #$37,D7
          BEQ.S SHOWOK             OK IF SOMETHING THERE
          LEA NOWNON(PC),A4
          JSR PSTRNG               ELSE PRINT NONE
          RTS

SHOWOK    LEA NOWISM(PC),A4
          JSR PSTRNG               PRINT HEADER
          LEA FL0C,A0              POINT TO BEGINNING OF TABLE
          CLR.L D0                 COUNTER
          LEA NOWLIN,A4            POINT TO OUTPUT LINE BUFFER
          MOVE.W #80/4-1,D1        SET UP LOOP TO PUT SPACES INTO IT
NOWLLO    MOVE.L #$20202020,(A4)+  FILL WITH SPACES
          DBRA D1,NOWLLO
          MOVE.B #'F',NOWLIN+5     F
          MOVE.B #4,NOWLIN+79      END MARKER
SHLOOP    LEA NOWLIN,A4            POINT TO OUTPUT LINE BUFFER
          MOVE.B (A0),D1           LOOK AT CONTROLLER TYPE
          CMP.B #$17,D1            IS IT 1772?
          BEQ.S SH1772             YES
          CMP.B #$37,D1            IS IT 3765?
          BNE.S SHNEXT             NOTHING THERE, GO TO NEXT
          MOVE.L #'37C6',22(A4)
          MOVE.B #'5',26(A4)       PUT CONTROLLER TYPE INTO LINE
          BRA.S SHWLOG             THEN SKIP OVER 1772
SH1772    MOVE.L #'1772',22(A4)
          MOVE.B #' ',26(A4)       PUT CONTROLLER TYPE INTO LINE
SHWLOG    MOVE.B D0,D7
          ADD.B #$30,D7            CONVERT F NUMBER INTO ASCII
          MOVE.B D7,6(A4)          PUT INTO LINE
          MOVE.B 2(A0),D3          PICK UP DRIVE DATA FROM TABLE
          MOVE.B D3,D4
          ASR.B #4,D4              SEPARATE INTO PHYSICAL DRIVE
          ADD.B #$30,D4            ASCII
          MOVE.B D4,41(A4)         INTO LINE
          AND.L #$0F,D3            SEPARATE INTO DRIVE TYPE
          MULU #6,D3               MULT BY 6
          ADD.L #NOWTYP,D3         ADD ADDRESS OF TYPE TABLE
          MOVE.L D3,A6             POINT A6 TO ENTRY
          MOVE.L (A6),56(A4)
          MOVE.B 4(A6),60(A4)      MOVE DRIVE TYPE IN
          MOVE.L #$20202020,66(A4)
          MOVE.L #$20202020,70(A4) ERASE "BOOT"
          TST.B D0                 ON F0?
          BNE.S PRINTIT
          MOVE.L #' <--',66(A4)
          MOVE.L #'BOOT',70(A4)    ELSE INSERT <--BOOT
PRINTIT   JSR PSTRNG               PRINT LINE

SHNEXT    LEA 4(A0),A0             NEXT ITEM IN TABLE
          ADD.B #1,D0              GO TO NEXT F
          CMP.B #7,D0              FINISHED?
          BNE.L SHLOOP             NO, CONTINUE
          JSR CRLF                 YES, SKIP LINE AND EXIT
          RTS

ISMSG     FCC 'This command lets you specify the type of floppy disk '
          DC.B $D,$A
          FCC 'controllers and drives you are using. Your current'
          DC.B $D,$A
          FCC 'setup configuration is shown below; F0 is the boot drive.'
          DC.B $D,$A,4
NOWISM    FCC 'LOGICAL DRIVE      CONTROLLER     PHYSICAL DRIVE     DRIVE TYPE'
          DC.B $D,$A,4
          EVEN
NOWTYP    FCC 'NONE  360K  720K  1.2M  1.44M 1M 8" '
NOWNON    FCC 'NONE - nothing is initialized.'
          DC.B $D,$A,4
ISDOIS    FCC 'Do you wish to run the setup program (Y or N)? '
          DC.B 4
DY3765    FCC 'Do you have a 37C65 controller? '
          DC.B 4
DY1772    FCC 'Do you have a 1772 controller? '
          DC.B 4
BOOMSG    FCC 'Which of the controllers would you like to boot from?
          DC.B $D,$A
          FCC '   Type 1 for 1772, 3 for 37C65: '
          DC.B 4
ISFMSG    FCC 'Initial setup is finished.'
          DC.B $D,$A,4
D1MSG1    DC.B $D,$A
          FCC 'For the 1772 controller, answer the following for drive '
          DC.B 4
D3MSG1    DC.B $D,$A
          FCC 'For the 37C65 controller, answer the following for drive '
          DC.B 4
DDMSG2    FCC 'What kind of drive is it?'
          DC.B $D,$A
          FCC '  A. None (The first drive on a controller cannot be NONE!)'
          DC.B $D,$A
          FCC '  B. "360K" drive 300 RPM (40-track, probably 5-1/4 inch)'
          DC.B $D,$A
          FCC '  C. "720K" drive 300 RPM (80-track, 3-1/2 or 5-1/4 inch)'
          DC.B 4
DDMSG4    FCC '  D. "1.2 meg" 360 RPM high density drive (5-1/4 inch)'
          DC.B $D,$A
          FCC '  E. "1.44 meg" 300 RPM high density drive (3-1/2 inch)'
          DC.B $D,$A
          FCC '  F. "1 meg" 360 RPM drive (77-track 8 inch)'
          DC.B 4
DDMSG5    FCC 'Choose one: '
          DC.B 4
DDMSG6    DC.B $D,$A
          FCC 'From now on, the preceding drive will be referred to as F'
          DC.B 7,4

********************************************************
* "LO" COMMAND - LOAD S1S9 FORMAT FORMAT TAPE
********************************************************

LOAD      JSR INEEE                GET THE FIRST CHAR
          CMP.B #$53,D5            S?
          BNE.S LOAD               1ST CHAR NOT S
          JSR INEEE                GET NEXT CHAR
          CMP.B #$39,D5            S9?
          BEQ.L LOAD21             YES, FINISH LOADING
          CMP.B #$38,D5            S8?
          BEQ.L LOAD21             YES, FINISH LOADING
          CMP.B #$37,D5            S7?
          BEQ.S LOAD21             YES, FINISH LOADING
          CMP.B #$31,D5            S1?
          BEQ.S LOADS1             YES
          CMP.B #$32,D5            S2?
          BEQ.S LOADS2             YES
          CMP.B #$33,D5            S3?
          BEQ.L LOADS3             YES
          BRA.S LOAD               2ND CHAR NOT VALID

* LOAD S1 ROUTINE - 2-BYTE ADDRESS
LOADS1    CLR.L D1                 ZERO CHECKSUM
          JSR BYTE                 READ BYTE (D5) & CSUM
          SUB.B #2,D5
          CLR.L D2                 ZERO COUNTER (D2)
          MOVE.B D5,D2             SET COUNTER
          CLR.L D5
LOADR2    JSR BYTE                 GET ADDRESS BYTE & CSUM
          LSL.L #8,D5              MOVE INTO NEXT BYTE
          JSR BYTE                 SECOND ADDRESS BYTE & CSUM
          MOVE.L D5,A0             FORM ADDRESS
* STORE DATA
LOAD11    JSR BYTE                 GET BYTE TO LOAD & CSUM
          SUB.L #1,D2              DECR COUNT
          BEQ.S LOAD15             ZERO BYTE COUNT?
          MOVE.B D5,(A0)           STORE DATA
          CMP.B (A0),D5            DATA STORED?
          BNE.S LOAD19
          ADD.L #1,A0              NEXT ADDRESS
          BRA.S LOAD11
LOAD15    EOR.B #$FF,D1            COMPLEMENT CHECKSUM
          BEQ.L LOAD               OK IF ZERO
LOAD19    MOVE.B #$3F,D4           PRINT ? IF ERROR
          JSR OUTEEE

LOAD21    JMP NXTCMD               QUIT WHEN DONE

* LOAD S2 ROUTINE - 3-BYTE ADDRESS
LOADS2    CLR.L D1                 ZERO CHECKSUM
          JSR BYTE                 READ BYTE (D5) (CSUM)
          SUB.B #3,D5
          CLR.L D2                 ZERO COUNTER (D2)
          MOVE.B D5,D2             SET COUNTER
          CLR.L D5
LOADR3    JSR BYTE                 GET ADDRESS BYTE & CSUM
          LSL.W #8,D5              MOVE INTO NEXT BYTE
          BRA.S LOADR2             READ 2 MORE BYTES, CONTINUE

* LOAD S3 ROUTINE - 4-BYTE ADDRESS
LOADS3    CLR.L D1                 ZERO CHECKSUM
          JSR BYTE                 READ BYTE (D5) (CSUM)
          SUB.B #4,D5
          CLR.L D2                 ZERO COUNTER (D2)
          MOVE.B D5,D2             SET COUNTER
          CLR.L D5
          JSR BYTE                 GET ADDRESS BYTE & CSUM
          LSL.W #8,D5              MOVE INTO NEXT BYTE
          BRA.S LOADR3             READ 3 MORE BYTES, CONTINUE

********************************************************
* 'HD' HEX DUMP COMMAND
* 'AD' ASCII DUMP COMMAND
* 'HA' COMBINED HEX AND ASCII DUMP
********************************************************

HEXDMP    MOVE.B #$FF,D0           HD IS <0 FLAG
          BRA.S HDADHA
ASCDMP    CLR.B D0                 AD IS =0 FLAG
          BRA.S HDADHA
HEXASC    MOVE.B #$1,D0            HA IS >0 FLAG

HDADHA    JSR FROMTO
          MOVE.L BEGA,D4           GET STARTING ADDRESS
          MOVE.L D4,A0             STORE IT
          MOVE.L D4,A1             WORKING COPY
DUMP      JSR CRLF                 JSR CRLF
          MOVE.L A1,D4
          CMP.L #$10000,D4         NEED 4 OR 8 DIGITS?
          BCS.S DUMP0              4 IF <10000
          JSR OUT8HS               ELSE USE 8
          BRA.S DUMP1
DUMP0     JSR OUT4HS               PRINT ADDRESS
DUMP1     JSR OUTS                 EXTRA SPACE
          TST.B D0                 CHECK FLAG
          BEQ.S ONLYAS             ONLY ASCII IF FLAG=0
          MOVE.B #16,D1            SET COUNTER TO 16
DUMP2     MOVE.W A1,D4
          AND.B #$07,D4            ON 0 OR 8 BOUNDARY?
          BNE.S DUMP2A             NO
          JSR OUTS                 YES, SKIP SPACE
DUMP2A    MOVE.B (A1)+,D4          GET THE BYTE
          JSR OUT2HS               PRINT NEXT BYTE
          SUB.B #1,D1              DECREMENT COUNTER
          BNE.S DUMP2              CONTINUE LINE IF NOT FINISHED
          TST.B D0                 SHOULD WE DO ASCII?
          BMI.S NOASCI             DON'T DO IF MINUS
          MOVE.L A0,A1             RESTORE WORKING ADDRESS
          JSR OUTS                 PRINT ANOTHER SPACE
ONLYAS    MOVE.B #16,D1            SET COUNTER TO 16 AGAIN
DUMP3     MOVE.W A1,D4
          AND.B #$07,D4            ON 0 OR 8 BOUNDARY?
          BNE.S DUMP3A             NO
          JSR OUTS                 YES, SKIP SPACE
DUMP3A    MOVE.B (A1)+,D4          GET THE BYTE
          AND.B #$7F,D4            MASK OFF PARITY BIT
          CMP.B #$7E,D4
          BCC.S DUMP4              SUBSTITUTE . FOR 7E,7F
          CMP.B #$20,D4
          BCC.S DUMP5              PRINT SPACE AND ABOVE
DUMP4     MOVE.B #$2E,D4           SUBSTITUTE . FOR ALL ELSE
DUMP5     JSR OUTEEE               PRINT IT
          SUB.B #1,D1              DECREMENT COUNTER
          BNE.S DUMP3              CONTINUE LINE IF NOT FINISHED
NOASCI    MOVE.L A1,A0             SAVE CURRENT
          CMP.L ENDA,A1            ARE WE DONE?
          BCS.L DUMP               NO, DO NEXT LINE
          RTS


********************************************************
* FROMTO SUBR - INITIALIZE BEGA AND ENDA ADDRESSES
********************************************************

FROMTO    LEA FROMST,A4
          JSR PDATA                PRINT "FROM "
          JSR INEEE                GET CHARACTER
          CMP.B #$0D,D5            IS IT A CR?
          BEQ.L CRLF               ON CR, DO CRLF AND RETURN
          JSR CVTHEX               CONVERT TO HEX
          BEQ.L NXTCMD             ABORT IF SPACE
          CLR.L D6
          MOVE.B D5,D6             READY TO FINISH WITH BADDR
          JSR BADDR1               GET REST OF NUMBER
          MOVE.L D5,BEGA           BEGINNING ADDRESS
          LEA TOSTR(PC),A4
          JSR PDATA                PRINT "TO "
          JSR BADDR                GET TO ADDRESS
          MOVE.L D5,ENDA           STORE IT
          JMP OUTS                 AND EXIT

********************************************************
* "FI" COMMAND - FIND 1 TO 5 BYTES IN MEMORY
********************************************************

FIND      LEA MANYST,A4
          JSR PDATA                ASK "HOW MANY BYTES"
          JSR INEEE                GET NUMBER
          SUB.B #$30,D5            CONVERT FROM ASCII
          BEQ.L CRLF               IF = 0
          CMP.B #$5,D5
          BHI.L CRLF               IF GREATER THAN 3
          MOVE.B D5,D3             STORE NUMBER OF BYTES
          MOVE.B D5,D2             BACKUP COPY
          JSR OUTS
          LEA WHATST(PC),A4
          JSR PDATA                ASK "WHAT BYTES"
          LEA WHAT,A0              WHERE TO PUT DESIRED BYTES
FIENTR    JSR BYTE                 ENTER A BYTE
          MOVE.B D5,(A0)+          STORE IT
          SUB.B #1,D3
          BNE.S FIENTR             ENTER MORE, IF NEEDED
          JSR FROMTO               GET BEGA AND ENDA
          MOVE.L BEGA,A0           GET READY TO LOOK
FIND1     MOVE.B D2,D1             RESET NUMBER OF BYTES
          MOVE.B (A0),D0           GET FIRST BYTE
          CMP.B WHAT,D0
          BNE.S FIND4              WRONG BYTE
          SUB.B #1,D1
          BEQ.S FIND2              FOUND ONE CORRECT BYTE
          MOVE.B 1(A0),D0          GET SECOND BYTE
          CMP.B WHAT+1,D0
          BNE.S FIND4              WRONG
          SUB.B #1,D1
          BEQ.S FIND2              FOUND TWO CORRECT BYTES
          MOVE.B 2(A0),D0          GET THIRD BYTE
          CMP.B WHAT+2,D0
          BNE.S FIND4              WRONG
          SUB.B #1,D1
          BEQ.S FIND2              FOUND THREE CORRECT BYTES
          MOVE.B 3(A0),D0          GET FOURTH BYTE
          CMP.B WHAT+3,D0
          BNE.S FIND4              WRONG
          SUB.B #1,D1
          BEQ.S FIND2              FOUND FOUR CORRECT BYTES
          MOVE.B 4(A0),D0          GET FIFTH BYTE
          CMP.B WHAT+4,D0
          BNE.S FIND4              WRONG BYTE
FIND2     BSR.L CRLF               PRINT CRLF
          MOVE.L A0,D4
          BSR.L OUT8HS             PRINT ADDRESS
          JSR OUTS                 ONE MORE SPACE
          LEA -1(A0),A1            BACKUP ONE BYTE
          MOVE.B #7,D1             READY TO PRINT SEVEN BYTES
FIND3     MOVE.B (A1)+,D4
          JSR OUT2HS               PRINT BYTE
          CMP.B #7,D1              BEFORE SECOND BYTE?
          BNE.S FIND3A             NO
          MOVE.B #$3E,D4           POINT TO IT
          JSR OUTEEE
FIND3A    SUB.B #01,D1
          BNE.S FIND3              PRINT FOUR BYTES
FIND4     CMP.L ENDA,A0            SEE IF DONE
          BEQ.L CRLF               YES
          ADD.L #1,A0              NO
          BRA.L FIND1              KEEP LOOKING

********************************************************
* "FM" COMMAND - FILL MEMORY WITH CONSTANT
********************************************************

FILL      JSR FROMTO               GET FROM-TO ADDRESSES
          LEA WITHST,A4
          JSR PDATA                ASK FOR DATA
          JSR BYTE                 INPUT
          MOVE.L BEGA,A0           GET STARTING ADDRESS
          MOVE.L ENDA,A1           ENDING ADDRESS
          ADD.L #1,A1              SIMPLIFY COMPARISON
FILOOP    MOVE.B D5,(A0)+          STORE THE BYTE
          CMP.L A1,A0              SEE IF DONE
          BNE.S FILOOP             CONTINUE OF NO
          RTS                      QUIT WHEN DONE

********************************************************
* SUM - MEMORY CHECKSUM
********************************************************

SUM       JSR FROMTO               GET ADDRESS LIMITS
          MOVE.L BEGA,A0           GET STARTING ADDRESS
          MOVE.L ENDA,A1           GET ENDING ADDRESS
          CLR.L D0
          CLR.L D1
SUMLP     MOVE.B (A0)+,D1          GET BYTE
          ADD.L D1,D0              ADD INTO CHECKSUM
          CMP.L ENDA,A0            LAST ADDRESS?
          BLS.S SUMLP              NO, REPEAT
SUMDON    MOVE.L D0,D4
          JSR OUT8HS               OUTPUT CHECKSUM
          RTS

********************************************************
* 'MT' - MEMORY TEST
********************************************************

MTEST     JSR FROMTO               GET ADDRESS LIMITS
          MOVE.L BEGA,A0
          MOVE.L ENDA,A2
LODREG    MOVE.B (A0),D2           SAVE OLD CONTENTS
          MOVE.B #1,D0             STORE 1 IN MEMORY
          MOVE.B D0,(A0)
          CMP.B (A0),D0            WAS IT WRITTEN?
          BNE.S ERRPNT             NO
ROLP1     ASL.B #1,D0
          BEQ.S INCR1              DONE WHEN ALL ZEROES
          MOVE.B D0,(A0)           STORE NEXT BIT
          CMP.B (A0),D0            CHECK IT
          BEQ.S ROLP1              OK, DO NEXT BIT
ERRPNT    JSR CRLF                 ON ERROR
          MOVE.L A0,D4             ADDRESS OF WRONG BYTE
          BSR.L OUT8HS             PRINT IT
          MOVE.B D0,D4             INCORRECT BIT
          JSR OUT2HS               OUTPUT WHAT SHOULD BE STORED
          MOVE.B (A0),D4           WRONG BIT
          JSR OUT2HS               OUTPUT WHAT WAS STORED
INCR1     MOVE.B D2,(A0)           RESTORE PREVIOUS CONTENTS
          CMP.L A2,A0              COMPARE WITH END ADDRESS
          BEQ.S FINISH
          ADD.L #1,A0
          BRA.S LODREG             DO NEXT BYTE IF NOT DONE
FINISH    MOVE.B #$2B,D4
          JSR OUTEEE               PRINT "+"
          RTS

********************************************************
* 'AI' COMMAND - ASCII INPUT ROUTINE
********************************************************

ASCIN     JSR FROMTO               GET ADDRESS RANGE
          JSR CRLF
          MOVE.L ENDA,A1           GET LAST EMPTY ADDRESS
          MOVE.L BEGA,A0           GET STARTING ADDRESS
          SUB.L #1,A0
ASCI2     ADD.L #1,A0
          JSR INEEE                GET NEXT CHARACTER
          MOVE.B D5,(A0)           STORE IT
          CMP.B (A0),D5            SEE IF IT STORED OK
          BNE.S ASCI3              NO, ERROR
          MOVE.L A0,ENDA           STORE ENDING ADDRESS
          CMP.L A0,A1              CHECK IF RUN OUT OF MEMORY
          BNE.S ASCI2              NO, SO GET MORE
ASCI3     LEA ESTR,A4              MEM FULL OR BAD, SO..
          JSR PDATA                PRINT ERROR
          BRA.L NXTCMD             QUIT

********************************************************
* 'AO' COMMAND - ASCII OUTPUT ROUTINE
********************************************************

ASCOUT    JSR FROMTO               GET ADDRESS RANGE
          JSR CRLF
          MOVE.L BEGA,A0           GET STARTING ADDRESS
          MOVE.L ENDA,A1           GET ENDING ADDRESS
ASCO2     MOVE.B (A0),D4           GET NEXT CHARACTER
          JSR OUTEEE               OUTPUT IT
          CMP.L A0,A1              SEE IF DONE
          BEQ.S ASCO3              YES
          ADD.L #1,A0
          BRA.S ASCO2              REPEAT IF NOT
ASCO3     RTS                      RETURN WHEN DONE

********************************************************
* 'MO' COMMAND - MOVE MEMORY ROUTINE
********************************************************

MOVE      LEA OLDSTR,A4
          JSR PDATA                ASK FOR OLD ADDRESSES
          JSR FROMTO
          JSR CRLF
          LEA NEWSTR,A4
          JSR PDATA                ASK FOR NEW ADDRESS
          JSR BADDR
          MOVE.L D5,A2             SAVE NEW ADDRESS
          MOVE.L BEGA,A0           BEGINNING ADDRESS
          MOVE.L ENDA,A1           ENDING ADDRESS
* NOW CHECK FOR FORWARD MOVE OR BACKWARD MOVE
          MOVE.L A0,D0             BEGINNING
          SUB.L A2,D0              SUBTRACT NEW
          BCS.S BACK               BACKWARD IF BEGINNING<NEW
          BNE.S FWD1
MEXIT     RTS                      NO MOVE IF NEW=OLD
* FORWARD MOVE
FWD1      MOVE.B (A0)+,(A2)+       MOVE AND INCREMENT
          CMP.L A0,A1              END?
          BNE.S FWD1               NO
          MOVE.B (A0),(A2)         MOVE LAST BYTE
          RTS                      RTS
* BACKWARD MOVE
BACK      MOVE.L A1,D0
          SUB.L A0,D0              COMPUTE NEW END
          ADD.L A2,D0
          MOVE.L D0,A3             TFR D,Y
          MOVE.B (A1),(A3)         MOVE LAST
BACK1     CMP.L A0,A1              DONE?
          BEQ.S MEXIT              YES
          MOVE.B -(A1),-(A3)       DECREMENT AND MOVE
          BRA.S BACK1              AND REPEAT

********************************************************
* 'BR' COMMAND - SET/RESET UP TO FOUR BPS
********************************************************

BREAK     BSR.S BKNUM              POINT A0 TO BP IN TABLE
          BSR.S BERASE             GO ERASE OLD ONE
          LEA NEWSTR(PC),A4        PRINT "ENTER NEW ADDRESS: "
          JSR PDATA
          JSR BADDR                GET ADDRESS
          BTST #0,D5               CHECK WHETHER EVEN
          BNE.S ODDADD             NO
          TST.L D5
          BEQ.L COMEND             NG IF ZERO
          MOVE.L D5,A1             POINT TO DESIRED BP
          MOVE.L D5,(A0)           STORE ADDRESS IN TABLE
          MOVE.W (A1),4(A0)        STORE PRESENT OP CODE
          MOVE.W #$4AFC,(A1)       SUBST INVALID INSTRUCTION CODE
          RTS                      AND RETURN
ODDADD    LEA ANEMSG(PC),A4
          JSR PSTRNG               PRINT "ADDRESS NOT EVEN"
          JMP NXTCMD

* ERASE PREVIOUS BP, IF ANY, AND RESTORE OP CODE
BERASE    MOVE.W 4(A0),D1          GET OP CODE
          MOVE.L (A0),A1           GET ADDRESS
          CMP.L #$FFFFFFFF,A1      WAS THERE A BP?
          BEQ.S BEEXIT             NO, EXIT
          MOVE.W D1,(A1)           YES, RESTORE OP CODE
          MOVE.L #$FFFFFFFF,(A0)   ERASE BP TABLE ENTRY
BEEXIT    RTS                      AND RETURN

********************************************************
* BKNUM ROUTINE - GET NO OF DESIRED BP & POINT
* TO ITS LOCATION IN BKTAB TABLE
********************************************************

BKNUM     LEA BNSTR,A4
          JSR PDATA
          JSR INEEE                GET BP NUMBER
          SUB.B #$30,D5            CONVERT FROM ASCII
          BEQ.L NXTCMD             IF ZERO
          CMP.B #$4,D5
          BHI.L NXTCMD             IF GREATER THAN 4
          CLR.L D0
          MOVE.B D5,D0
          JSR OUTS
          MOVE.W #6,D1
          MULU D0,D1               OFFSET INTO TABLE
          LEA BKTAB-6,A0           POINT TO BREAKPOINT TABLE
          LEA 0(A0,D1.L),A0         POINT TO ENTRY IN TABLE
          RTS                      RETURN WHEN DONE

********************************************************
* 'BP' COMMAND - PRINT BP LOCATIONS
********************************************************

BPRINT    MOVE.B #$30,D1           BP NUMBER IN ASCII
          LEA BKTAB,A0             POINT TO TABLE
BPR1      ADD.B #01,D1             NEXT BP NUMBER
          CMP.B #$35,D1            STOP AT 5 BPS
          BNE.S BPR2
          RTS                      RETURN WHEN DONE
BPR2      JSR CRLF                 PRINT CR
          MOVE.L D1,D4             GET BP NUMBER
          JSR OUTEEE               PRINT BP NUMBER
          JSR OUTS                 PRINT SPACE
          MOVE.L (A0)+,D4          GET BP ADDRESS
          CMP.L #$FFFFFFFF,D4      IS THERE ONE?
          BNE.S BPR3               YES, GO PRINT IT
          ADD.L #2,A0              POINT TO NEXT
          BRA.S BPR1               AND REPEAT
BPR3      JSR OUT8HS               PRINT ADDRESS OF BP
          MOVE.W (A0)+,D4          GET OP CODE
          JSR OUT4HS               PRINT OP CODE
          BRA.S BPR1               AND REPEAT

********************************************************
* 'RE' COMMAND - PRINT USER REGISTERS FROM STACK
********************************************************

REGIST    JSR CRLF                 JSR CRLF
          MOVE.W USERSR,D7         CHECK USER STATUS
          BTST.W #13,D7            CHECK S BIT
          BEQ.S A7ISUS             ZERO MEANS A7 IS USP
          MOVE.L SYSTSP,D7         ELSE A7 IS SYSTEM SP
          BRA.S OKONA7
A7ISUS    MOVE.L USERSP,D7         A7 IS USER SP
OKONA7    MOVE.L D7,REGA7
          LEA REMSG,A4             POINT TO COLUMN HEADER
          JSR PDATA                PRINT HEADER
          JSR CRLF
          LEA REGERS,A0            POINT TO REGISTER TABLE
          LEA DMSG,A4
          JSR PDATA                PRINT "D: "
          MOVE.B #8,D0             COUNT D REGISTERS
DPLOOP    MOVE.L (A0)+,D4          GET NEXT
          JSR OUT8HS               OUTPUT D REGISTER
          SUB.B #1,D0              DECREMENT COUNTER
          BNE.S DPLOOP             REPEAT UNTIL DONE
          JSR CRLF                 NEXT LINE
          LEA AMSG,A4
          JSR PDATA                PRINT "A: "
          MOVE.B #8,D0             COUNT A REGISTERS
APLOOP    MOVE.L (A0)+,D4          GET NEXT
          JSR OUT8HS               OUTPUT A REGISTER
          SUB.B #1,D0              DECREMENT COUNTER
          BNE.S APLOOP             REPEAT UNTIL DONE
          JSR CRLF                 NEXT LINE
          LEA PCMSG,A4
          JSR PDATA                PRINT "PC="
          MOVE.L (A0)+,D4          GET IT
          JSR OUT8HS               PRINT REGISTER
          LEA SRMSG,A4
          JSR PDATA                PRINT "SR="
          MOVE.W (A0)+,D4          GET IT
          MOVE.W D4,D0             SAVE IT
          MOVE.W D4,D2             SAVE IT
          JSR OUT4HS               PRINT REGISTER
          MOVE.B #$3D,D4
          JSR OUTEEE               PRINT EQUALS
          LEA SRLETR,A0            POINT TO LETTER TABLE
          MOVE.B #5,D1             DO FIRST FIVE LETTERS
          BSR.S SRLOOP             PRINT LETTERS
          MOVE.W D2,D4             GET INTERRUPT MASK
          LSR.W #8,D4              INTO RIGHT BYTE
          AND.B #$07,D4            INTERRUPT ONLY
          ADD.B #$30,D4            CVT TO ASCII
          JSR OUTEEE               PRINT IT
          LSL.W #3,D0              SKIP THE INTERRUPT BITS
          MOVE.B #8,D1             DO LAST 8 BITS
          BSR.S SRLOOP             PRINT LETTERS
          LEA USMSG,A4
          JSR PDATA                PRINT "US="
          MOVE.L USERSP,D4         GET IT
          JSR OUT8HS               PRINT REGISTER
          LEA SSMSG,A4
          JSR PDATA                PRINT "SS="
          MOVE.L SYSTSP,D4         GET IT
          JSR OUT8HS               PRINT REGISTER
          JSR CRLF                 FINISH UP
          RTS
* LOOP TO PRINT LETTERS FOR SR
SRLOOP    MOVE.B (A0)+,D4          GET NEXT LETTER
          LSL.W #1,D0              NEXT BIT INTO C
          BCS.S SRLUSE             IS 1 SO USE LETTER
          MOVE.B #$2E,D4           IS 0 SO SUBSTITUTE PERIOD
SRLUSE    JSR OUTEEE               PRINT IT
          SUB.B #1,D1              DECREMENT COUNTER
          BNE.S SRLOOP
          RTS
SRLETR    FCC 'TTSM????XNZVC'

********************************************************
* 'ST' - START SINGLE-STEP COMMAND
********************************************************

STRTSS    LEA FROMST,A4
          JSR PDATA                PRINT "FROM "
          JSR BADDR                GET ADDRESS
          TST.L D5
          BEQ.L COMEND             NG IF ZERO
          BTST #0,D5
          BNE.L ODDADD             NG IF ODD ADDRESS
          LEA WARMST,A0
          MOVE.L A0,USTACK-4       PUT RETURN ADDRESS ON STACK
          MOVE.L A0,SSTACK-4       PUT RETURN ADDRESS ON STACK
          LEA USTACK-4,A0
          MOVE.L A0,USERSP         INITIALIZE USER SP MEMORY
          LEA SSTACK-4,A0
          MOVE.L A0,SYSTSP         INITIALIZE SYST SP MEMORY
STEPCO    MOVE.W USERSR,D0         OLD STATUS REGISTER
          MOVE.L SYSTSP,A7         USE HIS SYSTEM SP
* USE 8 IN FOLLOWING INSTRUCTION FOR 68010/68020 >>B<<
          SUB.L #6,A7              BUT STEP BACK 6 TO MAKE ROOM
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S STEP00             6 OK FOR 68000
          SUB.L #2,A7              ELSE MAKE IT -8
* USE CLEAR INSTRUCTION FOR 68010/68020 >>B<<
          CLR.W 6(A7)              CLEAR 68010/20 FORMAT
STEP00    MOVE.W D0,(A7)           PUT USER SR ON STACK
          MOVE.L D5,2(A7)          PUT GOTO ADDRESS ON STACK
          MOVE.L USERSP,A0
          MOVE.L A0,USP            SET USER STACK POINTER
          MOVE.L $0024,A5
          MOVE.L A5,TRAVEC         SAVE OLD TRACE VECTOR
          LEA TRARET(PC),A5
          MOVE.L A5,$0024          PUT IN NEW TRACE VECTOR
          MOVE.L D5,A0             SAVE GOTO ADDRESS
          BSR.L PRTINS             PRINT OUT ADDRESS AND INSTR
          MOVEM.W (A0),D5-D5       LOOK AT THE NEXT INSTRUCTION
          CMP.W #$4E73,D5          IS IT AN RTE???
          BEQ.S ISRTE              YES, IT IS AN RTE
* SIMPLE IF IT'S NOT AN RTE
          MOVE.W (A7),D5           GET USER SR
          OR.W #$8000,D5           TURN ON TRACE BIT
          MOVE.W D5,(A7)           AND BACK ON STACK
          MOVEM.L REGERS,D0-D7/A0-A6 RESTORE REGISTERS
          RTE                      AND GO TO USER

* THEN COME BACK TO HERE
TRARET    MOVEM.L D0-D7/A0-A7,REGERS SAVE REGISTERS
          MOVE.W (A7),D0
          AND.W #$7FFF,D0          TURN OFF TRACE BIT
          MOVE.W D0,USERSR         SAVE USER STATUS REGISTER
          MOVE.L 2(A7),USERPC      AND USER PC
          MOVE.L USP,A0
          MOVE.L A0,USERSP         AND USER STACK POINTER
          BTST.W #13,D0            CHECK S BIT IN SR
          BEQ.S TRARUS             S=0 WAS USER MODE
          MOVE.L REGA7,D0          S=1 WAS SYSTEM, SO SAVE SYST SP
          ADD.L #6,D0              REMOVE SR AND PC
          MOVE.L D0,SYSTSP
TRARUS    MOVE.L TRAVEC,A5
          MOVE.L A5,$0024          RESTORE OLD TRACE VECTOR
          MOVE.W SYSTSR,SR         RESTORE INTERRUPT LEVEL
          JSR REGIST               PRINT REGISTERS
          JMP NXTCMD

* IF NEXT INSTRUCTION IS AN RTE, WE HAVE TO CARRY TRACE ACROSS
* CHANGE OF STATE

ISRTE     MOVE.L USERSP,A5         USER'S STACK POINTER
          MOVE.W (A5),D0           GET SR HE'S RETURNING
          OR.W #$8000,D0           SET THAT TRACE BIT
          MOVE.W D0,(A5)           RETURN IT
          MOVEM.L REGERS,D0-D7/A0-A6 RESTORE REGISTERS
          RTE                      AND FINALLY GO TO USER

* ROUTINE TO PRINT OUT INSTRUCTION POINTED TO BY A0

PRTINS    JSR CRLF                 NEXT LINE
          MOVE.L A0,D4             GOTO ADDRESS
          SWAP D4
          BSR.L OUT4H              PRINT IT W/O TRAILING SPACE
          SWAP D4
          BSR.L OUT4H
          MOVE.B #$3A,D4
          JSR OUTEEE               PRINT :
          MOVE.B #$20,D4
          JSR OUTEEE               PRINT SPACE
          MOVE.W (A0),D4
          JSR OUT4HS               PRINT OP CODE
          RTS

********************************************************
* 'SS' COMMAND - SINGLE STEP AFTER BREAKPOINT
********************************************************

STEP      MOVE.L USERPC,D5         WHERE TO GO
          BRA.L STEPCO             AND CONTINUE AS IN ST

********************************************************
* 'CO' COMMAND - CONTINUE AFTER A BREAKPOINT
********************************************************

CONT      MOVE.L USERPC,D5         WHERE TO GO
          MOVE.W USERSR,D0         OLD STATUS REGISTER
          MOVE.L SYSTSP,A7         USE HIS SYSTEM SP
* USE 8 IN FOLLOWING INSTRUCTION FOR 68010/68020 >>B<<
          SUB.L #6,A7              BUT STEP BACK 6 TO MAKE ROOM
          TST.B CPUTYP             CHECK PROCESSOR
          BEQ.S CONT00             6 OK FOR 68000
          SUB.L #2,A7              ELSE MAKE IT -8
* USE CLEAR INSTRUCTION FOR 68010/68020 >>B<<
          CLR.W 6(A7)              CLEAR 68010/20 FORMAT
CONT00    MOVE.W D0,(A7)           PUT USER SR ON STACK
          MOVE.L D5,2(A7)          PUT GOTO ADDRESS ON STACK
          MOVE.L USERSP,A0
          MOVE.L A0,USP            SET USER STACK POINTER
          MOVEM.L REGERS,D0-D7/A0-A6 RESTORE REGISTERS
          RTE                      AND GO TO USER

********************************************************
* 'MC' - MEMORY COMPARISON ROUTINE
********************************************************

COMPAR    LEA P1MSG,A4
          JSR PDATA                PRINT 'PROGRAM 1: '
          JSR FROMTO               GET PROGRAM 1 START AND END ADDR.
          JSR CRLF
          LEA P2MSG,A4
          JSR PDATA                PRINT 'PROGRAM 2: FROM '
          JSR BADDR                GET PROGRAM 2 START ADDR.
          MOVE.L BEGA,A0           PROG 1 START
          MOVE.L ENDA,A1           PROG 1 END
          ADD.L #1,A1              POINT PAST IT
          MOVE.L D5,A2             PROG 2 START
          JSR CRLF                 JSR CRLF
          MOVE.B #3,D0             INITIALIZE LINE COUNTER
MCLOOP    MOVE.B (A0)+,D7          GET NEXT BYTE FROM PGM 1
          CMP.B (A2)+,D7           COMPARE WITH PGM 2
          BEQ.S INCR               IF SAME, SEE IF DONE
* DIFFERENT BYTES, SO PRINT
          SUB.B #1,D0              DECREMENT LINE COUNTER
          BNE.S MCCONT             IF ROOM ON LINE, CONTINUE
          MOVE.B #2,D0             OTHERWISE RESET
          JSR CRLF
MCCONT    JSR OUTS
          JSR OUTS                 PRINT TWO SPACES
          MOVE.L A0,D4
          SUB.L #1,D4
          JSR OUT8HS               PRINT ADDRESS 1
          MOVE.B -1(A0),D4
          JSR OUT2HS               PRINT DATA 1
          MOVE.L A2,D4
          SUB.L #1,D4
          JSR OUT8HS               PRINT ADDRESS 2
          MOVE.B -1(A2),D4
          JSR OUT2HS               PRINT DATA 2
INCR      CMP.L A0,A1              DONE?
          BNE.S MCLOOP
          RTS                      FINISH UP

********************************************************
* 'HE' - HELP COMMAND
********************************************************

HELP      JSR CRLF
          LEA HLPMSG,A4
          JSR PSTRNG               PRINT HELP TEXT
          RTS

******************************************************
* TRAP PROCESSING
******************************************************

* BUSERR - BUS ERROR

PRBERR    MOVE.L BERVEC,A4
          JMP (A4)                 FOLLOW BUS ERROR VECTOR, MAYBE
BUSERR    LEA BUSMSG(PC),A4        ... TO HERE
          JSR PSTRNG
          JMP REPORS

* ADDERR - ADDRESS ERROR

ADDERR    LEA ADDMSG(PC),A4
          JSR PSTRNG
          JMP REPORS

* ILLINS - ILLEGAL INSTRUCTION

ILLINS    MOVEM.L D0-D7/A0-A7,REGERS SAVE REGISTERS
          CMP.L #$D7123456,D7      CHECK WHETHER IN CPUTYP TEST
          BNE.S ILLIN1             NO
          CMP.L #$A1987654,A1
          BNE.S ILLIN1             NO
          CMP.L #$A2A2A2A2,A2
          BNE.S ILLIN1             NO
          CMP.L #$A3A3A3A3,A3
          BNE.S ILLIN1             NO
          CMP.L #$A4A4A4A4,A4
          BEQ.L CPUTRE             YES, SO RETURN TO START
ILLIN1    MOVE.W SYSTSR,SR         RESTORE ORIGINAL IRQ LEVEL
          MOVE.W (A7),D0
          MOVE.W D0,USERSR         SAVE SR
          MOVE.L USP,A0
          MOVE.L A0,USERSP         SAVE SP
          MOVE.L 2(A7),A0          GET USER'S PC
          MOVE.L A0,USERPC         SAVE PC
          BTST.W #13,D0            CHECK S BIT IN SR
          BEQ.S ILLIUS             S=0 WAS USER MODE
          MOVE.L REGA7,D0          S=1 WAS SYSTEM, SO SAVE SYST SP
          ADD.L #6,D0              SKIP PAST SR AND PC
          MOVE.L D0,SYSTSP
ILLIUS    MOVE.W (A0),D0           GET OFFENDING INSTRUCTION
          CMP.W #$4AFC,D0          CHECK IF A BREAK
          BEQ.S CHKILL             MAY BE LEGAL, GO CHECK
REALIL    LEA ILLMSG(PC),A4
          JSR PSTRNG
PRTILL    MOVE.L 2(A7),D4
          JSR OUT8HS               PRINT ADDRESS
          JSR REGIST               PRINT REGISTERS
          JMP NXTCMD
CHKILL    CMP.L BKTAB,A0           CHECK ADDRESS 1
          BEQ.S ISBRK              IT'S A BREAK
          CMP.L BKTAB+6,A0         CHECK ADDRESS 2
          BEQ.S ISBRK              IT'S A BREAK
          CMP.L BKTAB+12,A0        CHECK ADDRESS 3
          BEQ.S ISBRK              IT'S A BREAK
          CMP.L BKTAB+18,A0        CHECK ADDRESS 4
          BNE.S REALIL             DEFINITELY ILLEGAL
ISBRK     LEA BRKMSG,A4
          JSR PSTRNG               PRINT "BREAKPOINT AT "
          BRA.S PRTILL

* ZERDIV - ZERO DIVIDE

ZERDIV    LEA ZERMSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* CHKINS - CHK INSTRUCTION

CHKINS    LEA CHKMSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPVI - TRAPV INSTR

TRAPVI    LEA TVIMSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* PRIVIO - PRIVILEGE VIOLATION

PRIVIO    LEA PRIMSG(PC),A4
          JSR PSTRNG
          JMP REPORS

* LN1010 - LINE 1010

LN1010    LEA L10MSG(PC),A4
          JSR PSTRNG
          JMP REPORS

* LN1111 - LINE 1111

LN1111    LEA L11MSG(PC),A4
          JSR PSTRNG
          JMP REPORS

* UNASSI - UNASSIGNED

UNASSI    LEA UNAMSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* FORERR - FORMAT ERROR ON 68010

FORERR    LEA FORMSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* SPURIO - SPURIOUS INTERRUPT

SPURIO    LEA SPUMSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL1IA - LEVEL 1 INTERRUPT AUTOVECTOR

LVL1IA    LEA LV1MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL2IA - LEVEL 2 INTERRUPT AUTOVECTOR

LVL2IA    LEA LV2MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL3IA - LEVEL 3 INTERRUPT AUTOVECTOR

LVL3IA    LEA LV3MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL4IA - LEVEL 4 INTERRUPT AUTOVECTOR

LVL4IA    LEA LV4MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL5IA - LEVEL 5 INTERRUPT AUTOVECTOR

LVL5IA    LEA LV5MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL6IA - LEVEL 6 INTERRUPT AUTOVECTOR

LVL6IA    LEA LV6MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* LVL7IA - LEVEL 7 INTERRUPT AUTOVECTOR

LVL7IA    LEA LV7MSG(PC),A4
          JSR PSTRNG
          JMP WARMST

* TRAP0V - TRAP 0

TRAP0V    LEA TR0MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP1V - TRAP 1

TRAP1V    LEA TR1MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP2V - TRAP 2

TRAP2V    LEA TR2MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP3V - TRAP 3

TRAP3V    LEA TR3MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP4V - TRAP 4

TRAP4V    LEA TR4MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP5V - TRAP 5

TRAP5V    LEA TR5MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP6V - TRAP 6

TRAP6V    LEA TR6MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP7V - TRAP 7

TRAP7V    LEA TR7MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP8V - TRAP 8

TRAP8V    LEA TR8MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAP9V - TRAP 9

TRAP9V    LEA TR9MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPAV - TRAP 10

TRAPAV    LEA T10MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPBV - TRAP 11

TRAPBV    LEA T11MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPCV - TRAP 12

TRAPCV    LEA T12MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPDV - TRAP 13

TRAPDV    LEA T13MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPEV - TRAP 14

TRAPEV    LEA T14MSG(PC),A4
          JSR PSTRNG
          JMP REPORN

* TRAPFV - TRAP 15

TRAPFV    MOVE.L T15VEC,A4
          JMP (A4)                 FOLLOW TRAP 15 VECTOR

* REPORT ADDRESS OF EXCEPTION OCCURRENCE. REPORS ASSUMES
* PUSHED ADDRESS IS THAT OF TRAP, REPORN ASSUMES ADDRESS
* IS THAT OF NEXT INSTRUCTION

REPORS    MOVE.L 2(A7),D4          GET EXCEPTION'S PC
REPORT    JSR OUT8HS               REPORT IT
          JMP WARMST

REPORN    MOVE.L 2(A7),D4          GET EXCEPTION'S PC
          SUB.L #2,D4              FIX IT
          BRA.S REPORT

*******************************************************
* TEXT STRINGS
*******************************************************

BUSMSG    FCC 'BUS ERROR AT ',4
ADDMSG    FCC 'ADDRESS ERROR AT ',4
ILLMSG    FCC 'ILLEGAL INSTRUCTION AT ',4
ZERMSG    FCC 'ZERO DIVIDE AT ',4
CHKMSG    FCC 'CHK INSTRUCTION AT ',4
TVIMSG    FCC 'TRAPV INSTR AT ',4
PRIMSG    FCC 'PRIVILEGE VIOLATION AT ',4
L10MSG    FCC 'LINE 1010 AT ',4
L11MSG    FCC 'LINE 1111 AT ',4
UNAMSG    FCC 'UNASSIGNED',4
FORMSG    FCC 'FORMAT ERROR ON 68010',4
SPUMSG    FCC 'SPURIOUS INTERRUPT',4
LV1MSG    FCC 'LEVEL 1 INTERRUPT AUTOVECTOR',4
LV2MSG    FCC 'LEVEL 2 INTERRUPT AUTOVECTOR',4
LV3MSG    FCC 'LEVEL 3 INTERRUPT AUTOVECTOR',4
LV4MSG    FCC 'LEVEL 4 INTERRUPT AUTOVECTOR',4
LV5MSG    FCC 'LEVEL 5 INTERRUPT AUTOVECTOR',4
LV6MSG    FCC 'LEVEL 6 INTERRUPT AUTOVECTOR',4
LV7MSG    FCC 'LEVEL 7 INTERRUPT AUTOVECTOR',4
TR0MSG    FCC 'TRAP 0 AT ',4
TR1MSG    FCC 'TRAP 1 AT ',4
TR2MSG    FCC 'TRAP 2 AT ',4
TR3MSG    FCC 'TRAP 3 AT ',4
TR4MSG    FCC 'TRAP 4 AT ',4
TR5MSG    FCC 'TRAP 5 AT ',4
TR6MSG    FCC 'TRAP 6 AT ',4
TR7MSG    FCC 'TRAP 7 AT ',4
TR8MSG    FCC 'TRAP 8 AT ',4
TR9MSG    FCC 'TRAP 9 AT ',4
T10MSG    FCC 'TRAP 10 AT ',4
T11MSG    FCC 'TRAP 11 AT ',4
T12MSG    FCC 'TRAP 12 AT ',4
T13MSG    FCC 'TRAP 13 AT ',4
T14MSG    FCC 'TRAP 14 AT ',4
H68MSG    FCC 'HUMBUG (R) Ver. 2.1, '
          FCC 'Copyright (C) 1986 - 1990 by Peter A. Stark',4
NOCMSG    FCC ' DATA DID NOT STORE',4
MEBMSG    FCC ' BUS ERROR',4
WHMESG    FCC 'REGISTER: ',4
FROMST    FCC ' FROM ',4
TOSTR     FCC ' TO ',4
MANYST    FCC 'HOW MANY BYTES? ',4
WITHST    FCC ' WITH? ',4
WHATST    FCC 'FIND WHAT? ',4
ESTR      FCC ' MEMORY FULL OR DEFECTIVE ',4
ANEMSG    FCC 'ADDRESS ERROR - NOT EVEN',4
BRKMSG    FCC 'BREAKPOINT ENCOUNTERED AT ',4
OLDSTR    FCC 'ENTER OLD ADDRESSES:',4
NEWSTR    FCC 'ENTER NEW ADDRESS: ',4
BNSTR     FCC ' NUMBER: ',4
REMSG     FCC '       0        1        2        3        4'
          FCC '        5        6        7',4
DMSG      FCC 'D: ',4
AMSG      FCC 'A: ',4
PCMSG     FCC 'PC=',4
SRMSG     FCC '   SR=',4
USMSG     FCC '   US=',4
SSMSG     FCC '   SS=',4
STMSG     FCC 'START FROM '
ADMSG     FCC 'ADDRESS: ',4
P1MSG     FCC 'REGION 1: ',4
P2MSG     FCC '     REGION 2:  FROM ',4
HLPMSG    FCC 'AD - ASCII Dump                  LO - LOad S1-S9 format'
          DC.B $D,$A
          FCC 'AI - ASCII Input FCC             MC - Memory Compare'
          DC.B $D,$A
          FCC 'AO - ASCII Output                ME - Memory Examine'
          DC.B $D,$A
          FCC 'BA - BASIC                       MO - MOve memory'
          DC.B $D,$A
          FCC 'BP - Breakpoint Print            MS - Memory Store'
          DC.B $D,$A
          FCC 'BR - BReakpoint set/reset        MT - Memory Test'
          DC.B $D,$A
          FCC 'CO - COntinue                    RC - Register Change'
          DC.B $D,$A
          FCC 'CS - CheckSum                    RD - Return to DOS'
          DC.B $D,$A
          FCC 'FD - Boot SK*DOS / Floppy Disk   RE - Register Examine'
          DC.B $D,$A
          FCC 'FI - FInd 1-5 bytes              SS - Single Step'
          DC.B $D,$A
          FCC 'FM - Fill Memory                 ST - STart single-step'
          DC.B $D,$A
 FCC 'HA - Hex and ASCII dump          WA - Boot SK*DOS / WX-GEN Drive A'
          DC.B $D,$A
 FCC 'HD - Hex memory Dump             WB - Boot SK*DOS / WX-GEN Drive B'
          DC.B $D,$A
 FCC 'HE - HElp                        WH - Boot SK*DOS / -HDO'
          DC.B $D,$A
          FCC 'IS - Initial Setup of system     X1 - eXtra option 1      '
          DC.B $D,$A
          FCC 'JS - Jump to System program      !! - Force reset'
          DC.B $D,$A
          FCC 'JU - Jump to User program'
          DC.B $D,$A,4

**********************************************************
* SYSTEM - DEPENDENT ROUTINES
**********************************************************

**********************************************************
* PARITY MEMORY ROUTINES
* NEEDED ONLY IF MEMORY CONTAINS PARITY CIRCUITRY
**********************************************************

MEMRD     RTS                      READ AND WRITE ALL OF MEMORY

PARON     RTS                      THEN TURN ON PARITY CIRCUITRY

************************
* CONSOLE I/O ROUTINES *
************************

***********************************************************
* EQUATES. THESE ROUTINES USE A 68681 DUART1 AT $FE0000
* FOR THE PT-68K-2 COMPUTER
***********************************************************

DUART1    EQU $FE0000              DUART 1 ADDRESS
DUART2    EQU $FE0040              DUART 2 ADDRESS
DMODEA    EQU 1                    PORT A MODE REG
DCLOCA    EQU 3                    PORT A CLOCK REG
DSTATA    EQU 3                    PORT A STATUS REG
DCOMMA    EQU 5                    PORT A COMMAND REGISTER
DDATAA    EQU 7                    PORT A DATA REGISTERS
DAUXCR    EQU 9                    AUXILIARY CONTROL REG
DINCHG    EQU 9                    INPUT PORT CHANGE REG
DINTMK    EQU 11                   INTERRUPT MASK REG
DINTST    EQU 11                   INTERRUPT STATUS REG
DCTUPR    EQU 13                   CTR/TIMER UPPER REGISTER
DCTLOW    EQU 15                   CTR/TIMER LOWER REGISTER
DMODEB    EQU 17                   PORT B MODE REG
DCLOCB    EQU 19                   PORT B CLOCK REG
DSTATB    EQU 19                   PORT B STATUS REG
DCOMMB    EQU 21                   PORT B COMMAND REGISTER
DDATAB    EQU 23                   PORT B DATA REGISTERS
DIVECT    EQU 25                   INTERRUPT VECTOR REG
DIPORT    EQU 27                   INPUT PORT
DOPORT    EQU 27                   OUTPUT PORT
PIT       EQU $FE0080              PARALLEL INTERFACE / TIMER
PSRR      EQU 3                    PIT SERVICE CONTROL REG
PPCDDR    EQU 9                    PIT PORT C DIRECTION REG


* MONOCHROME BOARD EQUATES

BNWRAM    EQU $D60000              VIDEO MEMORY ADDRESS
BNWADD    EQU $FA0769              6845 ADDRESS REGISTER
BWDATA    EQU BNWADD+2             6845 DATA REGISTER
BLATCH    EQU $FA0771              VIDEO CONTROL PORT

* CGA BOARD EQUATES

COLRAM    EQU $D70000              COLOR MEMORY ADDRESS
COLADD    EQU $FA07A9              6845 ADDRESS REGISTER
CODATA    EQU COLADD+2             6845 DATA REGISTER
CLATCH    EQU $FA07B1              COLOR CONTROL PORT
CCOLOR    EQU $FA07B3              COLOR SET REGISTER
COSTAT    EQU $FA07B5              CGA STATUS REG

* CLONE-STYLE KEYBOARD EQUATES

SKBRKA    EQU $16FA                SK*DOS BREAK RETURN ADDR
INDOS     EQU $171A                >0 IF CURRENTLY IN SK*DOS
KDATA     EQU $FE01C3              KEYBOARD DATA REG
KCLEAR    EQU $FE01C1              CLEARS KEYBOARD FLAG

* KBS BYTE TELLS US WHAT (USUALLY LOCK) STATE WE'RE IN
* KEYBOARD STATUS BYTE EXPLANATION:
*  7      6      5       4     3      2     1       0
*  0  | CAPSL | NUML |   0  |  0  | CTRL |  0   | SHFT |

* KBA BYTE TELLS US WHICH LOCK KEYS ARE ACTIVE
* KEY ACTIVE BYTE EXPLANATION:
*  7      6      5       4     3      2     1       0
*  0  | CAPSL | NUML |   0  |  0  |   0  |  0   |   0  |

* ALSO PRESENT ARE INQCHR, WHICH HOLDS THE LATEST CHAR RCVD
* FROM CLONE KEYBOARD, AND INQFLG WHICH TELLS US WHETHER
* INQCHR IS PRESENT OR NOT (IT ALSO PROVIDES STATUS INFO)

* THE HARDWE BYTE TELLS US WHAT HARDWARE IS ON THE SYSTEM:
*  7      6      5       4     3      2     1       0
* CGA |  B&W  |  -   |  WX1 |SLOTS|DUART2|DUART1|  PIT |


***********************************************************
* INIPOR - I/O PORT INITIALIZATION ROUTINE
*
* FIRST, DO AN INVENTORY TO SEE WHAT HARDWARE WE HAVE AND
* PUT IT INTO HARDWE
***********************************************************

INIPOR    CLR.B HARDWE             START WITH NOTHING
          CLR.B STATSI
          CLR.B STATSO
          MOVE.L BERVEC,A2         SAVE EXISTING BUS ERROR VEC
          LEA D1TEST(PC),A1
          MOVE.L A1,BERVEC         NO PIT RETURN
          CLR.B PIT+PPCDDR         PORT C ALL INPUT
          CLR.B PIT+PSRR           PIT PIRQ IS PORT C
          BSET #0,HARDWE           AND MARK PIT THERE
          BRA.S D1TES1             SKIP
D1TEST    ADD.L #14,A7             DELETE STACKED ERROR
D1TES1    LEA D2TEST(PC),A1
          MOVE.L A1,BERVEC         NO DUART1 RETURN
          CLR.B DUART1+DINTMK      CLEAR IRQ MASK REG
          BSET #1,HARDWE           AND MARK DUART THERE
          BRA.S D2TES1             SKIP
D2TEST    ADD.L #14,A7             DELETE STACKED ERROR
D2TES1    LEA IBTEST(PC),A1
          MOVE.L A1,BERVEC         NO DUART2 RETURN
          CLR.B DUART2+DINTMK      CLEAR IRQ MASK REG
          BSET #2,HARDWE           AND MARK DUART THERE
          BRA.S IBTES1             SKIP
IBTEST    ADD.L #14,A7             DELETE STACKED ERROR
IBTES1    LEA TEDONE(PC),A1
          MOVE.L A1,BERVEC         NO XT PORT RETURN
          MOVE.B $C00001,D7        TRY LOADING FROM XT SLOTS 1.3
          BSET #3,HARDWE           AND MARK SLOTS THERE
          BRA.S TEDON1             SKIP
TEDONE    ADD.L #14,A7             DELETE STACKED ERROR
TEDON1    MOVE.L A2,BERVEC         RESTORE BUS ERROR VECTOR

***********************************************************
* INITIALIZE VIDEO BOARD IF ANY, CLONE KEYBOARD INTERRUPTS,
* CONSOLE AND PRINTER PORTS, AND SET BAUD RATES
***********************************************************

* IF THERE ARE XT SLOTS, THEN
* TAKE A CHANCE AND INITIALIZE THE VIDEO BOARDS, EVEN IF
* THERE'S A POSSIBILITY THERE ISN'T ONE, JUST SO WE DON'T TAKE
* A CHANCE ON BLOWING OUT AN IBM MONITOR

          BTST #3,HARDWE
          BEQ.L NOVIDB             IF NO SLOTS
* MONOCHROME BOARD
          MOVE.B #$29,BLATCH       HIGH RES, VIDEO ON, BLINK ON 1.3
          LEA BNWADD,A5            POINT TO ADDR REG
          MOVE.B #$00,(A5)
          MOVE.B #97,2(A5)         VIS+INVIS CHAR/LINE
          MOVE.B #1,(A5)
          MOVE.B #80,2(A5)         VIS CHAR/LINE
          MOVE.B #2,(A5)
          MOVE.B #82,2(A5)         HOR SYNC POS
          MOVE.B #3,(A5)
          MOVE.B #15,2(A5)         HOR SYNC WIDTH
          MOVE.B #4,(A5)
          MOVE.B #25,2(A5)         VERT LINES OF TEXT
          MOVE.B #5,(A5)
          MOVE.B #6,2(A5)          VERTICAL ADJUST
          MOVE.B #6,(A5)
          MOVE.B #25,2(A5)         DISPLAY 25 LINES
          MOVE.B #7,(A5)
          MOVE.B #25,2(A5)         VERT SYNC POS
          MOVE.B #8,(A5)
          MOVE.B #2,2(A5)          NON-INTERLACE
          MOVE.B #9,(A5)
          MOVE.B #13,2(A5)         14 SCAN LINES PER ROW
          MOVE.B #10,(A5)
          MOVE.B #32,2(A5)         TURN OFF THE CURSOR
          MOVE.B #11,(A5)
          MOVE.B #12,2(A5)         END CURSOR AT LINE 12
          MOVE.B #12,(A5)
          MOVE.B #0,2(A5)          VID MEM STARTS AT 0000
          MOVE.B #13,(A5)
          MOVE.B #0,2(A5)          DITTO
          MOVE.B #14,(A5)
          MOVE.B #0,2(A5)          CURSOR NOW ALSO AT 0000
          MOVE.B #15,(A5)
          MOVE.B #0,2(A5)          DITTO

* CGA BOARD
          LEA COLADD,A5            POINT TO ADDR REG
          MOVE.B #$00,(A5)
          MOVE.B #$71,2(A5)         VIS+INVIS CHAR/LINE
          MOVE.B #1,(A5)
          MOVE.B #80,2(A5)         VIS CHAR/LINE
          MOVE.B #2,(A5)
          MOVE.B #$5A,2(A5)         HOR SYNC POS
          MOVE.B #3,(A5)
          MOVE.B #$0A,2(A5)         HOR SYNC WIDTH
          MOVE.B #4,(A5)
          MOVE.B #$1F,2(A5)         VERT LINES OF TEXT
          MOVE.B #5,(A5)
          MOVE.B #6,2(A5)          VERTICAL ADJUST
          MOVE.B #6,(A5)
          MOVE.B #25,2(A5)         DISPLAY 25 LINES
          MOVE.B #7,(A5)
          MOVE.B #$1C,2(A5)         VERT SYNC POS
          MOVE.B #8,(A5)
          MOVE.B #2,2(A5)          NON-INTERLACE
          MOVE.B #9,(A5)
          MOVE.B #$07,2(A5)         7 SCAN LINES PER ROW
          MOVE.B #10,(A5)
          MOVE.B #32,2(A5)         TURN OFF THE CURSOR
          MOVE.B #11,(A5)
          MOVE.B #$07,2(A5)         END CURSOR AT LINE 7
          MOVE.B #12,(A5)
          MOVE.B #0,2(A5)          VID MEM STARTS AT 0000
          MOVE.B #13,(A5)
          MOVE.B #0,2(A5)          DITTO
          MOVE.B #14,(A5)
          MOVE.B #0,2(A5)          CURSOR NOW ALSO AT 0000
          MOVE.B #15,(A5)
          MOVE.B #0,2(A5)          DITTO
          MOVE.B #$29,CLATCH       HIGH RES, VIDEO ON, BLINK ON
          MOVE.B #$01,CCOLOR       BLUE BORDER

* NOW CHECK WHETHER A MONOCHROME BOARD ACTUALLY EXISTS

          MOVE.B #$A5,BNWRAM+1
          MOVE.B #$5A,BNWRAM+5     DISCHARGE THE BUS
          CMP.B #$A5,BNWRAM+1      CAN WE STORE INTO VIDEO RAM?
          BNE.L CHKCOL             NO, SO NO BNW BOARD
          MOVE.B #$5A,BNWRAM+1     TRY THE COMPLEMENT
          MOVE.B #$A5,BNWRAM+5     DISCHARGE THE BUS
          CMP.B #$5A,BNWRAM+1
          BNE.L CHKCOL             NO, SO TRY COLOR BOARD

* BNW BOARD EXISTS, SO SET EVERYTHING UP

YESBNW    BSET #5,STATSO           COLOR BOARD OUTPUT
          BSET #7,HARDWE
          MOVE.B #11,MCURSZ        CURSOR SIZE BYTE
          MOVE.B #7,MATTR          ATTRIBUTE - LOW INTENSITY
          CLR.B MCURH              CURSOR AT 00
          CLR.B MCURV

* ERASE THE SCREEN. THIS ROUTINE STORES 00'S INTO UNUSED
* EVEN) BYTES OF VIDEO MEMORY, BUT THIS SHOULD BE OK - THEY
* DON'T GO ANYWHERE

          MOVE.L #1999,D7          ERASE (25X80) CHARS
          LEA BNWRAM,A5            POINT TO SCREEN RAM
          MOVE.L #$00200007,D6     SPACE AND LOW INTENSITY
BNWLOO    MOVE.L D6,(A5)+          STORE IT
          DBRA D7,BNWLOO           REPEAT
          MOVE.L ABFLAG,D7         CHECK AUTOBOOT FLAG
          AND.L #$FFFFFF00,D7
          CMP.L #$41554200,D7      'AUB'?
          BEQ.L CHKCOL             SKIP WHEN AUTOBOOTING
          LEA BNWRAM,A5            POINT TO SCREEN RAM
          LEA PENMSG,A6            POINT TO TEXT STRING
BNWPLO    MOVE.B (A6)+,D7          NEXT CHAR
          CMP.B #4,D7              DONE?
          BEQ.S CHKCOL             YES
          MOVE.B D7,1(A5)          PUT ON SCREEN
          ADD.L #4,A5              TO NEXT CHAR
          BRA.S BNWPLO
PENMSG    DC.B 'Please press ENTER ',17,196,217,4

* NOW CHECK WHETHER THE COLOR BOARD ACTUALLY EXISTS

CHKCOL    MOVE.B #$A5,COLRAM+1
          MOVE.B #$5A,COLRAM+5     DISCHARGE THE BUS
          CMP.B #$A5,COLRAM+1      CAN WE STORE INTO COLOR RAM?
          BNE.L CHBOTH             NO, SO NO COLOR BOARD
          MOVE.B #$5A,COLRAM+1     TRY THE COMPLEMENT
          MOVE.B #$A5,COLRAM+5     DISCHARGE THE BUS
          CMP.B #$5A,COLRAM+1
          BNE.S CHBOTH             NO, SO NO COLOR BOARD

* COLOR BOARD EXISTS, SO SET EVERYTHING UP

YESCOL    BSET #4,STATSO           VIDEO BOARD OUTPUT
          BSET #6,HARDWE
          MOVE.B #06,CCURSZ        CURSOR SIZE BYTE
          MOVE.B #$1E,CATTR        ATTRIBUTE - YEL ON BLUE
          CLR.B CCURH              CURSOR AT 00
          CLR.B CCURV

* ERASE THE SCREEN. THIS ROUTINE STORES 00'S INTO UNUSED
* EVEN) BYTES OF VIDEO MEMORY, BUT THIS SHOULD BE OK - THEY
* DON'T GO ANYWHERE

          MOVE.L #1999,D7          ERASE (25X80) CHARS
          LEA COLRAM,A5            POINT TO SCREEN RAM
          MOVE.L #$0020001E,D6     SPACE AND YEL/BLUE
COLLOO    MOVE.L D6,(A5)+          STORE IT
          DBRA D7,COLLOO           REPEAT
          MOVE.L ABFLAG,D7         CHECK AUTOBOOT FLAG
          AND.L #$FFFFFF00,D7
          CMP.L #$41554200,D7      'AUB'?
          BEQ.L CHBOTH             SKIP WHEN AUTOBOOTING
          LEA COLRAM,A5            POINT TO SCREEN RAM
          LEA PENMSG,A6            POINT TO TEXT STRING
COLPLO    MOVE.B (A6)+,D7          NEXT CHAR
          CMP.B #4,D7              DONE?
          BEQ.S CHBOTH             YES
          MOVE.B D7,1(A5)          PUT ON SCREEN
          ADD.L #4,A5              TO NEXT CHAR
          BRA.S COLPLO

* IF TWO VIDEO BOARDS, CHOOSE B&W;
* IF NEITHER VIDEO BOARD, USE SERIAL OUTPUT

CHBOTH    MOVE.B STATSO,D7
          AND.B #$30,D7            CHECK THE BW & COLOR BITS
          BEQ.S NOVIDB             IF NEITHER
          CMP.B #$30,D7            BOTH?
          BNE.S INCLON             NO
          BCLR #4,STATSO           YES, TURN OFF COLOR
          BRA.S INCLON             CONTINUE IF THERE
NOVIDB    BSET #6,STATSO           ELSE TURN ON SERIAL OUTPUT

* NOW INITIALIZE CLONE KEYBOARD, IRQ5, ETC.

INCLON    CLR.B KBS                CLEAR KB STATUS BYTE
          CLR.B KBA                CLEAR KEY ACTIVE BYTE
          CLR.B INQFLG             CLEAR KB FLAGS
          CLR.B ICTFLG
          CLR.B INQCHR             AND KB CHARACTER
          MOVE.W #63,D6            CLEAR OUT 64 CHARS FROM KB
CKBLO1    MOVE.W #$0FFF,D7         TIME
          TST.B KCLEAR             CLEAR KEYBOARD IRQ
CKBLO2    NOP                      ... 64 TIMES
          DBRA D7,CKBLO2           WAIT A BIT
          DBRA D6,CKBLO1           THEN CLEAR AGAIN
          MOVE.L #DUART1,A0         POINT TO DUART1
          TST.B DINCHG(A0)         CLEAR ANY PENDING IRQ
          MOVE.B #$E4,DAUXCR(A0)   ENABLE IP2 IRQ (JUST IN CASE)
          MOVE.B #$80,DINTMK(A0)   ALLOW IP2 CHANGE IRQ
          AND.W #$F8FF,SR          SET IRQ LEVEL 0
* CLONE KEYBOARD INTERRUPTS ARE NOW ACTIVE!!!

* INITIALIZE DUART1

          MOVE.L A0,PORADM         SET CONTROL PORT ADDRESS
          MOVE.L A0,A1
          ADD.L #16,A1
          MOVE.L A1,PORADP         SET PRINTER PORT ADDRESS
          MOVE.B #$15,DCOMMB(A0)   CRB: MODE=1, ENABLE RX&TX
          MOVE.B #$5,DCOMMB(A0)    CRB: ENABLE RX & TX
          MOVE.B #$13,DMODEB(A0)   MRB1: NO RTS, NO PARITY, 8 BITS
          MOVE.B #$27,DMODEB(A0)   MRB2: RTS,1 STOP BIT
          MOVE.B #$BB,DCLOCB(A0)   CSRB: 9600 BAUD
EMPTYB    BTST #0,DSTATB(A0)       CHECK IF SOMETHING IN RCVR
          BEQ.S BAUDAG             NO, SO CONTINUE
          MOVE.B DDATAB(A0),D0     EMPTY RCVR BUFFER 3 TIMES
          BRA.S EMPTYB
* INITIALIZE SERIAL PORT A ... SORT OF
BAUDAG    CLR.W D0
BAUWAI    SUB.W #1,D0              WAIT 1/2 SECOND OR SO
          BNE.S BAUWAI
          MOVE.B #$20,DCOMMA(A0)   RESET RECEIVER
          MOVE.B #$15,DCOMMA(A0)   CRA: MODE=1, ENABLE RX&TX
          MOVE.B #$5,DCOMMA(A0)    CRA: ENABLE RX & TX
          MOVE.B #$13,DMODEA(A0)   MRA1: NO RTS, NO PARITY, 8 BITS
          MOVE.B #$07,DMODEA(A0)   MRA2: NO RTS,1 STOP BIT
          MOVE.B #$88,DCLOCA(A0)   SET CSRA TO 2400 BAUD
          MOVE.B #$E4,DAUXCR(A0)   AUX CONTROL REG = SET 2 >>C<<
* AUX CR=E4 FOR CLOCK SET 2, TIMER ON (FOR BELL), AND
*           ALSO FOR IP2 IRQ ENABLE (FOR CLONE KEYBOARD)
EMPTYA    BTST #0,DSTATA(A0)       CHECK IF SOMETHING IN RCVR
          BEQ.S DNGDNG             NO, SO CONTINUE
          MOVE.B DDATAA(A0),D0     EMPTY RCVR BUFFER 3 TIMES
          BRA.S EMPTYA

* RING DING-DONG, BUT SKIP IF AUTOBOOTING >>F<<

DNGDNG    MOVE.L ABFLAG,D0         CHECK AUTOBOOT FLAG
          AND.L #$FFFFFF00,D0
          CMP.L #$41554200,D0      'AUB'?
          BEQ.L KBSETB             SKIP WHEN AUTOBOOTING
          MOVE.B #$04,DCTUPR(A0)
          MOVE.B #$00,DCTLOW(A0)   SET TONE FREQUENCY
          MOVE.B #$04,DOPORT(A0)   TURN ON CTR/TMR OUTPUT ON OP3
          MOVE.W #$4000,D0
BL1       MULU #1,D0               WAIT A BIT
          DBRA D0,BL1
          MOVE.B #$00,DOPORT(A0)   TURN OFF
          MOVE.W #$2000,D0
BL2       MULU #1,D0               WAIT AGAIN
          DBRA D0,BL2
          MOVE.B #$C1,DCTLOW(A0)   DOWN TWO NOTES
          MOVE.B #$04,DOPORT(A0)   TURN ON
          MOVE.W #$4000,D0
BL3       MULU #1,D0               WAIT A BIT
          DBRA D0,BL3
          MOVE.B #$00,DOPORT(A0)   TURN OFF

* IF NOT AUTOBOOTING:
* WAIT FOR A CHARACTER FROM EITHER CLONE KBD OR SERIAL PORT,
* AND SET STATUS TO INDICATE WHICH IT WAS

* NOW SIT BACK AND JUST WAIT FOR A CR CHARACTER
KBWAIT    CMP.B #$0D,INQCHR        CHECK CLONE KBD
          BEQ.S ISCLON             GOT ONE!
BAUDWA    BTST.B #0,DSTATA(A0)     CHECK SERIAL RX RDY BIT
          BNE.S ISSERI             GOT A SERIAL ONE!
          BRA.S KBWAIT             ELSE WAIT SOME MORE

ISCLON    BSET #1,STATSI           SIGNAL CLONE KBD IN USE
          BCLR #0,STATSI           TURN OFF SERIAL OUTPUT
          CLR.B INQFLG             CLEAR RECEIVED CR
          CLR.B ICTFLG
          CLR.B S1BAUD             AND ALSO SAVE FOR AUTOBOOT >>F<<
          RTS                      AND RETURN

ISSERI    BSET #0,STATSI           SIGNAL SERIAL KBD IN USE
          BCLR #1,STATSI           AND PC KBD OFF
          MOVE.B DDATAA(A0),D0     GET CHARACTER
          AND.B #$7F,D0            REMOVE PARITY BIT
          LEA BAUTAB(PC),A1        POINT TO BAUD TABLE
BAULOO    MOVE.W (A1)+,D1          GET NEXT ENTRY
          CMP.B D0,D1              DOES IT MATCH?
          BEQ.S BAUDOK             YES, GOT RIGHT BAUD RATE
          CMP.B #$FF,D1            ARE WE AT END OF TABLE?
          BEQ.L BAUDAG             YES, TRY IT AGAIN
          BRA.S BAULOO             NO, CHECK NEXT BAUD RATE

BAUTAB    DC.W $BB7F               9600 BAUD
          DC.W $BB7E               ALSO 9600 BAUD
          DC.W $880D               2400 BAUD
          DC.W $6666               1200 BAUD
          DC.W $5578               600 BAUD
          DC.W $4400               300 BAUD
          DC.W $00FF               END OF TABLE

BAUDOK    LSR.W #8,D1              GET BAUD RATE CODE
          MOVE.B D1,DCLOCA(A0)     GIVE IT TO DUART1
          MOVE.B D1,S1BAUD         AND SAVE FOR AUTOBOOT >>F<<
          MOVE.B DDATAA(A0),D0
          MOVE.B DDATAA(A0),D0     EMPTY RCVR BUFFER 3 TIMES
          MOVE.B DDATAA(A0),D0
          CMP.B #$BB,D1            WAS IT 9600 BAUD? >>C<<
          BNE.S BAURTS             NO, SO LEAVE AS IS >>C<<
* IF 9600 BAUD, IT COULD ALSO BE 19200; CHECK >>C<<
BAUDW2    BTST.B #0,DSTATA(A0)     CHECK RX RDY BIT >>C<<
          BEQ.S BAUDW2             WAIT FOR ANOTHER CHARACTER >>C<<
          MOVE.B DDATAA(A0),D0     GET CHARACTER >>C<<
          AND.B #$7F,D0            REMOVE PARITY BIT >>C<<
          CMP.B #$0D,D0            CR? >>C<<
          BEQ.S BAURTS             YES, USE 9600 >>C<<
          MOVE.B #$CC,DCLOCA(A0)   NO, SWITCH TO 19200 >>C<<
          MOVE.B #$CC,S1BAUD       AND SAVE FOR AUTOBOOT >>F<<
          MOVE.B DDATAA(A0),D0     >>C<<
          MOVE.B DDATAA(A0),D0     EMPTY RCVR BUFFER 3 TIMES >>C<<
          MOVE.B DDATAA(A0),D0     >>C<<
BAURTS    BSET #6,STATSO           TURN ON SERIAL I/O
          BSET #0,STATSI
          RTS                      >>C<<

* AUTOBOOTING: >>F<<
* GET BAUD RATE CODE FROM S1BAUD AND SET INTO DUART, EXCEPT THAT
* A RATE OF 0 MEANS USE CLONE KEYBOARD

KBSETB    MOVE.B S1BAUD,D1         GET BAUD RATE CODE
          BNE.S NOTACL             NONZERO MEANS NOT CLONE
          BSET #1,STATSI           SIGNAL CLONE KBD IN USE
          BCLR #0,STATSI           TURN OFF SERIAL OUTPUT
          CLR.B INQFLG             CLEAR RECEIVED CR
          CLR.B ICTFLG
          RTS                      AND RETURN

NOTACL    BSET #0,STATSI           SIGNAL SERIAL KBD IN USE
          BCLR #1,STATSI           AND PC KBD OFF
          BSET #6,STATSO           TURN ON SERIAL I/O
          MOVE.B D1,DCLOCA(A0)     OLD BAUD RATE TO DUART1
          MOVE.B DDATAA(A0),D0
          MOVE.B DDATAA(A0),D0     EMPTY RCVR BUFFER 3 TIMES
          MOVE.B DDATAA(A0),D0
          RTS

***************************************************
* INTERRUPT SERVICE SUBROUTINE
* REMEMBER TO PRESERVE REGISTERS
***************************************************

KBISS     BTST #6,DUART1+DINCHG     CHECK WHETHER KB CAUSED IT AND CLEAR
          BEQ.L LVL5IA             EXIT IF NOT
          BTST #2,DUART1+DINCHG     CHECK WHETHER HIGH OR LOW
          BNE.S KBRTE3             EXIT IF IT WENT HIGH
          MOVEM.L D5-D7/A5,-(A7)
          CLR.L D5                 IF IT WENT LOW, GET READY
          MOVE.B KDATA,D5          GET SCAN CODE
          BEQ.S KBRTE2             SKIP IF ZERO
          TST.B KCLEAR             CLEAR KEYBOARD
          BSR.L CONVERT            CONVERT TO ASCII IN D5
          BEQ.S MAYBD6             IGNORE IF NOTHING THERE
          BTST #3,KBS              ALTERNATE?
          BEQ.S NOALT1             NO
          OR.B #$80,D5             YES, SET BIT 8
NOALT1    MOVE.B D5,INQCHR         SAVE NEW CHARACTER
          MOVE.B #1,INQFLG         AND SET THE FLAG
MAYBD6    TST.W D6                 CHECK FOR CONTROL CODE
          BEQ.S KBRTE0             IGNORE IF NOTHING THERE
          BTST #3,KBS              ALTERNATE?
          BEQ.S NOALT2             NO
          OR.B #$80,D6             YES, SET BIT 8
NOALT2    MOVE.W D6,ICTCHR         ELSE PUT IN
          MOVE.B #1,ICTFLG         AND SET THE FLAG
            LSL.B #1,D6              LOOK AT D6 CODE AGAIN
            BEQ.S DONULL             NULL IF ALL ZEROES
KBRTE0    MOVEM.L (A7)+,D5-D7/A5
KBRTE1    RTE                      THEN RETURN
KBRTE2    MOVEM.L (A7)+,D5-D7/A5
KBRTE3    TST.B KCLEAR             CLEAR KEYBOARD
          RTE                      THEN RETURN
* ALLOW NULL CHARACTER ON VERSION 1.1 AND LATER
DONULL     BTST #3,KBS              ALTERNATE NULL?
           BEQ.S NOALT3             NO
           OR.B #$80,D5             YES, SET BIT 7
NOALT3     MOVE.B D5,INQCHR         SAVE THE NULL
           MOVE.B #1,INQFLG         SET THE FLAG
           BRA.S KBRTE0             AND EXIT

***************************************************
* SUBROUTINE TO CONVERT CODE IN D5 INTO ASCII IN D5
***************************************************

CONVERT   MOVE.B D5,D6             SAVE AND CHECK ORIG CODE
          BMI.L RELEAS             RELEASING KEY
          CMP.B #70,D5             SCROLL LOCK?
          BEQ.L CHKSCR             CHECK IF A BREAK
NOTBR1    CMP.B #83,D5             DEL?
          BEQ.L CHKDEL             CHECK IF A BREAK
NOTBR2    LEA KEYTAB(PC),A5        POINT TO KEY TABLE
          MULU #12,D5
          ADD.L D5,A5              POINT TO TABLE LINE

**********
* WE COME HERE WHEN WE ARE PRESSING KEY DOWN
**********

          TST.W 0(A5)              CHECK CONVERTED CODE
          BEQ.L SPESHL             SPECIAL IF MINUS

* NORMAL KEYS WITH ASCII CODES

          BTST #2,KBS              IN CONTROL MODE?
          BNE.S COLUM3             YES, USE TABLE COL 3
          BTST #5,KBS              IN NUMLOCK MODE?
          BEQ.S NOTNML             NO
          TST.W 10(A5)             CHECK 4TH COLUMN
          BPL.S COLUM4             USE IT IF EXISTS
NOTNML    BTST #0,KBS              SHIFT KEY DOWN?
          BNE.S YSHIFT             YES, MAYBE COL 2
          BTST #6,KBS              NO SHIFT, CHK CAPS LOCK
          BEQ.S COLUM1             NEITHER, USE COLUMN 1
          MOVE.B 0(A5),D7          CHECK CHARACTER
          CMP.B #'a',D7
          BCS.S COLUM1             COL 1 IF CL BUT NOT LETR
          CMP.B #'z',D7
          BHI.S COLUM1             DITTO
          BRA.S COLUM2             COL 2 IF CL AND LETTER
YSHIFT    BTST #6,KBS              SHIFT, CHK CAPS LOCK
          BEQ.S COLUM2             ONLY SHIFT, USE COL 2
          MOVE.B 0(A5),D7          BOTH, CHECK CHARACTER
          CMP.B #'a',D7
          BCS.S COLUM2             COL 2 BOTH BUT NOT LETR
          CMP.B #'z',D7
          BHI.S COLUM2             DITTO
* AND FALL THROUGH INTO COL 1 IF BOTH AND LETTER

COLUM1    MOVE.L 0(A5),D6
          LSR.L #8,D6              CONTROL CODE IN D6
          MOVE.B 0(A5),D5          REGULAR CODE IN D5
          RTS
COLUM2    MOVE.W 4(A5),D6          CONTROL CODE IN D6
          MOVE.B 3(A5),D5          REGULAR CODE IN D5
          RTS
COLUM3    MOVE.L 6(A5),D6
          LSR.L #8,D6              CONTROL CODE IN D6
          MOVE.B 6(A5),D5          REGULAR CODE IN D5
          RTS
COLUM4    MOVE.W 10(A5),D6         CONTROL CODE IN D6
          MOVE.B 9(A5),D5          REGULAR CODE IN D5
          RTS

* ABNORMAL KEYS WITHOUT ASCII CODES, SIGNALLED BY NO ENTRY
* IN THE KEY TABLE

SPESHL    TST.B D6                 CHECK SCAN CODE
          BEQ.S CCRTS              00 = NOTHING THERE
          CMP.B #29,D6
          BEQ.S CTRLDN             CONTROL DOWN
          CMP.B #42,D6
          BEQ.S SHFTDN             LEFT SHIFT DOWN
          CMP.B #54,D6
          BEQ.S SHFTDN             RIGHT SHIFT DOWN
          CMP.B #56,D6
          BEQ.S ALTDN              ALTERNATE DOWN
          CMP.B #58,D6
          BEQ.L CAPSDN             CAPS LOCK DOWN
          CMP.B #69,D6
          BCS.S CCRTS              IGNORE ALL FUNCTION KEYS
          BEQ.L NUMLDN             NUM LOCK DOWN
          RTS                      ELSE QUIT

* CONTROL KEY WENT DOWN
CTRLDN    BSET #2,KBS              SET CONTROL BIT IN KBS
CCRTS     CLR.B D5                 RETURN NOTHING
          CLR.W D6
          RTS

* ALTERNATE-KEY WENT DOWN
ALTDN     BSET #3,KBS              SET ALT BIT IN KBS
          BRA.S CCRTS

* SHIFT KEY WENT DOWN
SHFTDN    BSET #0,KBS              SET SHIFT BIT IN KBS
          BRA.S CCRTS

* SCROLL-LOCK WENT DOWN - RETURN TO SK*DOS IF IN CONTROL AND
*  NOT CURRENTLY IN IT
CHKSCR    BTST #2,KBS              CHECK WHETHER CONTROL
          BEQ.L NOTBR1             IGNORE IF NO
          MOVE.W $1000,D7
          CMP.W #$4EF9,D7          CHECK IF SK*DOS IS LOADED
          BNE.L SKISNO             NO, NOT LOADED
          TST.B INDOS              YES, ARE WE IN IT CURRENTLY?
          BNE.S CCRTS              YES, SO DON'T BREAK
          MOVE.B #$00,DUART1+DOPORT TURN OFF CTR/TMR OUTPUT
          MOVE.L SKBRKA,A5         GET SK*DOS BREAKA ADDR
          MOVE.W 20(A7),D7         SR OF INTERRUPTED PROGRAM
          MOVE.W D7,D6             COPY IT
          AND.W #$0700,D6          INTERRUPT LEVEL BITS
          CMP.W #$0500,D6          NEED AT LEAST LVL 5 FOR KBD
          BCS.S GOT4               OK IF <=4
          MOVE.W #$0400,D6         IF >4 MAKE IT 4
GOT4      BSET #13,D6              ASSUME SYSTEM STATE
          BTST #13,D7              IS OLD SR SYSTEM STATE?
          BNE.S RETSYS             YES, SO EXIT IN SYSTEM STATE
          CMP.L #$1006,A5          RETURN TO SK*DOS WARMSTART?
          BEQ.S RETSYS             YES, SO GO IN SYSTEM STATE
          BCLR #13,D6              NO, SO RETURN IN USER STATE
RETSYS    MOVE.W D6,SR             SET UP RETURN SR
          ADD.L #26,A7             REMOVE 26 BYTES FROM STACK
          JMP (A5)                 AND RETURN TO SK*DOS

* CAPS LOCK KEY WENT DOWN - LOCK IF PREVIOUSLY UP
CAPSDN    BTST #6,KBA              CHECK IF DOWN
          BNE.L CCRTS              IGNORE IF ALREADY DOWN
          BSET #6,KBA              MARK IT DOWN IF NOW UP
          BCHG #6,KBS              AND TOGGLE IT IN STATUS
          BRA.L CCRTS              THEN EXIT

* NUM LOCK KEY WENT DOWN - LOCK IF PREVIOUSLY UP
NUMLDN    BTST #5,KBA              CHECK IF DOWN
          BNE.L CCRTS              IGNORE IF ALREADY DOWN
          BSET #5,KBA              MARK IT DOWN IF NOW UP
          BCHG #5,KBS              AND TOGGLE IT IN STATUS
          BRA.L CCRTS              THEN EXIT

* CHECK FOR CTRL - ALT - DELETE
CHKDEL    BTST #2,KBS              CHECK CONTROL
          BEQ.L NOTBR2             IGNORE IF NOT
          BTST #3,KBS              CHECK ALTERNATE
          BEQ.L NOTBR2             IGNORE IF NOT
          TST.B INDOS              YES, ARE WE IN IT CURRENTLY?
          BNE.L CCRTS              YES, SO DON'T BREAK
          MOVE.B #$00,DUART1+DOPORT TURN OFF CTR/TMR OUTPUT
SKISNO    TRAP #15                 QUIT IF CTL-ALT-DEL

**********
* WE COME HERE WHEN WE ARE RELEASING A KEY
**********

RELEAS    CMP.B #128+29,D5
          BEQ.S CTRLUP             CONTROL KEY
          CMP.B #128+42,D5
          BEQ.S SHFTUP             LEFT SHIFT KEY
          CMP.B #128+54,D5
          BEQ.S SHFTUP             RIGHT SHIFT KEY
          CMP.B #128+56,D5
          BEQ.S ALTUP              ALTERNATE KEY
          CMP.B #128+58,D5
          BEQ.S CAPSUP             CAPS LOCK KEY
          CMP.B #128+69,D5
          BEQ.S NUMLUP             NUM LOCK KEY
          BRA.L CCRTS              IGNORE ALL OTHERS

* CONTROL KEY RELEASED
CTRLUP    BCLR #2,KBS
          BRA.L CCRTS

* ALTERNATE KEY RELEASED
ALTUP     BCLR #3,KBS
          BRA.L CCRTS

* SHIFT KEY RELEASED
SHFTUP    BCLR #0,KBS
          BRA.L CCRTS

* CAPS LOCK KEY RELEASED
CAPSUP    BCLR #6,KBA
          BRA.L CCRTS

* NUM LOCK KEY RELEASED
NUMLUP    BCLR #5,KBA
          BRA.L CCRTS

* CLONE KEYBOARD TABLE

KEYTAB    DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 0 = NONEXISTEN
          DC.B $1B,$00,$1B,$1B,$00,$1B,$1B,$00,$1B,$FF,$FF,$FF 1 = ESCAPE     
          DC.B $31,$00,$31,$21,$00,$21,$00,$04,$31,$FF,$FF,$FF 2              
          DC.B $32,$00,$32,$40,$00,$40,$00,$01,$00,$FF,$FF,$FF 3              
          DC.B $33,$00,$33,$23,$00,$23,$00,$04,$33,$FF,$FF,$FF 4              
          DC.B $34,$00,$34,$24,$00,$24,$00,$04,$34,$FF,$FF,$FF 5              
          DC.B $35,$00,$35,$25,$00,$25,$00,$04,$35,$FF,$FF,$FF 6              
          DC.B $36,$00,$36,$5E,$00,$5E,$1E,$00,$1E,$FF,$FF,$FF 7              
          DC.B $37,$00,$37,$26,$00,$26,$00,$04,$37,$FF,$FF,$FF 8              
          DC.B $38,$00,$38,$2A,$00,$2A,$00,$04,$38,$FF,$FF,$FF 9              
          DC.B $39,$00,$39,$28,$00,$28,$00,$04,$39,$FF,$FF,$FF 10             
          DC.B $30,$00,$30,$29,$00,$29,$00,$04,$30,$FF,$FF,$FF 11             
          DC.B $2D,$00,$2D,$5F,$00,$5F,$1F,$00,$1F,$FF,$FF,$FF 12             
          DC.B $3D,$00,$3D,$2B,$00,$2B,$00,$04,$3D,$FF,$FF,$FF 13             
          DC.B $08,$00,$08,$08,$00,$08,$7F,$00,$7F,$FF,$FF,$FF 14 = BACKSPACE 
          DC.B $09,$00,$09,$00,$02,$1F,$00,$03,$1F,$FF,$FF,$FF 15 = TAB       
          DC.B $71,$00,$71,$51,$00,$51,$11,$00,$11,$FF,$FF,$FF 16             
          DC.B $77,$00,$77,$57,$00,$57,$17,$00,$17,$FF,$FF,$FF 17             
          DC.B $65,$00,$65,$45,$00,$45,$05,$00,$05,$FF,$FF,$FF 18             
          DC.B $72,$00,$72,$52,$00,$52,$12,$00,$12,$FF,$FF,$FF 19             
          DC.B $74,$00,$74,$54,$00,$54,$14,$00,$14,$FF,$FF,$FF 20             
          DC.B $79,$00,$79,$59,$00,$59,$19,$00,$19,$FF,$FF,$FF 21             
          DC.B $75,$00,$75,$55,$00,$55,$15,$00,$15,$FF,$FF,$FF 22             
          DC.B $69,$00,$69,$49,$00,$49,$09,$00,$09,$FF,$FF,$FF 23             
          DC.B $6F,$00,$6F,$4F,$00,$4F,$0F,$00,$0F,$FF,$FF,$FF 24             
          DC.B $70,$00,$70,$50,$00,$50,$10,$00,$10,$FF,$FF,$FF 25
          DC.B $5B,$00,$5B,$7B,$00,$7B,$1B,$00,$1B,$FF,$FF,$FF 26
          DC.B $5D,$00,$5D,$7D,$00,$7D,$1D,$00,$1D,$FF,$FF,$FF 27
          DC.B $0D,$00,$0D,$0D,$00,$0D,$0D,$00,$0D,$FF,$FF,$FF 28 = RETURN    
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 29 = CONTROL   
          DC.B $61,$00,$61,$41,$00,$41,$01,$00,$01,$FF,$FF,$FF 30             
          DC.B $73,$00,$73,$53,$00,$53,$13,$00,$13,$FF,$FF,$FF 31             
          DC.B $64,$00,$64,$44,$00,$44,$04,$00,$04,$FF,$FF,$FF 32             
          DC.B $66,$00,$66,$46,$00,$46,$06,$00,$06,$FF,$FF,$FF 33             
          DC.B $67,$00,$67,$47,$00,$47,$07,$00,$07,$FF,$FF,$FF 34             
          DC.B $68,$00,$68,$48,$00,$48,$08,$00,$08,$FF,$FF,$FF 35             
          DC.B $6A,$00,$6A,$4A,$00,$4A,$0A,$00,$0A,$FF,$FF,$FF 36             
          DC.B $6B,$00,$6B,$4B,$00,$4B,$0B,$00,$0B,$FF,$FF,$FF 37             
          DC.B $6C,$00,$6C,$4C,$00,$4C,$0C,$00,$0C,$FF,$FF,$FF 38             
          DC.B $3B,$00,$3B,$3A,$00,$3A,$00,$04,$3B,$FF,$FF,$FF 39             
          DC.B $27,$00,$27,$22,$00,$22,$00,$04,$27,$FF,$FF,$FF 40             
          DC.B $60,$00,$60,$7E,$00,$7E,$00,$04,$60,$FF,$FF,$FF 41             
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 42 = LEFT SHIF 
          DC.B $5C,$00,$5C,$7C,$00,$7C,$1C,$00,$1C,$FF,$FF,$FF 43             
          DC.B $7A,$00,$7A,$5A,$00,$5A,$1A,$00,$1A,$FF,$FF,$FF 44
          DC.B $78,$00,$78,$58,$00,$58,$18,$00,$18,$FF,$FF,$FF 45
          DC.B $63,$00,$63,$43,$00,$43,$03,$00,$03,$FF,$FF,$FF 46
          DC.B $76,$00,$76,$56,$00,$56,$16,$00,$16,$FF,$FF,$FF 47
          DC.B $62,$00,$62,$42,$00,$42,$02,$00,$02,$FF,$FF,$FF 48
          DC.B $6E,$00,$6E,$4E,$00,$4E,$0E,$00,$0E,$FF,$FF,$FF 49
          DC.B $6D,$00,$6D,$4D,$00,$4D,$0D,$00,$0D,$FF,$FF,$FF 50
          DC.B $2C,$00,$2C,$3C,$00,$3C,$00,$04,$2C,$FF,$FF,$FF 51
          DC.B $2E,$00,$2E,$3E,$00,$3E,$00,$04,$2E,$FF,$FF,$FF 52
          DC.B $2F,$00,$2F,$3F,$00,$3F,$00,$04,$2F,$FF,$FF,$FF 53
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 54 = RIGHT SHI
          DC.B $2A,$01,$1D,$2A,$00,$2A,$00,$03,$1D,$2A,$00,$2A 55 = PRT SCR *
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 56 = ALT       
          DC.B $20,$00,$20,$20,$00,$20,$20,$00,$20,$FF,$FF,$FF 57 = SPACE     
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 58 = CAPS LOCK 
          DC.B $00,$01,$01,$00,$02,$01,$00,$03,$01,$FF,$FF,$FF 59 = F1        
          DC.B $00,$01,$02,$00,$02,$02,$00,$03,$02,$FF,$FF,$FF 60 = F2        
          DC.B $00,$01,$03,$00,$02,$03,$00,$03,$03,$FF,$FF,$FF 61 = F3        
          DC.B $00,$01,$04,$00,$02,$04,$00,$03,$04,$FF,$FF,$FF 62 = F4        
          DC.B $00,$01,$05,$00,$02,$05,$00,$03,$05,$FF,$FF,$FF 63 = F5        
          DC.B $00,$01,$06,$00,$02,$06,$00,$03,$06,$FF,$FF,$FF 64 = F6        
          DC.B $00,$01,$07,$00,$02,$07,$00,$03,$07,$FF,$FF,$FF 65 = F7        
          DC.B $00,$01,$08,$00,$02,$08,$00,$03,$08,$FF,$FF,$FF 66 = F8        
          DC.B $00,$01,$09,$00,$02,$09,$00,$03,$09,$FF,$FF,$FF 67 = F9        
          DC.B $00,$01,$0A,$00,$02,$0A,$00,$03,$0A,$FF,$FF,$FF 68 = F10       
          DC.B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00 69 = NUM LOCK  
          DC.B $00,$01,$1E,$00,$02,$1E,$00,$03,$1E,$FF,$FF,$FF 70 = SCROLL LO 
          DC.B $00,$01,$20,$37,$00,$37,$00,$03,$20,$37,$00,$37 71 = HOME      
          DC.B $0B,$01,$25,$38,$00,$38,$00,$03,$25,$38,$00,$38 72 = UP ARROW
          DC.B $00,$01,$23,$39,$00,$39,$00,$03,$23,$39,$00,$39 73 = PG UP
          DC.B $2D,$00,$2D,$2D,$00,$2D,$00,$03,$2D,$2D,$00,$2D 74 = GREY MINU
          DC.B $08,$01,$28,$34,$00,$34,$00,$03,$28,$34,$00,$34 75 = LEFT ARRO
          DC.B $00,$01,$27,$35,$00,$35,$00,$03,$27,$35,$00,$35 76 = 5
          DC.B $09,$01,$26,$36,$00,$36,$00,$03,$26,$36,$00,$36 77 = RIGHT ARR
          DC.B $2B,$00,$2B,$2B,$00,$2B,$00,$03,$3B,$2B,$00,$2B 78 = GREY PLUS
          DC.B $00,$01,$22,$31,$00,$31,$00,$03,$22,$31,$00,$31 79 = END
          DC.B $0A,$01,$27,$32,$00,$32,$00,$03,$27,$32,$00,$32 80 = DOWN ARRO
          DC.B $00,$01,$24,$33,$00,$33,$00,$03,$24,$33,$00,$33 81 = PG DN     
          DC.B $00,$01,$2A,$30,$00,$30,$00,$03,$2A,$30,$00,$30 82 = INSERT
          DC.B $00,$01,$2B,$2E,$00,$2E,$00,$03,$2B,$2E,$00,$2E 83 = DELETE

***********************************************************
* INCHEK - CHECK FOR CHAR IN CURRENT INPUT PORT
***********************************************************

INCHEK    BTST #0,STATSI           CHECK STATUS
          BNE.S INCHE0             SERIAL IF BIT0=1
          TST.B INQFLG             ELSE CHECK CLONE KEYBOARD
          RTS                      AND RETURN

***********************************************************
* ICCHEK - CHECK FOR CHAR IN CURRENT ICNTRL PORT. FOR A
* SERIAL KEYBOARD, THIS DEFAULTS TO NORMAL SERIAL DRIVER
***********************************************************

ICCHEK    BTST #0,STATSI           CHECK STATUS
          BNE.S INCHE0             SERIAL IF BIT0=1
          TST.B ICTFLG             ELSE CHECK CLONE ICNTRL
          RTS                      AND RETURN

***********************************************************
* INCHE0 - CHECK FOR CHAR IN SERIAL PORT
***********************************************************

INCHE0    MOVEM.L A6-A6,-(A7)
          MOVE.L PORADM,A6         POINT TO PORT
          BTST #0,DSTATA(A6)       CHECK RDRF FLAG
          MOVEM.L (A7)+,A6-A6
          RTS                      AND RETURN WITH IT

***********************************************************
* GET 8-BIT CHARACTER FROM KEYBOARD INTO D5
***********************************************************

INCH8     BTST #0,STATSI           CHECK STATUS
          BNE.L INCH8S             SERIAL IF BIT0=1
* POSITION CURSOR IF A VIDEO BOARD EXISTS
          BTST     #5,STATSO       CHECK FOR MONO BOARD
          BEQ.S    NOBCUR          NO BW CURSOR
          BSR.S    DOBCUR          YES, GO MOVE IT
NOBCUR    BTST     #4,STATSO       CHECK FOR COLOR BOARD
          BEQ.S    INCH8C          NO COLOR CURSOR
          BSR.S    DOCCUR          YES, GO MOVE IT
INCH8C    TST.B INQFLG             THEN CHECK CLONE KEYBOARD
          BEQ.S INCH8C             WAIT IF NOTHING THERE
          MOVE.B INQCHR,D5         THEN GET CHARACTER
          CLR.B INQFLG             CLEAR FLAGS
          CLR.B ICTFLG
          RTS                      AND RETURN
DOBCUR    MOVEM.L D6-D7,-(A7)      PUSH
          BRA.L    MRTS            AND GO DO IT
DOCCUR    MOVEM.L D6-D7,-(A7)      PUSH
          BRA.L    CRTS            AND GO DO IT

***********************************************************
* GET 8-BIT CHARACTER FROM ICNTRL KEYBOARD INTO D5. IF A
* SERIAL KEYBORD IS BEING USED, THEN THIS DEFAULTS TO IT
***********************************************************

ICTRNL    BTST #0,STATSI           CHECK STATUS
          BNE.L INCH8S             SERIAL IF BIT0=1
* POSITION CURSOR IF A VIDEO BOARD EXISTS
          BTST     #5,STATSO       CHECK FOR MONO BOARD
          BEQ.S    NCBCUR          NO BW CURSOR
          BSR.S    DCBCUR          YES, GO MOVE IT
NCBCUR    BTST     #4,STATSO       CHECK FOR COLOR BOARD
          BEQ.S    ICNTRC          NO COLOR CURSOR
          BSR.S    DCCCUR          YES, GO MOVE IT
ICNTRC    TST.B ICTFLG             THEN CHECK CLONE KEYBOARD
          BEQ.S ICNTRC             WAIT IF NOTHING THERE
          MOVE.W ICTCHR,D5         THEN GET CHARACTER
          CLR.B INQFLG             CLEAR FLAGS
          CLR.B ICTFLG
          RTS                      AND RETURN
DCBCUR    MOVEM.L D6-D7,-(A7)      PUSH
          BRA.L    MRTS            AND GO DO IT
DCCCUR    MOVEM.L D6-D7,-(A7)      PUSH
          BRA.L    CRTS            AND GO DO IT

***********************************************************
* GET 8-BIT CHARACTER FROM SERIAL PORT
***********************************************************

INCH8S    MOVEM.L A6-A6,-(A7)
          MOVE.L PORADM,A6         POINT TO PORT
INCH8A    BTST #0,DSTATA(A6)       CHECK STATUS OF PORT
          BEQ.S INCH8A             WAIT IF NOTHING
          MOVE.B DDATAA(A6),D5     ELSE GET CHARACTER
          MOVEM.L (A7)+,A6-A6
          RTS

***********************************************************
* OUTPUT ON PRINTER (PORT P)
***********************************************************

OUTCHP    MOVEM.L A6-A6,-(A7)
          MOVE.L PORADP,A6         OUTPUT TO PORT P
* LINE DELETED HERE BY >>D<<
          BRA.S OUTCHE

***********************************************************
* OUTPUT ON CONTROL PORT (MAIN CONSOLE)
***********************************************************

OUTCHM    MOVEM.L A6-A6,-(A7)
          MOVE.L PORADM,A6         POINT TO MAIN PORT
OUTCHE    BTST #2,DSTATA(A6)       CHECK TDRE
          BEQ.S OUTCHE             WAIT UNTIL READY
          MOVE.B D4,DDATAA(A6)     PRINT IT
          MOVEM.L (A7)+,A6-A6
          RTS

***********************************************************
* OUTPUT ON MONOCHROME VIDEO BOARD
***********************************************************

OUTCHB    MOVEM.L D6-D7,-(A7)
          CMP.B #8,D4              BACKSPACE?
          BEQ.L BS
          CMP.B #$0D,D4            CARRIAGE RETURN?
          BEQ.L CR
          CMP.B #$0A,D4            LINE FEED?
          BEQ.S LF
          CMP.B #$1A,D4            CLEAR SCREEN?
          BEQ.L CLRSCR
          CMP.B #$07,D4            BELL?
          BEQ.L BELL
          CMP.B #$0B,D4            VERT TAB?
          BEQ.L VT
          CMP.B #$0C,D4            NON-DESTRUCTIVE SPACE?
          BEQ.S FF
          CMP.B #$7F,D4            RUBOUT?
          BEQ.L MRTS

* IT'S EITHER CONTROL, NORMAL, OR >127
          MOVE.B D4,D7
          AND.B #$60,D7            CONTROL OR MINUS?
          BEQ.L MRTS               YES, DON'T DO

* NOW DO NORMAL CHARACTER
          CLR.L D7
          MOVE.B MCURH,D7
          MOVE.W D7,-(A7)          PUSH CURH ON STACK
          MOVE.B MCURV,D7          NOW COMPUTE VIDRAM LOC
          MULU #80,D7
          ADD.W (A7)+,D7           POS ON SCREEN
          ASL.L #2,D7              *4
          ADD.L #BNWRAM+1,D7       FINALLY THE ADDRESS
          MOVE.L D7,A6             POINT TO IT
          MOVE.B D4,(A6)           DISPLAY CHAR ON SCREEN
          MOVE.B MATTR,D7
          MOVE.B D7,2(A6)          AND ALSO ATTRIBUTE
FF        ADD.B #1,MCURH           MOVE CURSOR RIGHT
          MOVE.B MCURH,D7
          CMP.B #79,D7             END OF LINE?
          BLE.S MRTS               NO
          CLR.B MCURH              YES, GO TO BEG OF NEXT
LF        MOVE.B MCURV,D7          GET VERTICAL POSITON
          CMP.B #24,D7             BOTTOM OF SCREEN?
          BEQ.S SCROLL             YES, SO GO SCROLL
* NOT YET AT BOTTOM
          ADD.B #1,MCURV           MOVE CURSOR DOWN 1
* TWO EXITS: MRTS IF CURSOR MOVES, MRTS1 IF IT DOESN'T
MRTS      CLR.L D6
          MOVE.B MCURH,D6
          CLR.L D7
          MOVE.B MCURV,D7          NOW COMPUTE VIDRAM LOC
          MULU #80,D7
          ADD.W D7,D6              POS ON SCREEN
          MOVE.B #15,BNWADD
          MOVE.B D6,BNWADD+2       LSB OF CURSOR ADDRESS
          LSR.W #8,D6
          MOVE.B #14,BNWADD
          MOVE.B D6,BNWADD+2       MSB OF CURSOR ADDRESS
          MOVE.B #10,BNWADD
          MOVE.B MCURSZ,D6
          MOVE.B D6,BNWADD+2       TURN ON CURSOR
MRTS1     MOVEM.L (A7)+,D6-D7
          RTS                      AND RETURN

* ONCE AT BOTTOM, SCROLL
SCROLL    LEA BNWRAM,A6            POINT TO TOP OF SCREEN RAM
          MOVE.W #239,D7           DO (24*80)/8=240 TIMES
SCRO1     MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+     MOVE UP 4 CHARACTERS
          MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+
          MOVE.L 320(A6),(A6)+
          DBRA D7,SCRO1

* FINALLY, ERASE BOTTOM LINE
          MOVE.L #79,D7            ERASE 80 CHARACTERS
          MOVE.L A5,-(A7)
          LEA BNWRAM+7680,A5       POINT TO BOTTOM LINE
          MOVE.L #$00200000,D6     SPACE
          MOVE.B MATTR,D6          AND ATTRIBUTE
ERBOTL    MOVE.L D6,(A5)+          STORE IT
          DBRA D7,ERBOTL           REPEAT
          CLR.B MCURH               SET UP CURSOR POSITION
          MOVE.B #24,MCURV          AT BEG OF LAST LINE
          MOVE.L (A7)+,A5
          BRA.L MRTS

* DO BACKSPACE
BS        TST.B MCURH               POSITION
          BEQ.L MRTS1              IGNORE IF AT BEG OF LINE
          SUB.B #1,MCURH            ELSE MOVE CURSOR LEFT 1
          BRA.L MRTS

* DO VERTICAL TAB
VT        TST.B MCURV               POSITION
          BEQ.L MRTS1              IGNORE IF AT TOP OF SCREEN
          SUB.B #1,MCURV            ELSE MOVE UP 1 LINE
          BRA.L MRTS

* CARRIAGE RETURN
CR        CLR.B MCURH
          BRA.L MRTS

* ERASE THE SCREEN. THIS ROUTINE STORES 00'S INTO UNUSED
* EVEN) BYTES OF VIDEO MEMORY, BUT THIS SHOULD BE OK - THEY
* DON'T GO ANYWHERE

CLRSCR    MOVE.L #1999,D7          ERASE (25X80) CHARS
          MOVE.L A5,-(A7)
          LEA BNWRAM,A5            POINT TO SCREEN RAM
          MOVE.L #$00200000,D6     SPACE
          MOVE.B MATTR,D6          AND ATTRIBUTE
CLSLOO    MOVE.L D6,(A5)+
          DBRA D7,CLSLOO           REPEAT
          CLR.B MCURH              SET UP CURSOR POSITION
          CLR.B MCURV              AT TOP LEFT OF SCREEN
          MOVE.L (A7)+,A5
          BRA.L MRTS

* RING BELL
BELL      MOVE.B #$04,DUART1+DCTUPR
          MOVE.B #$55,DUART1+DCTLOW SET TONE FREQUENCY
          MOVE.B #$04,DUART1+DOPORT TURN ON CTR/TMR OUTPUT ON OP3
          MOVE.W #$6000,D7
BELOOP    MULU #1,D7               WAIT A BIT
          DBRA D7,BELOOP
          MOVE.B #$00,DUART1+DOPORT TURN OFF CTR/TMR OUTPUT
          BRA.L MRTS1

***********************************************************
* OUTPUT ON COLOR VIDEO BOARD
***********************************************************

OUTCHC    MOVEM.L D6-D7,-(A7)
          CMP.B #8,D4              BACKSPACE?
          BEQ.L CBS
          CMP.B #$0D,D4            CARRIAGE RETURN?
          BEQ.L COLRCR
          CMP.B #$0A,D4            LINE FEED?
          BEQ.L CLF
          CMP.B #$1A,D4            CLEAR SCREEN?
          BEQ.L CCLRSC
          CMP.B #$07,D4            BELL?
          BEQ.L CBELL
          CMP.B #$0B,D4            VERT TAB?
          BEQ.L CVT
          CMP.B #$0C,D4            NON-DESTRUCTIVE SPACE?
          BEQ.S CFF
          CMP.B #$7F,D4            RUBOUT?
          BEQ.L CRTS

* IT'S EITHER CONTROL, NORMAL, OR >127
          MOVE.B D4,D7
          AND.B #$60,D7            CONTROL OR MINUS?
          BEQ.L CRTS                YES, DON'T DO

* NOW DO NORMAL CHARACTER
          CLR.L D7
          MOVE.B CCURH,D7
          MOVE.W D7,-(A7)          PUSH CURH ON STACK
          MOVE.B CCURV,D7          NOW COMPUTE VIDRAM LOC
          MULU #80,D7
          ADD.W (A7)+,D7           POS ON SCREEN
          ASL.L #2,D7              *4
          ADD.L #COLRAM+1,D7       FINALLY THE ADDRESS
          MOVE.L D7,A6             POINT TO IT
          MOVE.B CATTR,D7
          BTST #3,STATSO           CHECK IF FAST OR SLOW
          BNE.S W1                 1=SLOW
* DO THIS SECTION IF DOING FAST ACCESS WITH SNOW
          MOVE.B D4,(A6)           DISPLAY CHAR ON SCREEN
          BRA.S NORCON
* DO THIS SECTION IF DOING SLOW ACCESS FOR NO SNOW
W1        BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.S W1                 NO
          MOVE.B D4,(A6)           DISPLAY CHAR ON SCREEN
W2        BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.L W2                 NO
* AND NOW CONTINUE
NORCON    MOVE.B D7,2(A6)          AND ALSO ATTRIBUTE
CFF       ADD.B #1,CCURH           MOVE CURSOR RIGHT
          MOVE.B CCURH,D7
          CMP.B #79,D7             END OF LINE?
          BLE.S CRTS               NO
          CLR.B CCURH              YES, GO TO BEG OF NEXT
CLF       MOVE.B CCURV,D7          GET VERTICAL POSITON
          CMP.B #24,D7             BOTTOM OF SCREEN?
          BEQ.S CSCROL             YES, SO GO SCROLL
* NOT YET AT BOTTOM
          ADD.B #1,CCURV           MOVE CURSOR DOWN 1
* TWO EXITS: CRTS IF CURSOR MOVES, CRTS1 IF IT DOESN'T
CRTS      CLR.L D6
          MOVE.B CCURH,D6
          CLR.L D7
          MOVE.B CCURV,D7          NOW COMPUTE VIDRAM LOC
          MULU #80,D7
          ADD.W D7,D6              POS ON SCREEN
          MOVE.B #15,COLADD
          MOVE.B D6,COLADD+2       LSB OF CURSOR ADDRESS
          LSR.W #8,D6
          MOVE.B #14,COLADD
          MOVE.B D6,COLADD+2       MSB OF CURSOR ADDRESS
          MOVE.B #10,COLADD
          MOVE.B CCURSZ,D6
          MOVE.B D6,COLADD+2       TURN ON CURSOR
CRTS1     MOVEM.L (A7)+,D6-D7
          RTS                      AND RETURN

* ONCE AT BOTTOM, SCROLL
CSCROL    LEA COLRAM,A6            POINT TO TOP OF SCREEN RAM
          MOVE.W #1919,D7          DO (24*80)/8 TIMES
          BTST #3,STATSO           CHECK IF FAST OR SLOW
          BNE.S CSCRO1             1=SLOW
* DO THIS SECTION IF DOING FAST ACCESS WITH SNOW
CSCRO0    MOVE.L 320(A6),(A6)+
          DBRA D7,CSCRO0
          BRA.S CSRCON
* DO THIS SECTION IF DOING SLOW ACCESS FOR NO SNOW
CSCRO1    BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.S CSCRO1             NO
          MOVE.L 320(A6),D6
W3        BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.S W3                 NO
          MOVE.L D6,(A6)+
          DBRA D7,CSCRO1
* AND NOW CONTINUE

* FINALLY, ERASE BOTTOM LINE
CSRCON    MOVE.L #79,D7            ERASE 80 CHARACTERS
          MOVE.L A5,-(A7)
          LEA COLRAM+7680,A5       POINT TO BOTTOM LINE
          MOVE.L #$00200000,D6     SPACE
          MOVE.B CATTR,D6          AND ATTRIBUTE
          BTST #3,STATSO           CHECK IF FAST OR SLOW
          BNE.S CERBOT             1=SLOW
* DO THIS SECTION IF DOING FAST ACCESS WITH SNOW
CERBO0    MOVE.L D6,(A5)+          STORE IT
          DBRA D7,CERBO0           REPEAT
          BRA.S CONCER
* DO THIS SECTION IF DOING SLOW ACCESS FOR NO SNOW
CERBOT    BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.S CERBOT             NO
          MOVE.L D6,(A5)+          STORE IT
          DBRA D7,CERBOT           REPEAT
CONCER    CLR.B CCURH              SET UP CURSOR POSITION
          MOVE.B #24,CCURV         AT BEG OF LAST LINE
          MOVE.L (A7)+,A5
          BRA.L CRTS

* DO BACKSPACE
CBS       TST.B CCURH               POSITION
          BEQ.L CRTS1               IGNORE IF AT BEG OF LINE
          SUB.B #1,CCURH            ELSE MOVE CURSOR LEFT 1
          BRA.L CRTS

* DO VERTICAL TAB
CVT       TST.B CCURV               POSITION
          BEQ.L CRTS1               IGNORE IF AT TOP OF SCREEN
          SUB.B #1,CCURV            ELSE MOVE UP 1 LINE
          BRA.L CRTS

* CARRIAGE RETURN
COLRCR    CLR.B CCURH
          BRA.L CRTS

* ERASE THE SCREEN. THIS ROUTINE STORES 00'S INTO UNUSED
* EVEN) BYTES OF VIDEO MEMORY, BUT THIS SHOULD BE OK - THEY
* DON'T GO ANYWHERE

CCLRSC    MOVE.L #1999,D7          ERASE (25X80) CHARS
          MOVE.L A5,-(A7)
          LEA COLRAM,A5            POINT TO SCREEN RAM
          MOVE.L #$00200000,D6     SPACE
          MOVE.B CATTR,D6          AND ATTRIBUTE
          BTST #3,STATSO           CHECK IF FAST OR SLOW
          BNE.S CCLSLO             1=SLOW
* DO THIS SECTION IF DOING FAST ACCESS WITH SNOW
CCLFAS    MOVE.L D6,(A5)+
          DBRA D7,CCLFAS           REPEAT
          BRA.S CCLCON
* DO THIS SECTION IF DOING SLOW ACCESS FOR NO SNOW
CCLSLO    BTST #0,COSTAT           CHECK IF OK TO ACCESS
          BEQ.S CCLSLO             NO
          MOVE.L D6,(A5)+
          DBRA D7,CCLSLO           REPEAT
* NOW CONTINUE
CCLCON    CLR.B CCURH              SET UP CURSOR POSITION
          CLR.B CCURV              AT TOP LEFT OF SCREEN
          MOVE.L (A7)+,A5
          BRA.L CRTS

* RING BELL
CBELL     MOVE.B #$04,DUART1+DCTUPR
          MOVE.B #$55,DUART1+DCTLOW SET TONE FREQUENCY
          MOVE.B #$04,DUART1+DOPORT TURN ON CTR/TMR OUTPUT ON OP3
          MOVE.W #$6000,D7
CBLLOO    MULU #1,D7               WAIT A BIT
          DBRA D7,CBLLOO
          MOVE.B #$00,DUART1+DOPORT TURN OFF CTR/TMR OUTPUT
          BRA.L CRTS1

*******************************************************
* 'FD - BOOT SK*DOS FROM FLOPPY DISK
*******************************************************

* DECIDE WHICH CONTROLLER IT IS
FLBOOT    MOVE.B FL0C,D3
          CMP.B #$37,D3            CHECK FOR 3765
          BEQ.L FB3765             OK, BOOT FROM 3765
          CMP.B #$17,D3            CHECK FOR 1772
          BEQ.S FB1772             OK, BOOT FROM 1772
FLBEIS    LEA MISMSG(PC),A4
          JSR PSTRNG               PRINT "MUST IS FIRST
          JMP NXTCMD
MISMSG    FCC 'You must do an initial setup with the IS command first.'
          DC.B $D,$A,4

****************** 1772 ROUTINE ********************

DLATCH    EQU $FE00C1
* EXPLANATION OF DLATCH OPERATION:
*           BITS 0 & 1 SELECT DRIVE 0-3 >>C<<
*           BITS 2 - 4 - NOT USED
*           BIT 5 SELECTS DENSITY (0 = DD)
*           BIT 6 - SELECTS SIDE (O = SIDE A)
*           BIT 7 - NOT USED
*
COMREG    EQU $FE0101
STAREG    EQU COMREG
TRKREG    EQU COMREG+2
SECREG    EQU COMREG+4
DATREG    EQU COMREG+6

FB1772    MOVE.B #4,D3             RETRY COUNTER
          MOVE.B #$20,D2           DD, DRIVE 0 >>C<<
PRLOOP    MOVE.B D2,DLATCH         SELECT DRIVE, MOTOR, DENSITY
          EOR.B #$20,D2            CHANGE DENSITY FOR NEXT TRY
          BSR.L WAIT
* FOLLOWING LINE IS 01 FOR 1772, 03 FOR OTHER WESTERN DIGITAL FDC'S
          MOVE.B #$01,COMREG       RESTORE, LOAD, SLOW STEP >>A<<
          BSR.L WNBUSY             WAIT UNTIL NOT BUSY
          MOVE.B #0,TRKREG         TRACK 0
          BSR.L WAIT
          MOVE.B #1,SECREG         SECTOR 1
          BSR.L WAIT

          MOVE.L #$0800,A5         WHERE TO LOAD THE SECTOR
* ASSUME INTERRUPTS ARE PROPERLY SET
          MOVE.W SR,D4             SAVE IRQ LEVEL
          OR.W #$0700,SR
          LEA STAREG,A6            POINT A6 TO STATUS REG
          LEA DATREG,A4            POINT A4 TO DATA REG
          MOVE.B #$84,COMREG       READ COMMAND
          BSR WAIT                 WAIT FOR FDC TO SETTLE
          BRA.S RDLOOP             REPEAT UNTIL DONE

RDBYTE    MOVE.B (A4),(A5)+        GET DATA BYTE
RDLOOP    MOVE.B (A6),D6           CHECK STATUS
          BTST.B #1,D6             DRQ?
          BNE.S RDBYTE             YES
          BTST.B #0,D6             BUSY?
          BNE.S RDLOOP             YES, SO WAIT

          MOVE.W D4,SR             RESTORE IRQ LEVEL
          AND.B #$1C,D6            NR, RNF, CRC, OR LOST DATA?
          BEQ.S FDEXIT             EXIT NORMALLY IF NO ERROR
          SUB.B #1,D3              DECR RETRY COUNTER
          BNE.S PRLOOP             ELSE TRY AGAIN WHEN NOT DONE
          LEA EBDMSG,A4
          JSR PSTRNG               THEN PRINT ERROR MESSAGE
          JMP WARMST               AND QUIT
FDEXIT    JMP $0800                GO TO SUPER-BOOT
EBDMSG    FCC 'ERROR BOOTING DOS.',4

* WAIT - WAIT ROUTINE TO WAIT A WHILE

WAIT      BSR.S WAIT8
          NOP
WAIT8     BSR.S WAIT4
          NOP
WAIT4     BSR.S WAIT2
          NOP
WAIT2     BSR.S WAIT1
          NOP
WAIT1     RTS                      RTS

* WNBUSY

WNBUSY    BSR.S WAIT               WAIT FOR COMMAND TO SETTLE
          MOVE.B STAREG,D6         GET STATUS
          BTST.B #0,D6             CHECK BUSY FLAG
          BNE.S WNBUSY             WAIT IF STILL BUSY
          RTS                      ELSE RETURN WITH B=STATUS

**************** 37C65 BOOT ROUTINE *******************

* SK*DOS EQUATES

DRUSED    EQU $113C                DRIVE USED TABLE

* CONTROLLER EQUATES

REGOPER   EQU $FA07E5              OPERATIONS REGISTER
REGSTAT   EQU REGOPER+4            MAIN STATUS REGISTER
REGDATA   EQU REGOPER+6            DATA REGISTER
REGCONT   EQU REGOPER+10           CONTROL REGISTER

* REGISTER USAGE FOR 37C65 DISK DRIVERS ONLY

* D0 UNIT NUMBER
* D3 TEMP IN RESTORE
* D4 IRQ FLAG FOR SENDIT
* D5 NUMBER OF BYTES FOR SENDIT
* D5 =1 IF NOT TRACK 0 IN SETCOM

* DRIVE PARAMETER AREA. FOR EACH KIND OF DRIVE, WE STORE THE
* FOLLOWING DATA:


DN        EQU 0                    N
DTL       EQU 1                    DTL DATA LENGTH
DBPS      EQU 2                    BPS CODE FOR CONTROL REG
D0MF      EQU 3                    MF BIT FOR TRACK 0
DAMF      EQU 4                    MF BIT FOR OTHER TRACKS
D0SECT    EQU 5                    SECTORS PER TRACK 0
DASECT    EQU 6                    SECTORS ON OTHER TRACKS
D0FGAP    EQU 7                    TRK 0 FMT GAP 3
DAFGAP    EQU 8                    OTHER TRK FORMAT GAP 3
D0GAP     EQU 9                    TRK 0 R/W GAP 3
DAGAP     EQU 10                   OTHER TRK R/W GAP 3
D0SIDB    EQU 11                   TRK 0 SEC NUM SUB FOR SIDE B
DASIDB    EQU 12                   OTHER TRK SEC NUM SUB FOR B
DDUBL     EQU 13                   DOUBLE-STEP FLAG

* THERE ARE 16 BYTES FOR EACH; THE LAST 2 ARE ZERO

* 360K DRIVE 40-TRACK DRIVE
TYPEB     DC.B 1,$FF,2,1,1,18,18,12,12,10,10,00,00,0,0,0 DD ALL
          DC.B 1,$FF,2,0,0,10,10,14,14,08,08,00,00,0,0,0 SD ALL
          DC.B 1,$FF,2,0,1,10,18,14,12,08,10,00,00,0,0,0 0 SD, DD ALL
          DC.B 2,$FF,2,1,1,09,09,80,80,42,42,09,09,0,0,0 IBM 360
* 720K 80-TRACK DRIVE
TYPEC     DC.B 1,$FF,2,1,1,18,18,12,12,10,10,00,00,0,0,0 80 TR DD
          DC.B 1,$FF,2,1,1,18,18,12,12,10,10,00,00,1,0,0 40 TR DD
          DC.B 1,$FF,2,0,0,10,10,14,14,08,08,00,00,1,0,0 40 TR SD
          DC.B 2,$FF,2,1,1,09,09,80,80,42,42,09,09,1,0,0 IBM 360
* 1.1 MEG 5-1/4" DRIVE
TYPED     DC.B 1,$FF,0,1,1,28,28,40,40,20,20,28,28,0,0,0 80 TR HD
          DC.B 1,$FF,1,1,1,18,18,12,12,10,10,00,00,0,0,0 80 TR DD
          DC.B 1,$FF,1,1,1,18,18,12,12,10,10,00,00,1,0,0 40 TR DD
          DC.B 2,$FF,0,1,1,15,15,80,80,42,42,15,15,0,0,0 IBM 1.2
* 1.4 MEG 3-1/2" DRIVE
TYPEE     DC.B 1,$FF,0,1,1,34,34,40,40,27,27,34,34,0,0,0 80 TR HD
          DC.B 1,$FF,2,1,1,18,18,12,12,10,10,00,00,0,0,0 80 TR DD
          DC.B 2,$FF,2,1,1,09,09,80,80,42,42,09,09,0,0,0 IBM 720
          DC.B 2,$FF,0,1,1,18,18,84,84,27,27,18,18,0,0,0 IBM 1.44
* 8" 1 MEG DRIVE
TYPEF     DC.B 1,$FF,0,1,1,26,26,54,54,14,14,00,00,0,0,0 77 TR DD
          DC.B 1,$FF,0,1,1,26,26,54,54,14,14,00,00,0,0,0 DUPLICATE
          DC.B 1,$FF,0,0,1,15,26,42,54,14,14,00,00,0,0,0 SD 0 ELSE DD
          DC.B 1,$FF,0,0,0,15,15,42,42,14,14,00,00,0,0,0 77 TR SD

**********************************
* INITIALIZE
**********************************

* FIRST GET DATA TO FILL DRIVE AND DISK TABLES

FB3765    CLR.L D7
          MOVE.B FL0D,D7           GET INFO FOR F0 BOOT DRIVE
          BEQ.L FLBEIS
          AND.B #$F,D7             AND DRIVE TYPE
          MOVE.B D7,DRTYPE         PUT IN DRIVE TYPE
          LSL.W #6,D7              X64
          MOVE.B #0,DSKSEQ         INITIALLY SEQUENCE NO=0
          LEA TYPEB-64,A6          POINT TO FORMAT TABLES
          LEA 0(A6,D7),A6          FORMAT TABLE FOR THIS DRIVE
          MOVE.L A6,DRVPTR
          MOVE.L (A6),DRVDAT
          MOVE.L 4(A6),DRVDAT+4    COPY OVER 1 LINE FROM TABLE
          MOVE.L 8(A6),DRVDAT+8
          MOVE.L 12(A6),DRVDAT+12
          MOVE.B #$FF,PRETRK       FORCES INITIAL RESTORE

* NEXT INITIALIZE THE CONTROLLER

          MOVE.B #$34,REGOPER      MOTORS ON, NO SOFT RESET: AT MODE
          MOVE.B #0,REGCONT        SET TO 250/500 KBPS
          MOVE.B #$03,COMMAND      SPECIFY COMMAND
          MOVE.B #$4F,COMMAND+1    STEP=12,UNLOAD TIME = MAX
          MOVE.B #$7F,COMMAND+2    HEAD LOAD=126, NON-DMA MODE
          MOVE.W #3,D5             THREE BYTES TO SEND
          MOVE.B #0,D4             DON'T TURN OFF IRQ
          BSR.L SENDIT             SEND COMMAND TO 3765
          BNE.L D7RROR             ON ERROR, QUIT

* NOW SEARCH DISK DIRECTORY FOR SK*DOS.SYS

          MOVE.L #$0005,D0         DIRECTORY START DISK ADDRESS
DI7EAD    BSR.L D7READ             READ DIRECTORY SECTOR
          BNE.L D7RROR
          LEA DBUFFR,A0            BACK TO DIRECTORY BUFFER
          LEA 256(A0),A6           END OF BUFFER
          LEA 16(A0),A0            FIRST DIR ENTRY
D7RLOO    TST.B (A0)               CHECK FIRST BYTE OF ENTRY
          BMI.S ND7DIR             DELETED ENTRY
          BEQ.L D7RROR             END OF DIRECTORY
          MOVE.L (A0),D7           FIRST FOUR LETTERS
          CMP.L #$534B2A44,D7      "SK*D" ?
          BNE.S ND7DIR             NO
          MOVE.L 4(A0),D7          NEXT FOUR LETTERS
          CMP.L #$4F530000,D7      "OS.." ?
          BNE.S ND7DIR
          MOVE.L 8(A0),D7          NEXT THREE
          AND.L #$FFFFFF00,D7      BLANK OUT LAST
          CMP.L #$53595300,D7      "SYS" ?
          BEQ.S GOTIT7             GOT IT?

ND7DIR    ADD.L #24,A0             POINT TO NEXT ENTRY
          CMP.L A0,A6              AT END OF SECTOR?
          BNE.S D7RLOO             NO, CONTINUE

          MOVE.W DBUFFR,D0         AT END, GET POINTER TO NEXT
          BEQ.L D7RROR             SK*DOS.SYS NOT FOUND IF AT END
          BRA.S DI7EAD             ELSE LOOK AT NEXT SCTR

* WE HAVE FOUND 'SK*DOS.SYS'

GOTIT7    MOVE.B 13(A0),D0
          LSL.W #8,D0
          MOVE.B 14(A0),D0         GET STARTING DISK ADDRESS
          LEA DBUFFR,A0            POINT BACK TO BUFFER
          MOVE.W D0,(A0)           PUT FIRST ADDRESS INTO IT

* NOW READ THE FILE INTO MEMORY WITHOUT AN OFFSET

          MOVE.L #0,A3             ERASE EXECUTION ADDRESS
          CLR.L D1                 DATA POINTER =0
DET2      BSR.L DETNEW             GET FLAG BYTE
          CMP.B #$02,D5            IS IT 02?
          BEQ.S DETD2O             2-BYTE ADDRESS DATA
          CMP.B #$03,D5            IS IT 03?
          BEQ.S DETD4O             4-BYTE ADDRESS DATA
          CMP.B #$16,D5            IS IT 16?
          BEQ.L DETT2O             2-BYTE TRANSFER
          CMP.B #$17,D5            IS IT 17?
          BEQ.L DETT4O             4-BYTE TRANSFER
          BRA.S DET2               ANYTHING ELSE JUST SKIP

DETD2O    BSR.L DETWRD             GET 2-BYTE LOAD ADDRESS
          MOVE.L D4,A2             PUT INTO A2
          BSR.L DETNEW             GET LENGTH
          MOVE.L D5,D2             SET UP AS COUNTER
          BRA.S DETLOO             THEN CONTINUE

DETD4O    BSR.L DETWRD             GET LEFT WORD OF LOAD ADDRESS
          SWAP D4
          MOVE.L D4,A2             MOVE INTO A2
          BSR.L DETWRD             GET RIGHT WORD OF LOAD ADDRESS
          ADD.L D4,A2              COMBINE TWO WORDS
          BSR.L DETWRD             GET LENGTH
          MOVE.L D4,D2             SET UP AS COUNTER

DETLOO    BSR.L DETNEW             ELSE GET ONE BYTE
          MOVE.B D5,(A2)+          STORE IN MEMORY
          SUB.W #01,D2             DECREMENT COUNTER
          BNE.S DETLOO
          BRA.L DET2               AT END, LOOK FOR NEXT FLAG

DETT4O    BSR.S DETWRD             GET LEFT WORD OF TRANSFER ADDRESS
          SWAP D4                  MOVE INTO LEFT HALF
          MOVE.L D4,A3             SAVE IN A3
          BSR.S DETWRD             GET RIGHT HALF OF ADDR
          ADD.L A3,D4              ADD BACK TOGETHER
          MOVE.L D4,A3             SAVE EXECUTION ADDRESS
          BRA.S DET2

DETT2O    BSR.S DETWRD             GET TRANSFER ADDRESS FROM FILE
          MOVE.L D4,A3             STORE EXECUTION ADDRESS
          BRA.L DET2               AND REPEAT

* DETWRD - GET TWO-BYTE WORD FROM FILE

DETWRD    BSR.S DETNEW             GET MSB BYTE
          MOVE.L D5,D4             SAVE IN D4
          LSL.W #8,D4              MOVE INTO SECOND BYTE
          BSR.S DETNEW             GET LSB
          ADD.W D5,D4              ADD THE TWO BYTES TOGETHER IN D4
DETEXI    RTS

* DETNEW - GET BYTE FROM FILE

DETNEW    TST.B D1                 CHECK POINTER TO DATA
          BEQ.S READD7             ZERO MEANS HAVE TO READ SCTR
DETNW1    CLR.L D5
          MOVE.B 0(A0,D1.W),D5     READ A BYTE
          ADD.B #1,D1              POINT TO NEXT
          RTS

* READD7 - READ A NEW SECTOR FROM 37C65 DISK INTO BUFFER

READD7    LEA DBUFFR,A0            POINT TO BUFFER
          MOVE.W (A0),D0           POINTER TO NEXT
          BEQ.S D7FINI             FINISHED IF 00 POINTER
          BSR.S D7READ             READ NEXT SECTOR
          MOVE.W #4,D1             POINT TO ITS FIRST BYTE
          BRA.S DETNW1             THEN CONTINUE AS ABOVE

* D7FINI - WHEN FINISHED READING, REASSIGN DRIVE NUMBERS,
* AND JUMP TO PROGRAM IF THERE IS A TRANSFER ADDRESS

D7FINI    MOVE.L A3,D7             TRANSFER ADDRESS, IF ANY
          BEQ.L D7RROR             ERROR IF NONE
          MOVE.B #$10,DRUSED       F0  DISK BECOMES DRIVE 0
          MOVE.B #$11,D0           F1 CODE
          LEA FL1C,A0              LOC FOR F1
          MOVE.W #5-1,D1           COUNTER TO 5 TESTS
D7FTST    TST.B (A0)               CHECK FOR AN ENTRY
          BEQ.S D7FAIL
          MOVE.B D0,DRUSED+1
          JMP.L (A3)               THEN JUMP TO SK*DOS
D7FAIL    LEA 4(A0),A0             ELSE UP FOUR
          ADD.B #1,D0
          DBRA D1,D7FTST
          JMP.L (A3)               THEN JUMP TO SK*DOS

* D7READ - READ SECTOR INTO MEMORY. ENTER WITH D0=LOGICAL TR/SEC,
* CAN USE A5 D6

D7READ    MOVEM.L D0-D5/A0-A4,-(A7)
          LEA DRVDAT,A1            POINT TO THIS DRIVE'S DATA
          MOVE.W D0,TRKSEC
          MOVE.B #20,RETRCT        SETUP RETRY COUNTER
RDRETRY   BSR.L SETCOM             SET UP COMMAND BUFFER
          BSR.L SEEK

          MOVE.B MFBIT,D7          MF BIT IN BIT 6
          ADD.B #6,D7              INSERT READ COMMAND
          MOVE.B D7,COMMAND        MF + READ COMMAND
          MOVE.W #9,D5             NINE BYTES TO SEND
          MOVE.B #1,D4             DO TURN OFF IRQ
          BSR.L SENDIT             SEND TO FDC
          LEA REGSTAT,A2           POINT TO STATUS REG
          LEA REGDATA,A3           POINT TO DATA REGISTER
          MOVE.B (A5)+,D7          GET LAST BYTE OF COMMAND
          LEA  DBUFFR,A5           WHERE TO PUT DATA
          MOVE.W SR,D5             SAVE IRQ LEVEL
          OR.W #$0700,SR
          MOVE.B D7,REGDATA        SEND OUT LAST BYTE OF COMMAND
          BSR.L WAIT12
          BRA.S RDMOVE
RDREAD    MOVE.B (A3),(A5)+        MOVE A BYTE
RDMOVE    MOVE.B (A2),D7           STATUS REGISTER
          BPL.S RDMOVE             WAIT FOR RQM
          BTST #5,D7               CHECK IF STILL EXECUTING
          BNE.S RDREAD             NO, SO FINISHED READING

RDDONE    MOVE.W D5,SR             RESTORE INTERRUPTS
          LEA ST0,A5               POINT TO RESULTS BUFFER
RDRESU    BSR.L WAIT12
          MOVE.B REGSTAT,D7        GET STATUS REGISTER
          AND.B #$C0,D7            LOOK AT DIO AND RQM ONLY
          CMP.B #$80,D7            10 MEANS WE'RE FINISHED
          BEQ.S FINRES
          CMP.B #$C0,D7            NEED 11 TO CONTINUE READING
          BNE.S RDRESU
          MOVE.B REGDATA,(A5)+
          BRA.S RDRESU

* FINISHED READING AND TRANSFERRING; CHECK FOR ERRORS
FINRES    MOVE.B ST0,D7            CHECK STATUS REG 0
          AND.B #$D8,D7            CHECK BITS 3,4,6,7
          BEQ.L RDISOK
* FOLLOWING FOUR LINES CORRECT FOR ANOTHER 37C65 BUG
          CMP.B #$40,D7            CHECK FOR NON-COMPLETION
          BNE.S RETRYR             MUST BE SOMETHING ELSE
          CMP.B #$80,ST1           END OF CYLINDER? BOOBOO!
          BEQ.L RDISOK             YES, NOT REALLY AN ERROR

RETRYR    SUB.B #1,RETRCT
          BEQ.S RD7ERR             ERROR OUT IF TOO MANY RETRIES
          MOVE.B RETRCT,D7
          AND.B #3,D7              LOOK AT LAST 2 BITS
          BNE.S CHKRST             IF <>0, DON'T SWAP DISK FORM
          CLR.L D6
          ADD.B #1,DSKSEQ          TRY THE NEXT DSK SEQUENCE
          MOVE.B DSKSEQ,D6
          AND.B #3,D6              RIGHT TWO BITS ONLY
          LSL.B #4,D6              X16
          MOVE.L DRVPTR,A2         POINTER TO DRIVE TYPE
          ADD.L D6,A2              POINT TO NEW SUBTYPE
          MOVE.L 0(A2),DRVDAT
          MOVE.L 4(A2),DRVDAT+4    TRANSFER 16 DISK INFO BYTES
          MOVE.L 8(A2),DRVDAT+8
          MOVE.L 12(A2),DRVDAT+12
CHKRST    AND.B #1,D7              LOOK AT LAST BIT OF RETRCT
          BNE.L RDRETRY            RESTORE ONLY EVERY TWO TRIES
          BSR.L RESTORE            RESTORE
          MOVE.B #$30,REGOPER      DO SOFT RESET
          MOVE.B #$34,REGOPER
NOREST    BRA.L RDRETRY

RD7ERR    MOVE.B #$04,REGOPER      MOTORS OFF NO SOFT RESET: AT MODE
          MOVEM.L (A7)+,D0-D5/A0-A4
          BRA.L COMEND             QUIT

RDISOK    MOVEM.L (A7)+,D0-D5/A0-A4
          RTS


* SETCOM - SET UP COMMAND BUFFER WITH KNOWN DATA; SKIP COMMAND
* ITSELF.

SETCOM    MOVE.B #$34,REGOPER      MOTOR ON AND UNIT=0
          LEA DRVDAT,A1            POINT TO THIS DRIVE'S DATA
          MOVE.B DBPS(A1),REGCONT  SET FOR CORRECT BPS RATE
          CLR.L D5
          MOVE.B TRKSEC,D5         ACTUAL DESIRED TRACK
          MOVE.B D5,COMMAND+2      INTO COMMAND
          BEQ.S SETTR0             IF TRACK 0
          MOVE.B #1,D5             D5=1 IF TRACK<>0
SETTR0    MOVE.B D0MF(A1,D5),D7    GET MF FOR APPROPRIATE TRK
          LSL.B #6,D7
          MOVE.B D7,MFBIT          SET UP MF BIT
          CLR.B COMMAND+3          TEMP ASSUME HEAD 0
          MOVE.B D0SECT(A1,D5),D7  # OF SECT ON TRACK
          CMP.B TRKSEC+1,D7        ACTUAL DESIRED SECTOR
          BCS.S SETSDB             IF ON SIDE A
SETSDA    CLR.B COMMAND+3          H=0 FOR SIDE A
          MOVE.B #0,COMMAND+1      HS AND US
          MOVE.B TRKSEC+1,D7
SETBOTH   MOVE.B D7,COMMAND+4
          MOVE.B D7,COMMAND+6      EOT
          MOVE.B DN(A1),COMMAND+5  N
          MOVE.B D0GAP(A1,D5),COMMAND+7   GPL GAP 3
          MOVE.B DTL(A1),COMMAND+8 DTL DATA LENGTH
          RTS
SETSDB    MOVE.B #4,COMMAND+1      HS=1 AND UNIT = 0
          MOVE.B #1,COMMAND+3      AND H=1
          MOVE.B TRKSEC+1,D7
          SUB.B D0SIDB(A1,D5),D7   CORRECT SECTOR FOR SIDE B
          BRA.S SETBOTH

* SEEK COMMAND

SEEK      MOVE.B COMMAND+2,D7      LOG TRACK WE WANT
          BEQ.S SEEKT0             OK IF TRACK 0
          TST.B DDUBL(A1)          DOUBLE-STEPPING?
          BEQ.S SEEKT0             NO
          LSL.B #1,D7              YES, DOUBLE IT
          MOVE.B D7,COMMAND+2      THEN RESTORE IT
SEEKT0    CMP.B PRETRK,D7          SAME AS PREVIOUS?
          BEQ.S SEEKEX             EXIT IF ALREADY THERE
          MOVE.B PRETRK,D7         PREVIOUS TRACK
          CMP.B #255,D7            SEE IF CURRENT STILL 255
          BNE.S SEEKGO             NO, OK TO SEEK
          BSR.L RESTORE
          BNE.S SEEKER             EXIT IN ERROR

* PRETRK IS NOT 255, AND MUST SEEK
SEEKGO    MOVE.B #$0F,COMMAND      SEEK COMMAND
          MOVE.W #3,D5             THREE BYTES IN COMMAND
          MOVE.B #0,D4             DON'T TURN OFF IRQ
          BSR.L SENDIT             SEND TO FDC
          BNE.S SEEKER             SOMETHING WRONG
          BSR.L SENSIN             SENSE IRQ TO CLEAR
          CMP.B COMMAND+2,D7       CHECK IF CORRECT TRACK
          BNE.S SEEKER             EXIT IF NO MATCH

* RESTORE CORRECT TRACK NUMBER OF DOUBLE-STEPPING IF NO ERROR
SEEKEX    MOVE.B COMMAND+2,D7      PHYS TRACK WE ARE NOW ON
          MOVE.B D7,PRETRK
          TST.B DDUBL(A1)          DOUBLE-STEPPING?
          BEQ.S RETZ               REALLY EXIT IF NOT
          LSR.B #1,D7              CVT BACK TO LOGICAL TRK
          MOVE.B D7,COMMAND+2      THEN RESTORE IT
          CLR.L D7                 AND RETURN ZERO
RETZ      RTS

* RESTORE CORRECT TRACK NUMBER OF DOUBLE-STEPPING IF NO ERROR
SEEKER    TST.B DDUBL(A1)          DOUBLE-STEPPING?
          BEQ.S RETNZ              REALLY EXIT IF NOT
          MOVE.B COMMAND+2,D7      ELSE PHYS TRACK WE WANT
          LSR.B #1,D7              CVT BACK TO LOG
          MOVE.B D7,COMMAND+2      THEN RESTORE IT
RETNZ     MOVE.B #1,D7             RETURN NON-ZERO ON ERROR
          RTS

* RESTORE

RESTORE   MOVE.B #7,COMMAND        RESTORE COMMAND
          MOVE.B COMMAND+1,D3      SAVE OLD HS AND US
          MOVE.B D0,COMMAND+1      PUT IN US ONLY
          MOVE.W #2,D5             TWO BYTES IN COMMAND
          MOVE.B #0,D4             DON'T TURN OFF IRQ
          BSR.S SENDIT             SEND TO FDC
          BNE.S RESTNG             SOMETHING WRONG
          BSR.L SENSIN             SENSE IRQ TO CLEAR
          TST.B D7                 CHECK PRESENT TRACK NO
          BNE.S RESTNG             ERROR IF NOT 0
          MOVE.B D3,COMMAND+1
          CLR.B PRETRK             SET CURRENT TO 0
          RTS
RESTNG    MOVE.B D3,COMMAND+1
          MOVE.B #1,D7             RETURN NON-ZERO ON ERROR
          RTS

* SENDIT ROUTINE: SEND (D5) BYTES TO 765 FROM COMMAND BUFFER
*   THE CALLING ROUTINE SETS D4=1 IF IT WANTS IRQ DISABLED, 0 IF NOT
*   IF D4=1, THEN SENDIT DOESN'T SEND THE VERY LAST BYTE OF
*   THE COMMAND, LETTING THE CALLING PROGRAM DO IT

SENDIT    MOVE.W #$FFFF,D6         REPEAT MANY TIMES
SEND10    MOVE.B REGSTAT,D7
          BTST #7,D7               CHECK DRQ BIT
          BEQ.S SEND20             WAIT IF NOT READY
          BTST #6,D7               DIO MUST BE 0 FOR WRITE
          BEQ.S SEND40             OK
          MOVE.B REGDATA,D7        ELSE READ DATA TO CLEAR
SEND20    BSR.L WAIT12             WAIT 12 MICROSECONDS
SENDER    DBRA D6,SEND10
          MOVE.B #1,D7             BNE MEANS ERROR
          RTS

SEND40    BTST #4,REGSTAT          CHECK BUSY BIT
          BNE.S SENDER             IF STILL BUSY, THEN REAL BAD
          MOVE.B REGSTAT,D7
          AND.B #$0F,D7            CHECK 4 SEEK BITS
          BEQ.S SEND50             OK IF NONE
          BSR.L SENSIN             EXECUTE SENSE INTERRUPT

* PRESUMABLY 765 IS NOW READY FOR COMMAND, SO GO! AT THIS POINT,
* D5 CONTAINS NUMBER OF BYTES TO SEND FROM COMMAND BUFFER
SEND50    LEA COMMAND,A5           POINT TO COMMAND BUFFER
          SUB.W #1,D5              SEND ALL BYTES, EXCEPT ...
          SUB.B D4,D5              OMIT LAST IF D4=1
SEND60    BSR.S WAITRQ             WAIT FOR OK TO WRITE
          MOVE.B (A5)+,D7
          MOVE.B D7,REGDATA        OUTPUT A COMMAND
          DBRA D5,SEND60           REPEAT FOR ALL BUT LAST
          BSR.S WAITRQ             WAIT FOR OK TO WRITE, RET BEQ
          TST.B D4                 CHECK WHETHER TO DISABLE IRQ
          BEQ.S SENDND             NO, DON'T DISABLE
* DISABLE IRQ HERE
          NOP
SENDND    BSR.S WAIT12
SENDEX    RTS                      AND RETURN WITH BEQ

* SENSE INTERRUPT COMMAND - TO CLEAR IRQ AFTER SEEK OR RESTORE
*   RETURNS STATUS REG 0 IN D6, CYLINDER IN 7

SENSIN    MOVE.W #$7FFF,D7
SENSIN1   SUB.W #1,D7              WAIT FOR BOOBOO
          BNE.S SENSIN1
          MOVE.B #$08,REGDATA      SENSE INTERRUPT STATUS CMD
          BSR.S WAITRQ
          MOVE.B REGDATA,D6        RETURN STATUS REG 0
          CMP.B #$80,D6            INVALID OP CODE, ALL ELSE OK?
          BEQ.S SENSIN             YES, REPEAT AGAIN
          BSR.S WAITRQ
          MOVE.B REGDATA,D7        GET CYLINDER NUMBER
          BTST #5,D6               SEEK END?
          BEQ.S SENSIN             NO, SO WAIT SOME MORE
          RTS

* WAIT 12 MICROSECONDS TO KEEP 765 HAPPY

WAIT12    MOVE.B #50,D7
WAIT12A   SUB.B #1,D7
          BNE.S WAIT12A
          RTS

* WAIT FOR STATUS REG RQM REQUEST SIGNAL

WAITRQ    BSR.S WAIT12
WAITRQ1   MOVE.B REGSTAT,D7        CHECK STATUS
          BPL.S WAITRQ1            WAIT FOR RQM=1
          RTS

* WAIT 1 SECOND ROUTINE FOR MOTOR TO COME ON

WAIT1S    MOVE.L #600000,D7
WAIT0S    SUB.L #1,D7              WAIT 1 SECOND FOR MOTOR
          BNE.S WAIT0S
          RTS

* D7RROR - WHAT TO DO IN CASE OF ERROR

D7RROR    LEA D7EMSG,A4
          JSR PSTRNG               THEN PRINT ERROR MESSAGE
          JMP WARMST               AND QUIT
D7EMSG    FCC '37C65 DISK BOOT ERROR.',4


********************************************************
* 'WH' COMMAND - BOOT SK*DOS FROM WD1002-HDO CONTROLLER
********************************************************

WDREAD    EQU $FE0141              READ DATA REGISTER
WDWRIT    EQU WDREAD               WRITE DATA REGISTER
WDERRO    EQU $FE0143              ERROR REGISTER
WDWPRE    EQU WDERRO               WRITE PRECOMP REGISTER
WDSCNT    EQU $FE0145              SECTOR COUNT REGISTER
WDSNUM    EQU $FE0147              SECTOR NUMBER
WDCYLO    EQU $FE0149              CYLINDER NUMBER - LOW ORDER BYTE
WDCYHI    EQU $FE014B              CYLINDER NUMBER - HIGH ORDER BYTE
WDSDHR    EQU $FE014D              SIZE,DRIVE,HEAD REGISTER
WDSTAT    EQU $FE014F              STATUS REG - READ ONLY
WDCOMA    EQU WDSTAT               COMMAND REG - WRITE ONLY

* FIRST, TEST WHETHER THERE IS A WD1002 CONTROLLER

WHBOOT    MOVE.B #$A5,WDSNUM       TRY STORING INTO WD1002
          MOVE.B WDSNUM,D5         READ BACK
          CMP.B #$A5,D5            CHECK IT
          BNE.L BERROR             NO WD1002 THERE
          MOVE.B #$5A,WDSNUM       THEN TRY THE COMPLEMENT
          MOVE.B WDSNUM,D5         READ BACK
          CMP.B #$5A,D5            CHECK IT
          BNE.L BERROR             NO WD1002 THERE

* INITIALIZE THE WINCHESTER

          MOVE.B #$88,WDSDHR       ECC,SEC=256,DRIVE 1,HEAD 0
          MOVE.B #32,WDWPRE        SET PRECOMP TO TRACK 128
          MOVE.B #$1F,WDCOMA       DO A SLOW RESTORE
          BSR.L CHBUSY             WAIT FOR WD1002 NOT BUSY
          BNE.L BERROR             EXIT IF ERROR

* READ TRACK 0 SECTOR 0 TO DETERMINE PARTITION 0 LAYOUT

          MOVE.B #0,WDSNUM         SECTOR 0
          MOVE.B #0,WDCYHI
          MOVE.B #0,WDCYLO         CYLINDER 0
          MOVE.B #1,WDSCNT         SECTOR COUNT = 1
          MOVE.B #$20,WDCOMA       SEND READ COMMAND
          BSR.L CHBUSY             WAIT FOR COMPLETION
          BNE.L BERROR             EXIT IF ERROR
          LEA OURWIN,A1            POINT TO OUR WINTAB
          MOVE.L #13,D7            READ 14 BYTES OF DATA
DILOOP    MOVE.B WDREAD,(A1)+
          DBRA D7,DILOOP
          MOVE.B WDSTAT,D7         GET WD STATUS BYTE
          BTST.B #0,D7             CHECK ERROR BIT
          BNE.L BERROR             EXIT IF ERROR

* NOW SEARCH DISK DIRECTORY FOR SK*DOS.SYS

          MOVE.L #$0005,D0         DIRECTORY START DISK ADDRESS
          LEA OURWIN,A1            POINT TO OUR WINTAB
DIREAD    LEA DBUFFR,A0            DIRECTORY SECTOR BUFFER
          BSR.L HREAD              READ DIRECTORY SECTOR
          BNE.L BERROR
          LEA DBUFFR,A0            BACK TO DIRECTORY BUFFER
          LEA 256(A0),A6           END OF BUFFER
          LEA 16(A0),A0            FIRST DIR ENTRY
DIRLOO    TST.B (A0)               CHECK FIRST BYTE OF ENTRY
          BMI.S NXTDIR             DELETED ENTRY
          BEQ.L BERROR             END OF DIRECTORY
          MOVE.L (A0),D7           FIRST FOUR LETTERS
          CMP.L #$534B2A44,D7      "SK*D" ?
          BNE.S NXTDIR             NO
          MOVE.L 4(A0),D7          NEXT FOUR LETTERS
          CMP.L #$4F530000,D7      "OS.." ?
          BNE.S NXTDIR
          MOVE.L 8(A0),D7          NEXT THREE
          AND.L #$FFFFFF00,D7      BLANK OUT LAST
          CMP.L #$53595300,D7      "SYS" ?
          BEQ.S GOTIT              GOT IT?

NXTDIR    ADD.L #24,A0             POINT TO NEXT ENTRY
          CMP.L A0,A6              AT END OF SECTOR?
          BNE.S DIRLOO             NO, CONTINUE

          MOVE.W DBUFFR,D0         AT END, GET POINTER TO NEXT
          BEQ.L BERROR             SK*DOS.SYS NOT FOUND IF AT END
          BRA.S DIREAD             ELSE LOOK AT NEXT SCTR

* WE HAVE FOUND 'SK*DOS.SYS'

GOTIT     MOVE.B 13(A0),D0
          LSL.W #8,D0
          MOVE.B 14(A0),D0         GET STARTING DISK ADDRESS
          LEA DBUFFR,A0            POINT BACK TO BUFFER
          MOVE.W D0,(A0)           PUT FIRST ADDRESS INTO IT

* NOW READ THE FILE INTO MEMORY WITHOUT AN OFFSET

          MOVE.L #0,A3             ERASE EXECUTION ADDRESS
          CLR.L D1                 DATA POINTER =0
GET2      BSR.L GETNEW             GET FLAG BYTE
          CMP.B #$02,D5            IS IT 02?
          BEQ.S GETD2O             2-BYTE ADDRESS DATA
          CMP.B #$03,D5            IS IT 03?
          BEQ.S GETD4O             4-BYTE ADDRESS DATA
          CMP.B #$16,D5            IS IT 16?
          BEQ.L GETT2O             2-BYTE TRANSFER
          CMP.B #$17,D5            IS IT 17?
          BEQ.L GETT4O             4-BYTE TRANSFER
          BRA.S GET2               ANYTHING ELSE JUST SKIP

GETD2O    BSR.L GETWRD             GET 2-BYTE LOAD ADDRESS
          MOVE.L D4,A2             PUT INTO A2
          BSR.L GETNEW             GET LENGTH
          MOVE.L D5,D2             SET UP AS COUNTER
          BRA.S GETLOO             THEN CONTINUE

GETD4O    BSR.L GETWRD             GET LEFT WORD OF LOAD ADDRESS
          SWAP D4
          MOVE.L D4,A2             MOVE INTO A2
          BSR.L GETWRD             GET RIGHT WORD OF LOAD ADDRESS
          ADD.L D4,A2              COMBINE TWO WORDS
          BSR.L GETWRD             GET LENGTH
          MOVE.L D4,D2             SET UP AS COUNTER

GETLOO    BSR.L GETNEW             ELSE GET ONE BYTE
          MOVE.B D5,(A2)+          STORE IN MEMORY
          SUB.W #01,D2             DECREMENT COUNTER
          BNE.S GETLOO
          BRA.L GET2               AT END, LOOK FOR NEXT FLAG

GETT4O    BSR.S GETWRD             GET LEFT WORD OF TRANSFER ADDRESS
          SWAP D4                  MOVE INTO LEFT HALF
          MOVE.L D4,A3             SAVE IN A3
          BSR.S GETWRD             GET RIGHT HALF OF ADDR
          ADD.L A3,D4              ADD BACK TOGETHER
          MOVE.L D4,A3             SAVE EXECUTION ADDRESS
          BRA.S GET2

GETT2O    BSR.S GETWRD             GET TRANSFER ADDRESS FROM FILE
          MOVE.L D4,A3             STORE EXECUTION ADDRESS
          BRA.L GET2               AND REPEAT

* GETWRD - GET TWO-BYTE WORD FROM FILE

GETWRD    BSR.S GETNEW             GET MSB BYTE
          MOVE.L D5,D4             SAVE IN D4
          LSL.W #8,D4              MOVE INTO SECOND BYTE
          BSR.S GETNEW             GET LSB
          ADD.W D5,D4              ADD THE TWO BYTES TOGETHER IN D4
GETEXI    RTS

* GETNEW - GET BYTE FROM FILE

GETNEW    TST.B D1                 CHECK POINTER TO DATA
          BEQ.S READIT             ZERO MEANS HAVE TO READ SCTR
GETNW1    CLR.L D5
          MOVE.B 0(A0,D1.W),D5     READ A BYTE
          ADD.B #1,D1              POINT TO NEXT
          RTS

* READIT - READ A NEW SECTOR FROM HARD DISK INTO BUFFER

READIT    LEA DBUFFR,A0            POINT TO BUFFER
          MOVE.W (A0),D0           POINTER TO NEXT
          BEQ.S HDFINI             FINISHED IF 00 POINTER
          BSR.S HREAD              READ NEXT SECTOR
          MOVE.W #4,D1             POINT TO ITS FIRST BYTE
          BRA.S GETNW1             THEN CONTINUE AS ABOVE

* HDFINI - WHEN FINISHED READING, REASSIGN DRIVE NUMBERS,
* AND JUMP TO PROGRAM IF THERE IS A TRANSFER ADDRESS

HDFINI    MOVE.L A3,D7             TRANSFER ADDRESS, IF ANY
          BEQ.L BERROR             ERROR IF NONE
          MOVE.B #$20,DRUSED       HARD DISK BECOMES DRIVE 0
          MOVE.B #$10,DRUSED+1     FLOPPY DISK BECOMES DRIVE 1
          BCLR #4,HARDWE           SIGNAL NO WX1 CONTROLLER
          JMP.L (A3)               THEN JUMP TO SK*DOS

* HREAD - READ SECTOR INTO MEMORY. ENTER WITH D0=LOGICAL TR/SEC,
* AND A0 = ADDRESS OF BUFFER TO READ INTO

HREAD     BSR.L LPCONV             CONVERT LOG TO PHYS ADDRESS
          MOVE.B #1,WDSCNT         SECTOR COUNT = 1
          MOVE.B #$20,WDCOMA       SEND READ COMMAND
          BSR.S CHBUSY             WAIT FOR COMPLETION
          BEQ.S HREDOK             CONTINUE IF NO ERROR >>A<<
          MOVE.B #$20,WDCOMA       >>A<<
          BSR.S CHBUSY             TRY AGAIN ON PROBLEM >>A<<
          BEQ.S HREDOK             >>A<<
          MOVE.B #$20,WDCOMA       >>A<<
          BSR.S CHBUSY             TRY AGAIN ON PROBLEM >>A<<
          BEQ.S HREDOK             >>A<<
          MOVE.B #$20,WDCOMA       >>A<<
          BSR.S CHBUSY             TRY AGAIN ON PROBLEM >>A<<
          BEQ.S HREDOK             >>A<<
          MOVE.B #$20,WDCOMA       >>A<<
          BSR.S CHBUSY             TRY AGAIN ON PROBLEM >>A<<
HREDOK    MOVE.L A0,A5             POINT TO BUFFER >>A<<
          MOVE.W #255,D6           COUNTER = 256-1
HRDLOO    MOVE.B WDREAD,(A5)+      READ A BYTE
          DBRA D6,HRDLOO           REPEAT FOR 256 BYTES
          BSR.S CHBUSY             WAIT FOR COMPLETION
          BNE.L BERROR             IF ERROR
          RTS

* CHBUSY - WAIT IF BUSY, BUT ABORT IF IT TAKES TOO LONG

CHBUSY    MOVE.L #$100000,D6       TIMEOUT COUNTER
CHBUS1    SUB.L #1,D6              DROP TIMEOUT COUNT
          BEQ.L BERROR             SOMETHING WRONG?
          TST.B WDSTAT             CHECK WD1002 STATUS
          BMI.L CHBUS1             WAIT UNTIL NOT BUSY
          MOVE.B WDSTAT,D7         GET WD STATUS BYTE
          BTST.B #0,D7             CHECK ERROR BIT
          RTS

* LPCONV - CONVERT A LOGICAL TRACK AND SECTOR NUMBER (IN D0
* AS 0000TRSE) INTO PHYSICAL TRACK, HEAD, AND SECTOR NUMBERS AND
* PUT INTO WD REGS, USING INFO IN OURWIN ENTRY POINTED TO BY A1

LPCONV    MOVE.W D0,D6
          LSR.W #8,D6              LOGICAL TRACK
          CLR.L D7
          MOVE.B 11(A1),D7         LOG SECT/TRACK
          ADD.W #1,D7              NUMBER PER TRACK
          MULU D7,D6               SECT BEFORE THIS TRACK
          CLR.L D7
          MOVE.B D0,D7             LOG SECTOR
          ADD.W D7,D6              BLOCK NUMBER
          MOVE.W 4(A1),D7          SECT/CYL ON HARD DISK
          DIVU D7,D6               REMAINDER | TRACK NUMBER
          ADD.W 8(A1),D6           PLUS START OF PARTITION
          MOVE.B D6,WDCYLO
          LSR.L #8,D6
          MOVE.B D6,WDCYHI         CYLINDER NUMBER TO WD1002
          LSR.L #8,D6              REMAINDER IN RIGHT HALF
          CLR.L D7
          MOVE.B 2(A1),D7          SECTORS PER TRACK
          DIVU D7,D6               SECTOR | HEAD
          ADD.B #$88,D6            COMBINE WITH OTHER SDH BITS
          MOVE.B D6,WDSDHR         PUT INTO SDH REGISTER
          SWAP D6                  MOVE SECTOR RIGHT
          MOVE.B D6,WDSNUM         SECTOR NUMBER TO WD1002
          RTS

* BERROR - WHAT TO DO IN CASE OF ERROR

BERROR    LEA HBEMSG,A4
          JSR PSTRNG               THEN PRINT ERROR MESSAGE
          JMP WARMST               AND QUIT
HBEMSG    FCC 'HARD DISK NOT READY - WAIT AND TRY AGAIN.',4

********************************************************
* 'WA/WB' COMMANDS - BOOT SK*DOS FROM WD1002A-WX1 HARD DISK
********************************************************

* SK*DOS EQUATES

WXDATA    EQU $FA0641              DATA REGISTER
WXCOMM    EQU WXDATA               COMMAND REGISTER
WXSTAT    EQU WXDATA+2             STATUS REGISTER
WXRESE    EQU WXDATA+2             RESET REGISTER
WXSELE    EQU WXDATA+4             SELECT REGISTER
WDAROM    EQU $D90000              CONTROLLER ROM SPACE

* TWO ENTRY POINTS: WABOOT FOR WX1 DRIVE A, WBBOOT FOR DRIVE B
WABOOT    CLR.B BOODRI             FOR DRIVE A, BOODRI=0
          BRA.S W1BOOT
WBBOOT    MOVE.B #$20,BOODRI       FOR DRIVE B, BOODRI=$20

* FIRST, TEST WHETHER THERE IS A CONTROLLER

W1BOOT    CMP.B #$55,WDAROM+1      CHECK FIRST BYTE
          BNE.L BERROR             NO WD1002 THERE
          CMP.B #$AA,WDAROM+3      CHECK SECOND
          BNE.L BERROR             NO WD1002 THERE

* INITIALIZE THE CONTROLLER

          MOVE.B #0,WXRESE         RESET IT
          BSR.L WCHBUS             WAIT FOR WD1002 NOT BUSY
          MOVE.B #1,D0
          MOVE.B BOODRI,D1         INSERT DRIVE NUMBER
          CLR.B D2                 COMMAND TO RESTORE DRIVE
          CLR.B D3
          CLR.B D4
          CLR.B D5
          BSR.L GIVE6              GIVE TO CONTROLLER
          BSR.L CFWAIT             WAIT FOR COMPLETION CODE
          BTST #1,WXDATA           CHECK THE CODE
          BNE.L BERROR             ERROR IF NOT ZERO

* SEND A TEMPORARY SET OF DRIVE PARAMETERS TO THE CONTROLLER SO
* WE CAN READ THE FIRST SECTOR

          MOVE.B #$0C,D0           INIT DRIVE PARAMS
          BSR.L GIVE6              GIVE TO CONTROLLER
          BSR.L C9WAIT             WAIT FOR BUSY AND REQ ONLY
          BNE.L BERROR
          MOVE.B #0,WXDATA         TEMPORARY DRIVE PARAMS FOR NOW
          BSR.L C9WAIT
          MOVE.B #100,WXDATA       100 CYLINDERS
          BSR.L C9WAIT
          MOVE.B #2,WXDATA         2 HEADS
          BSR.L C9WAIT
          MOVE.B #0,WXDATA
          BSR.L C9WAIT
          MOVE.B #128,WXDATA       REDUCE WRITE CUR AT 128
          BSR.L C9WAIT
          MOVE.B #0,WXDATA
          BSR.L C9WAIT
          MOVE.B #128,WXDATA       WRITE PRECOMP AT 128
          BSR.L C9WAIT
          MOVE.B #5,WXDATA         ECC BURST LENGTH OF 5
          BSR.L CFWAIT             WAIT FOR COMPLETION CODE
          BTST #1,WXDATA           CHECK THE CODE
          BNE.L BERROR             ERROR IF NOT ZERO

* READ TRACK 0 SECTOR 0 TO DETERMINE PARTITION 0 LAYOUT

          MOVE.B #$08,D0           READ SECTOR COMMAND
          MOVE.B BOODRI,D1         DRIVE # HEAD 0
          CLR.B D2                 CYL = SECTOR 0
          CLR.B D3                 CYLINDER 0
          MOVE.B #1,D4             1 SECTOR
          CLR.B D5                 RETRY AND SLOW
          BSR.L GIVE6              GO DO IT
          BSR.L CBWAIT             WAIT FOR DATA READY
          LEA OURWIN,A1            POINT TO OUR WINTAB
          MOVE.L #14,D0            READ 15 BYTES OF DATA
WDLOOP    MOVE.B WXDATA,(A1)+
          BSR.L CBWAIT             WAIT FOR NEXT DATA
          DBRA D0,WDLOOP
          MOVE.B WXDATA,(A1)+      GET LAST BYTE
          MOVE.B #0,WXRESE         ABORT THE READ
          BSR.L WCHBUS             WAIT FOR WD1002 NOT BUSY

* SEND THE CORRECT SET OF DRIVE PARAMETERS TO THE CONTROLLER

          MOVE.B #$0C,D0           INIT DRIVE PARAMS
          BSR.L GIVE6              GIVE TO CONTROLLER
          BSR.L C9WAIT             WAIT FOR BUSY AND REQ ONLY
          LEA OURWIN,A1
          MOVE.B 6(A1),WXDATA
          BSR.L C9WAIT
          MOVE.B 7(A1),WXDATA      NUMBER OF CYLINDERS
          BSR.L C9WAIT
          MOVE.B 3(A1),WXDATA      2 HEADS
          BSR.L C9WAIT
          MOVE.B #0,WXDATA
          BSR.L C9WAIT             DON'T HAVE A BETTER VALUE, SO
          MOVE.B #128,WXDATA       REDUCE WRITE CUR AT 128
          BSR.L C9WAIT
          MOVE.B #0,WXDATA
          BSR.L C9WAIT
          MOVE.B 14(A1),WXDATA     WRITE PRECOMP CYLINDER
          BSR.L C9WAIT
          MOVE.B #5,WXDATA         ECC BURST LENGTH OF 5
          BSR.L CFWAIT             WAIT FOR COMPLETION CODE
          BTST #1,WXDATA           CHECK THE CODE
          BNE.L BERROR             ERROR IF NOT ZERO

* NOW SEARCH DISK DIRECTORY FOR SK*DOS.SYS

          MOVE.L #$0005,D0         DIRECTORY START DISK ADDRESS
          LEA OURWIN,A1            POINT TO OUR WINTAB
WDIRRD    LEA DBUFFR,A0            DIRECTORY SECTOR BUFFER
          BSR.L WHREAD             READ DIRECTORY SECTOR
          BNE.L BERROR
          LEA DBUFFR,A0            BACK TO DIRECTORY BUFFER
          LEA 256(A0),A6           END OF BUFFER
          LEA 16(A0),A0            FIRST DIR ENTRY
WDIRLO    TST.B (A0)               CHECK FIRST BYTE OF ENTRY
          BMI.S WNXTDI             DELETED ENTRY
          BEQ.L BERROR             END OF DIRECTORY
          MOVE.L (A0),D7           FIRST FOUR LETTERS
          CMP.L #$534B2A44,D7      "SK*D" ?
          BNE.S WNXTDI             NO
          MOVE.L 4(A0),D7          NEXT FOUR LETTERS
          CMP.L #$4F530000,D7      "OS.." ?
          BNE.S WNXTDI
          MOVE.L 8(A0),D7          NEXT THREE
          AND.L #$FFFFFF00,D7      BLANK OUT LAST
          CMP.L #$53595300,D7      "SYS" ?
          BEQ.S WGOTIT              GOT IT?

WNXTDI    ADD.L #24,A0             POINT TO NEXT ENTRY
          CMP.L A0,A6              AT END OF SECTOR?
          BNE.S WDIRLO             NO, CONTINUE

          MOVE.W DBUFFR,D0         AT END, GET POINTER TO NEXT
          BEQ.L BERROR             SK*DOS.SYS NOT FOUND IF AT END
          BRA.S WDIRRD             ELSE LOOK AT NEXT SCTR

* WE HAVE FOUND 'SK*DOS.SYS'

WGOTIT    MOVE.B 13(A0),D0
          LSL.W #8,D0
          MOVE.B 14(A0),D0         GET STARTING DISK ADDRESS
          LEA DBUFFR,A0            POINT BACK TO BUFFER
          MOVE.W D0,(A0)           PUT FIRST ADDRESS INTO IT

* NOW READ THE FILE INTO MEMORY WITHOUT AN OFFSET

          MOVE.L #0,A3             ERASE EXECUTION ADDRESS
          CLR.L D1                 DATA POINTER =0
WXGET2    BSR.S WGETNW             GET FLAG BYTE
          CMP.B #$02,D5            IS IT 02?
          BEQ.S WGET2O             2-BYTE ADDRESS DATA
          CMP.B #$03,D5            IS IT 03?
          BEQ.S WGET4O             4-BYTE ADDRESS DATA
          CMP.B #$16,D5            IS IT 16?
          BEQ.S WGETT2             2-BYTE TRANSFER
          CMP.B #$17,D5            IS IT 17?
          BEQ.S WGETT4             4-BYTE TRANSFER
          BRA.S WXGET2             ANYTHING ELSE JUST SKIP

WGET2O    BSR.S WGETWR             GET 2-BYTE LOAD ADDRESS
          MOVE.L D4,A2             PUT INTO A2
          BSR.S WGETNW             GET LENGTH
          MOVE.L D5,D2             SET UP AS COUNTER
          BRA.S WGETLO             THEN CONTINUE

WGET4O    BSR.S WGETWR             GET LEFT WORD OF LOAD ADDRESS
          SWAP D4
          MOVE.L D4,A2             MOVE INTO A2
          BSR.S WGETWR             GET RIGHT WORD OF LOAD ADDRESS
          ADD.L D4,A2              COMBINE TWO WORDS
          BSR.S WGETWR             GET LENGTH
          MOVE.L D4,D2             SET UP AS COUNTER

WGETLO    BSR.S WGETNW             ELSE GET ONE BYTE
          MOVE.B D5,(A2)+          STORE IN MEMORY
          SUB.W #01,D2             DECREMENT COUNTER
          BNE.S WGETLO
          BRA.S WXGET2               AT END, LOOK FOR NEXT FLAG

WGETT4    BSR.S WGETWR             GET LEFT WORD OF TRANSFER ADDRESS
          SWAP D4                  MOVE INTO LEFT HALF
          MOVE.L D4,A3             SAVE IN A3
          BSR.S WGETWR             GET RIGHT HALF OF ADDR
          ADD.L A3,D4              ADD BACK TOGETHER
          MOVE.L D4,A3             SAVE EXECUTION ADDRESS
          BRA.S WXGET2

WGETT2    BSR.S WGETWR             GET TRANSFER ADDRESS FROM FILE
          MOVE.L D4,A3             STORE EXECUTION ADDRESS
          BRA.S WXGET2               AND REPEAT

* WGETWR - GET TWO-BYTE WORD FROM FILE

WGETWR    BSR.S WGETNW             GET MSB BYTE
          MOVE.L D5,D4             SAVE IN D4
          LSL.W #8,D4              MOVE INTO SECOND BYTE
          BSR.S WGETNW             GET LSB
          ADD.W D5,D4              ADD THE TWO BYTES TOGETHER IN D4
          RTS

* WGETNW - GET BYTE FROM FILE

WGETNW    TST.B D1                 CHECK POINTER TO DATA
          BEQ.S WREADT             ZERO MEANS HAVE TO READ SCTR
WGETN1    CLR.L D5
          MOVE.B 0(A0,D1.W),D5     READ A BYTE
          ADD.B #1,D1              POINT TO NEXT
          RTS

* WREADT - READ A NEW SECTOR FROM HARD DISK INTO BUFFER

WREADT    LEA DBUFFR,A0            POINT TO BUFFER
          MOVE.W (A0),D0           POINTER TO NEXT
          BEQ.S WXFINI             FINISHED IF 00 POINTER
          BSR.S WHREAD             READ NEXT SECTOR
          BNE.L BERROR             IF ERROR
          LEA DBUFFR,A0            POINT TO BUFFER AGAIN
          MOVE.W #4,D1             POINT TO ITS FIRST BYTE
          BRA.S WGETN1             THEN CONTINUE AS ABOVE

* WXFINI - WHEN FINISHED READING, REASSIGN DRIVE NUMBERS,
* AND JUMP TO PROGRAM IF THERE IS A TRANSFER ADDRESS

WXFINI    MOVE.L A3,D7             TRANSFER ADDRESS, IF ANY
          BEQ.L BERROR             ERROR IF NONE
          MOVE.B BOODRI,D7         BOOT DRIVE A=0 B=20
          LSR.B #3,D7              A=0 B=4
          ADD.B #$20,D7            A=20 B=24
          MOVE.B D7,DRUSED         HARD DISK BECOMES DRIVE 0
          MOVE.B #$10,DRUSED+1     FLOPPY DISK BECOMES DRIVE 1
          BSET #4,HARDWE           SIGNAL WX1 CONTROLLER
          JMP.L (A3)               THEN JUMP TO SK*DOS

* WHREAD - READ SECTOR INTO MEMORY. ENTER WITH D0=LOGICAL TR/SEC,
* A1 POINTS TO ENTRY IN OURWIN, AND A0 = ADDRESS OF BUFFER TO READ INTO

WHREAD    BSR.L WLPCON             CONVERT LOG TO PHYS ADDRESS
          BSR.L WCHBUS             WAIT FOR NOT BUSY
          MOVE.B #0,WXSELE         SELECT THE CONTROLLER
          BSR.L CDWAIT             WAIT FOR COMMAND REQUEST
          MOVE.B #08,WXCOMM        READ SECTOR COMMAND
          BSR.L CDWAIT
          MOVE.B WX1HD,D7          HEAD NUMBER
          ADD.B BOODRI,D7          ADD IN DRIVE BIT
          MOVE.B D7,WXCOMM         DRIVE AND HEAD NUMBERS
          BSR.L CDWAIT
          MOVE.W WX1CYL,D7
          CLR.B D7                 ISOLATE MSB OF CYLINDER
          LSR.W #1,D7              AND INTO BITS 7-8
          ADD.B WX1SEC,D7          COMBINE WITH SECTOR
          LSR.W #1,D7              AND THEN DIV BY 2
          MOVE.B D7,WXCOMM
          BSR.L CDWAIT
          MOVE.B WX1CYL+1,D7
          MOVE.B D7,WXCOMM         LSB OF CYLINDER
          BSR.L CDWAIT
          MOVE.B #1,WXCOMM         1 SECTOR
          BSR.L CDWAIT
          LEA OURWIN,A1
          MOVE.B 1(A1),WXCOMM      RETRY AND STEP RATE
          BSR.L CBWAIT
          LEA SBUFFR,A5        POINT TO SECTOR BUFFER
          MOVE.W #510,D7           COUNTER FOR 511 BYTES
HRLOOP    MOVE.B WXDATA,(A5)+      MOVE A BYTE
          MOVE.B WXSTAT,D6         CHECK STATUS
          AND.B #$0F,D6
          CMP.B #$0B,D6            CHECK IF STILL WAITING
          BNE.L BERROR             NO, ERROR
          DBRA D7,HRLOOP           YES, CONTINUE
          MOVE.B WXDATA,(A5)+      MOVE LAST BYTE
* THEN CHECK IF ANY ERRORS
          BSR.L CFWAIT
          BNE.L BERROR             IF ERROR
          LEA SBUFFR,A5        WHERE FROM
          BTST #0,WX1SEC           CHECK WHETHER ODD OR EVEN SEC
          BEQ.S ISEVEN             USE IT IF EVEN
          LEA SBUFFR+256,A5    ELSE USE SECOND HALF
ISEVEN    MOVE.W #63,D7            256/4-1 REPS
HRMOVE    MOVE.L (A5)+,(A0)+       MOVE A BYTE
          DBRA D7,HRMOVE
          MOVE.B WXDATA,D7         GET ERROR CODE BYTE
          AND.B #$DF,D7            IGNORE DRIVE NUMBER
          RTS

* WLPCON - CONVERT A LOGICAL TRACK AND SECTOR NUMBER (IN D0
* AS 0000TRSE) INTO PHYSICAL TRACK, HEAD, AND SECTOR NUMBERS AND
* SAVE IN MEMORY, USING INFO IN OURWIN ENTRY POINTED TO BY A1.
* THIS ROUTINE ASSUMES 2 256-BYTE SECTORS ARE PACKED INTO EACH OF
* THE 17 512-BYTE SECTORS ON A TRACK

WLPCON    MOVE.W D0,D6
          LSR.W #8,D6              LOGICAL TRACK
          CLR.L D7
          MOVE.B 11(A1),D7         LOG SECT/TRACK
          ADD.W #1,D7              NUMBER PER TRACK
          MULU D7,D6               SECT BEFORE THIS TRACK
          CLR.L D7
          MOVE.B D0,D7             LOG SECTOR
          ADD.W D7,D6              BLOCK NUMBER
          MOVE.W 4(A1),D7          SECT/CYL ON HARD DISK
          DIVU D7,D6               REMAINDER | TRACK NUMBER
          ADD.W 8(A1),D6           PLUS START OF PARTITION
          MOVE.W D6,WX1CYL         SAVE CYLINDER NUMBER
          LSR.L #8,D6
          LSR.L #8,D6                REMAINDER IN RIGHT HALF
          CLR.L D7
          MOVE.B 2(A1),D7          SECTORS PER TRACK
          DIVU D7,D6               SECTOR | HEAD
          MOVE.B D6,WX1HD          SAVE HEAD NUMBER
          SWAP D6                  MOVE SECTOR RIGHT
          MOVE.B D6,WX1SEC         SAVE LOGICAL SECTOR NUMBER
          RTS

* GIVE6 - ROUTINE TO PASS A 6-BYTE CONTROL BLOCK FROM D0-D5
* TO THE CONTROLLER

GIVE6     BSR.S WCHBUS             WAIT FOR NOT BUSY
          MOVE.B #0,WXSELE         SELECT THE CONTROLLER
          BSR.S CDWAIT             WAIT FOR COMMAND REQUEST
          MOVE.B D0,WXCOMM         GIVE FIRST BYTE
          BSR.S CDWAIT
          MOVE.B D1,WXCOMM
          BSR.S CDWAIT
          MOVE.B D2,WXCOMM
          BSR.S CDWAIT             GIVE REMAINING BYTES
          MOVE.B D3,WXCOMM
          BSR.S CDWAIT
          MOVE.B D4,WXCOMM
          BSR.S CDWAIT
          MOVE.B D5,WXCOMM
          RTS

* WCHBUS - WAIT FOR CONTROLLER NOT BUSY
*   USES D7

WCHBUS    MOVE.L #$100000,D7       SET UP COUNTER
CALOOP    SUB.L #1,D7              DEC COUNTER
          BEQ.L BERROR             ERROR IF TOOK TOO LONG
          MOVE.B WXSTAT,D6         GET STATUS
          AND.B #$0F,D6            DELETE THE $C
          BNE.S CALOOP             REPEAT IF STILL BUSY
          RTS

* CDWAIT - WAIT FOR CONTROLLER READY TO RECEIVE A COMMAND BYTE
* (STATUS RETURNS A $CD AS SIGNAL = BUSY COMMAND WRITE REQ)
*   USES D6 AND D7

CDWAIT    MOVE.L #$100000,D7       SET UP COUNTER
CDLOOP    SUB.L #1,D7              DEC COUNTER
          BEQ.L BERROR             ERROR IF TOOK TOO LONG
          MOVE.B WXSTAT,D6         GET STATUS REGISTER
          AND.B #$0F,D6            KEEP RIGHT 4 BITS
          CMP.B #$0D,D6            CHECK BUSY, COM, WRITE, REQ
          BNE.S CDLOOP             WAIT FOR IT
          RTS

* CFWAIT - WAIT FOR CONTROLLER READY TO RETURN COMPLETION CODE
* (STATUS RETURNS A $CF AS SIGNAL = BUSY COMMAND READ REQUEST)
*   USES D6 AND D7

CFWAIT    MOVE.L #$100000,D7       SET UP COUNTER
CFLOOP    SUB.L #1,D7              DEC COUNTER
          BEQ.L BERROR             ERROR IF TOOK TOO LONG
          MOVE.B WXSTAT,D6         GET STATUS REGISTER
          AND.B #$0F,D6            KEEP RIGHT 4 BITS
          CMP.B #$0F,D6            CHECK BUSY, COM, READ, REQ
          BNE.S CFLOOP             WAIT FOR IT
          RTS

* C9WAIT - WAIT FOR CONTROLLER READY TO RETURN COMPLETION CODE
* (STATUS RETURNS A $C9 AS SIGNAL = BUSY DATA WRITE REQUEST)
*   USES D6 AND D7

C9WAIT    MOVE.L #$100000,D7       SET UP COUNTER
C9LOOP    SUB.L #1,D7              DEC COUNTER
          BEQ.L BERROR             ERROR IF TOOK TOO LONG
          MOVE.B WXSTAT,D6         GET STATUS REGISTER
          AND.B #$0F,D6            KEEP RIGHT 4 BITS
          CMP.B #$09,D6            CHECK BUSY, DATA, WRITE, REQ
          BNE.S C9LOOP             WAIT FOR IT
          RTS

* CBWAIT - WAIT FOR CONTROLLER READY TO RETURN COMPLETION CODE
* (STATUS RETURNS A $CB AS SIGNAL = BUSY DATA READ REQUEST)
*   USES D6 AND D7

CBWAIT    MOVE.L #$100000,D7       SET UP COUNTER
CBLOOP    SUB.L #1,D7              DEC COUNTER
          BEQ.L BERROR             ERROR IF TOOK TOO LONG
          MOVE.B WXSTAT,D6         GET STATUS REGISTER
          AND.B #$0F,D6            KEEP RIGHT 4 BITS
          CMP.B #$0B,D6            CHECK BUSY, DATA, WRITE, REQ
          BNE.S CBLOOP             WAIT FOR IT
          RTS

********************************************************
* 'RD' COMMAND - RETURN TO SK*DOS
********************************************************

SKCOLD    EQU $1000                SK*DOS COLD-START
SKWARM    EQU $1006                SK*DOS WARM-START

RETDOS    MOVE.W SKCOLD,D0         CHECK IF DOS LOADED
          CMP.W #$4EF9,D0          IS IT A JUMP?
          BNE.L COMEND             IGNORE IF NOT
          JMP SKWARM               RETURN TO DOS IF OK

********************************************************


* THIS IS UITERWIK 4K BASIC WHICH
* IS IN THE PUBLIC DOMAIN, AS TAKEN FROM
* BEST OF INTERFACE AGE

* ACTUAL PROGRAM

INTER     FCC 'TO'
          DC.B $F1
          DC.B $F1
TOPNT     DC.W $9999
          FCC 'STEP'
          DC.B $F1
          DC.B $F1
STEPNT    DC.W $8888

* KEYWORD TABLES
* CAUTION!! IT IS ABSOLUTELY ESSENTIAL THAN
* NONE OF THE FDB ADDRESSES IN THIS TABLE
* CONTAIN A $F1 BYTE!!!
* IN ORDER TO FORCE WORD ALIGNMENT, INCLUDE AN EXTRA F1 SO ALL
* OFFSET ADDRESSES START AT A WORD BOUNDARY

* COMMAND TABLE: KEYWORD, F1, MAYBE ANOTHER F1, ADDRESS TO GO TO
COMMAN    FCC 'RUN'
          DC.B $F1
          DC.W RUN-COMMAN
          FCC 'LIST'
          DC.B $F1
          DC.B $F1
          DC.W CLIST-COMMAN
          FCC 'NEW'
          DC.B $F1
          DC.W UBASIC-COMMAN
          FCC 'GOSUB'
          DC.B $F1
          DC.W GOSUB-COMMAN
          FCC 'GOTO'
          DC.B $F1
          DC.B $F1
          DC.W GOTO-COMMAN
          FCC 'ON'
          DC.B $F1
          DC.B $F1
          DC.W ONGO-COMMAN
          FCC 'THEN'
          DC.B $F1
          DC.B $F1
          DC.W THEN-COMMAN
          FCC 'PRINT'
          DC.B $F1
          DC.W PRINT-COMMAN
          FCC 'LET'
          DC.B $F1
          DC.W LET-COMMAN
          FCC 'INPUT'
          DC.B $F1
          DC.W INPUT-COMMAN
          FCC 'IF'
          DC.B $F1
          DC.B $F1
          DC.W IF-COMMAN
          FCC 'READ'
          DC.B $F1
          DC.B $F1
          DC.W READ-COMMAN
          FCC 'DATA'
          DC.B $F1
          DC.B $F1
DATLOC    DC.W REMARK-COMMAN
          FCC 'RESTORE'
          DC.B $F1
          DC.W RESTOR-COMMAN
          FCC 'END'
          DC.B $F1
          DC.W READY-COMMAN
          FCC 'RETURN'
          DC.B $F1
          DC.B $F1
          DC.W RETURN-COMMAN
          FCC 'DIM'
          DC.B $F1
          DC.W DIM-COMMAN
          FCC 'FOR'
          DC.B $F1
          DC.W FOR-COMMAN
          FCC 'NEXT'
          DC.B $F1
          DC.B $F1
          DC.W NEXT-COMMAN
          FCC 'REM'
          DC.B $F1
          DC.W REMARK-COMMAN
          FCC 'STOP'
          DC.B $F1
          DC.B $F1
          DC.W STOP-COMMAN
          FCC 'POKE'
          DC.B $F1
          DC.B $F1
          DC.W EKOP-COMMAN
          FCC 'SOUND'
          DC.B $F1
          DC.W SOUND-COMMAN
          FCC 'MON'                RETURN TO HUMBUG
          DC.B $F1
          DC.W WARMS-COMMAN
BCOMEN    DC.B $F1
          DC.B $F1
IMPLET    DC.W LET-COMMAN
          FCC 'RND('
          DC.B $F1
          DC.B $F1
          DC.W RANDOM-COMMAN
          FCC 'TAB('
          DC.B $F1
          DC.B $F1
          DC.W TAB-COMMAN
          FCC 'INT('
          DC.B $F1
          DC.B $F1
          DC.W INT-COMMAN
          FCC 'CHR$('
          DC.B $F1
          DC.W CHR-COMMAN
          FCC 'PEEK('
          DC.B $F1
          DC.W MPIK-COMMAN
          FCC 'ABS('
          DC.B $F1
          DC.B $F1
          DC.W ABS-COMMAN
          FCC 'SGN('
FUNEND    DC.B $F1
          DC.B $F1
          DC.W SGN-COMMAN
WARMS     JMP WARMST                QUIT
RDYMSG    DC.B $0D,$0A
          FCC 'Ready'
          DC.B $0D,$0A
          DC.B $F1
DELMSG    FCC ' DELETE'
          DC.B $F1
BWHAT      FCC 'RE-ENTER'
          DC.B $F1
ERRMS1    FCC 'ERROR: '
          DC.B $F1
ERRMS2    FCC ' in line '
          DC.B $F1
DEL       LEA DELMSG,A2        DO ON CONTROL-C
          BSR.L OUTPUT             PRINT STRING & BCRLF
          BRA.S KEYBD0

* ALL PURPOSE KEYBD ROUTINE
KEYBD     MOVE.B #'?',D0
          BSR.L OUTCH
          BSR.L PRINSP             PRINT A SPACE
* SUBROUTINE ENTRY WITHOUT ""
KEYBD0    LEA BASBUF,A2        START OF KEYBD ROUTINE
KEYBD1    BSR.L CNISAB             GET A CHARACTER
          CMP.B #$18,D0            CONTROL-X?
          BEQ.S DEL
          CMP.B #$D,D0             IS IT CR?
          BEQ.S IEXIT              IF SO, EXIT
          CMP.B #$8,D0             BACKSPACE?
          BNE.S NOTBS
          LEA BASBUF,A5
          CMP.L A2,A5              IS IT FIRST CHAR
          BEQ.S KEYBD1             IF SO, JUST RELOOP
          SUB.L #1,A2              OTHERWISE BACKSPACE
          MOVE.L A2,-(A7)          PSH X
          MOVE.B #$20,D0
          BSR.L OUTCH              ERASE PREV CHARACTER
          MOVE.B #$08,D0
          BSR.L OUTCH              AND ANOTHER BS
          MOVE.L (A7)+,A2          PUL X
          BRA.S KEYBD1             AND THEN RELOOP

NOTBS     LEA BASBUF+72,A5
          CMP.L A2,A5
          BNE.S NOTBSO
          MOVE.B #$21,D1           INPUT LINE TOO LONG ERROR
          BRA.L ERROR              PRINT ERROR MESSAGE

NOTBSO    CMP.B #'a',D0
          BCS.S NOTBSL
          CMP.B #'z',D0
          BHI.S NOTBSL
          AND.B #$DF,D0            CHANGE LOWER TO UPPER CASE
NOTBSL    MOVE.B D0,(A2)+
          BRA.S KEYBD1

IEXIT     MOVE.B #$F1,D0           END WITH F1
          MOVE.B D0,0(A2)
          MOVE.L A2,ENDBUF         SAVE AS ENDBUF
          BRA.L BCRLF              DO CR AND EXIT

* HEX OUTPUT ROUTINES ETC.

BOUT4H    MOVE.B (A2),D7           NUMBER TO PRINT
          ASL.W #8,D7
          MOVE.B 1(A2),D7
          AND.W #$FFF0,D7
          BEQ.S O4H1S              SINGLE DIGIT
          AND.W #$FF00,D7
          BEQ.S O4H2S              TWO DIGITS
          AND.W #$F000,D7
          BEQ.S O4H3S              THREE DIGITS
          BRA.S O4H4               FOUR DIGITS
O4H3S     BSR.S O4HS               OUTPUT A SPACE
          BRA.S O4H3               AND THREE DIGITS
O4H2S     BSR.S O4HS
          BSR.S O4HS               OUTPUT TWO SPACES
          ADD.L #1,A2              SKIP FIRST BYTE
          BRA.S O4H2               AND TWO DIGITS
O4H1S     BSR.S O4HS
          BSR.S O4HS               OUTPUT THREE SPACES
          BSR.S O4HS
          ADD.L #1,A2              SKIP FIRST BYTE
          BRA.S O4H1               AND ONE DIGIT
O4H4      MOVE.B 0(A2),D0          PRINT FOUR DIGITS
          BSR.S BOUTHL              LEFT DIG
O4H3      MOVE.B (A2)+,D0          PRINT THREE DIGITS
          BSR.S BOUTHR              RIGHT DIG
O4H2      MOVE.B 0(A2),D0          PRINT TWO DIGITS
          BSR.S BOUTHL              LEFT DIG
O4H1      MOVE.B (A2)+,D0          PRINT ONE DIGIT
          BSR.S BOUTHR              RIGHT DIG
O4HS      MOVE.B #$20,D0           PRINT SPACE
          BSR.L BASOCH             PRINT
          RTS

OUT2HH    MOVE.B 0(A2),D0
          BSR.S BOUTHL              LEFT DIG
          MOVE.B (A2)+,D0
          BRA.S BOUTHR              RIGHT DIG

BOUTHL     LSR.B #4,D0              SHIFT RIGHT 4
BOUTHR     AND.B #$0F,D0
          ADD.B #'0',D0
          CMP.B #'9',D0
          BLS.L BASOCH
          ADD.B #7,D0              IF A-F
          BRA.L BASOCH

OUTCH     BSR.S BASBK
          BRA.L BASOCH

BASBK     JSR INCHEK               CHECK KBD STATUS
          BEQ.S BASBK1             NO BREAK
          JSR INCH7                GET CHARACTER
BASBK0    CMP.B #3,D5              CONTROL-C?
          BEQ.L READY              YES
BASBK1    RTS

* UNIVERSAL OUTPUT PRINT STRING & BCRLF ROUTINE
OUTPUT    BSR.S OUTNCR             PRINT STRING AND BCRLF
          BRA.S BCRLF

L014      BSR.L BASOCH
          ADD.L #1,A2
OUTNCR    MOVE.B 0(A2),D0          PRINT STRING UP TO $F1
          CMP.B #$F1,D0
          BNE.S L014
          RTS

BCRLF      MOVE.L A2,-(A7)          PSHS X
          LEA BCRLFST,A2
          BSR.S OUTNCR             PRINT STRING TO F1
          MOVE.L (A7)+,A2          PULS X,PC
          RTS

BCRLFST    DC.B $D
          DC.B $A
          DC.B $F1

STOREX    MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE
          MOVE.L A2,A4
          MOVE.L (A3),A2           RESTORE A2(X)
          BRA.S L018

STORE     MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE             BACKUP TO 1ST ARG
          MOVE.L A2,A4
          LEA -7(A2),A2            BACK TO VARIABLE ADDR
          MOVE.B 0(A2),D7
          ASL.L #8,D7
          MOVE.B 1(A2),D7
          ASL.L #8,D7
          MOVE.B 2(A2),D7
          ASL.L #8,D7
          MOVE.B 3(A2),D7
          MOVE.L D7,A2
L018      MOVE.B #5,D1             COPY 5 BYTES
L019      MOVE.B (A4)+,(A2)+
          SUB.B #1,D1
          BNE.S L019
          MOVE.B (A4)+,D0          SKIP 1
          MOVE.B (A4)+,(A2)
          MOVE.L (A3)+,A2          PULL X
          RTS

INDX      MOVE.L A2,-(A3)
          MOVE.L A2,A4
          BRA.S IND0

IND       MOVE.L A2,-(A3)
          BSR.L PULLAE
          MOVE.W A2,D7             CHECK WHETHER EVEN
          BTST #0,D7
          BEQ.S INDEV              EVEN, JUST DO MOVE.L
          MOVE.L -1(A2),D7         ODD, DO IN PIECES
          ASL.L #8,D7
          MOVE.B 3(A2),D7
          MOVE.L D7,A4
          BRA.S IND0
INDEV     MOVE.L 0(A2),A4
IND0      MOVE.B #5,D1             LDB #5
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
L01B      MOVE.B (A4)+,(A2)+
          SUB.B #1,D1              DECB
          BNE.S L01B
          MOVE.B (A4)+,D0
          MOVE.B D0,1(A2)
          CLR.B 0(A2)
          BSR.L PUSHAE
          MOVE.L (A3)+,A2
          RTS

* OUTPUT SOURCE LINE POINTED TO BY X
OUTLIN    BSR.L BOUT4H
          MOVE.B (A2)+,D0          GET TOKEN
          ASL.L #8,D0
          MOVE.B (A2)+,D0
          ASL.L #8,D0
          MOVE.B (A2)+,D0
          ASL.L #8,D0
          MOVE.B (A2)+,D0
          MOVE.L A2,-(A7)          SAVE X POINTER
          LEA IMPLET,A5
          CMP.L A5,D0              IS IT AN IMPLIED LET?
          BEQ.S ISLET              YES
          MOVE.L D0,A2
          SUB.L #2,A2              BACK TO LST LETR OR 1ST F1
L01F      MOVE.B -(A2),D0          BACKUP TO PREVIOUS CHAR
          CMP.B #$F1,D0            IS IT AN F1?
          BNE.S L01F               NO, GO BACK ANOTHER BYTE
          LEA 3(A2),A2             SKIP TO BEG OF KEY WORD
          BSR.L OUTNCR             PRINT STRING TO F1
          BSR.S PRINSP             PRINT A SPACE
ISLET     CLR.B PRCNT              CLEAR PRCNT
          MOVE.L (A7)+,A2          POINT BACK TO LINE
          BRA.L OUTPUT             PRINT REST OF CURRENT LINE

* PRINT A SPACE
PRINSP    MOVE.B D0,-(A7)
          MOVE.B #$20,D0
          BSR.L OUTCHA
          MOVE.B (A7)+,D0
          RTS

* FIND A VARIABLE
FINVAR    BSR.L SKIPSP             SKIP SPACES
          BSR.L TSTLTR             CHECK 1ST CHAR
          BCS.S FINV11             C=1 IF NOT A LETTER
          MOVE.L D0,D1
          MOVE.B 1(A2),D0          GET THE NEXT
          BSR.L TSTLTR             CHECK 2ND CHAR OF VAR NAME
          BCS.S FINV2              C=1 IF NOT A LETTER OR FN
          BSR.L FCODE              LOOK UP FUNCTION
          MOVE.L A2,-(A3)          PUSH X
          MOVE.L BASPNT,A2
          BSR.L PAREXP             EVALUATE PARAMETER
          MOVE.L A2,BASPNT
          MOVE.L (A3)+,A2          ADDR OF OFFSET
          CLR.L D7
          MOVE.W 0(A2),D7          OFFSET
          LEA COMMAN,A2
          ADD.L D7,A2              CALCULATE FN ADDRESS
          JSR (A2)                 GO DO FUNCTION
          BSR.L PUSHAE
          MOVE.L BASPNT,A2
          LEA 8(A7),A7             REMOVE 2 RETURN ADDRESSES
          RTS

FINV11    OR.B #2,CCR              SEV IF NOT A LETTER (I.E., NOT VARIABLE)
          RTS

FINV2     BSR.L TESTNO             TEST FOR NUMBER
          BCC.S FINV3
          CMP.B #'(',D0            CHECK FOR (
          BEQ.S FINV3
          SUB.L #1,A2
          MOVE.B #$20,D0
FINV3     LEA 2(A2),A2
          MOVE.L A2,-(A3)          PUSH X
          MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
FINV4     CMP.L ARRTAB,A2
          OR.B #$11,CCR            SET CARRY AND X
          BEQ.S FINV5
          CMP.B 0(A2),D1
          BNE.S FINV6
          CMP.B 1(A2),D0
          BNE.S FINV6
          AND.B #$EE,CCR           CLEAR X AND CARRY
FINV5     MOVEM.L A2-A2,VARPNT
          MOVEM.L (A3)+,A2-A2       PULL X
          AND.B #$FD,CCR           CLEAR V
          RTS

FINV6     MOVEM.W D0-D0,-(A7)
          MOVE.B 1(A2),D0
          CMP.B #'(',D0            CHECK FOR (
          MOVEM.W (A7)+,D0-D0      PULL BACK A
          BEQ.S FINV7
          BSR.L INXATE
          BRA.S FINV4

FINV7     MOVE.B 4(A2),D7
          ASL.L #8,D7
          MOVE.B 5(A2),D7
          ASL.L #8,D7
          MOVE.B 6(A2),D7
          ASL.L #8,D7
          MOVE.B 7(A2),D7
          MOVE.L D7,A2
          BRA.S FINV4

TSTV      BSR.L BASBK              CHECK FOR BREAK
          BSR.L FINVAR
          BVC.S TSTV1              V=1 IF NOT A VARIABLE
          RTS                      NOT VARIABLE

TSTV1     MOVEM.W D0-D0,-(A7)          WAS VARIABLE
          BCS.S TSTV4
          MOVE.L A2,BASPNT         SAVE BASPNT
          MOVE.L VARPNT,A2
          CMP.B #'(',D0            CHECK FOR (
          BEQ.S TSTV3
TSTV11    LEA 2(A2),A2
TSTV2     LEA VARPNT,A5
          MOVE.L A2,(A5)
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          MOVE.B 0(A5),0(A2)
          MOVE.B 1(A5),1(A2)       PUT ADDR OF VAR INTO AESTK
          MOVE.B 2(A5),2(A2)       A BYTE AT A TIME
          MOVE.B 3(A5),3(A2)
          BSR.L PUSHAE
          MOVEM.W (A7)+,D0-D0
          MOVE.L BASPNT,A2
          AND.B #$EE,CCR           CLEAR X AND C
          RTS

TSTV3     BSR.L GETPAR
          BCC.S TSTV33
TSTV31    BSR.L FIX
          BRA.S TSTV34

TSTV33    CLR.L D1
TSTV34    MOVE.B D1,-(A7)
          BSR.L FIX
          MOVE.L D1,D0
          MOVE.B (A7)+,D1
          BSR.L SUBCAL
          BRA.S TSTV2

TSTV4     MOVE.L A2,BASPNT
          MOVE.L VARPNT,A2
          MOVE.B D1,0(A2)
          MOVE.B D0,1(A2)
          CMP.B #'(',D0               CHECK FOR (
          BNE.S TSTV5
          MOVE.B #10,D1
          MOVE.B D1,2(A2)
          MOVE.B D1,3(A2)
          BSR.L GETPAR
          BCS.S TSTV44
          CLR.L D1
          MOVE.B D1,3(A2)
TSTV44    MOVE.B 2(A2),D0
          BSR.L DIMCAL
          TST.B 3(A2)
          BEQ.S TSTV33
          BRA.S TSTV31

TSTV5     BSR.L INXATE
          MOVE.L A2,ARRTAB
          MOVE.L VARPNT,A2
          BRA.L TSTV11

TSTLTR    CMP.B #'A',D0
          BMI.S NONO
          CMP.B #'Z',D0
          BLE.S YESNO
* CHECK IF NUMBER, RETURN C=1 IF NOT
TESTNO    CMP.B #'0',D0
          BMI.S NONO
          CMP.B #'9',D0
          BLE.S YESNO
NONO      OR.B #$11,CCR            SET CARRY AND X
          RTS

YESNO     AND.B #$EE,CCR
          RTS

PUSHAE    MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          BSR.L INXSEV
L040      MOVE.L A2,AESTK
          RTS

PULLAE    MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          LEA -7(A2),A2
          BRA.S L040

INXATE    LEA 8(A2),A2
          BRA.S IXCHEK

INXSEV    LEA 7(A2),A2
          BRA.S IXCHEK

INXSIX    ADD.L #1,A2
INXFIV    LEA 5(A2),A2
IXCHEK    CMP.L MEMENB,A2      BASIC'S MEMEND
          BMI.S L041
          BRA.L OVERFL             MEMORY OVERFLOW

L041      RTS

* FIX: CONVERT FLOATING POINT NUMBER TO INTEGER IN D1

FIX       MOVE.L A2,-(A3)          PUSH X
          BSR.S PULLAE             POINT TO FLT
          MOVE.B 6(A2),D0          CHECK CHARACTERISTIC
          CMP.B #4,D0              NG IF >4
          BLE.S L043
FIXERR    MOVE.B #1,D1             ERR 1 = VARIABLE >255
          BRA.L ERROR              PRINT ERROR MESSAGE

L043      CLR.L D0
          CLR.L D1
          CLR.L D7
          TST.B 6(A2)              TST 6,X
FIX2      BLS.S FIXEX
          MULU #10,D1              MULT PREVIOUS BY 10
          MOVE.B (A2),D7           NEXT DIGIT
          ADD.W D7,D1              ADD DIGIT INTO D1
          BSR.L ALLEFT             JSR ALLEFT
          SUB.B #1,6(A2)           DEC 6,X
          BRA.S FIX2

FIXEX     CMP.L #256,D1            ERROR IF D1>255
          BCC.S FIXERR
          MOVE.L (A3)+,A2          PULL X
          RTS

FACT      BSR.L SKIPSP             SKIP SPACES
          BSR.L TSTV               TEST IF A VARIABLE
          BCS.S L049               IF NOT A VARIABLE
          BRA.L IND

L049      BSR.L TSTN               TEST IF A NUMBER
          BCS.S L04C
          RTS

L04C      CMP.B #'(',D0
          BNE.S FACT3
          ADD.L #1,A2
PAREXP    BSR.S EXPR
          BSR.L SKIPSP             SKIP SPACES
          BNE.S L04F
          BNE.S FACT2
L04F      ADD.L #1,A2
          RTS

FACT2     MOVE.B #$13,D1           ERROR 13=PARENTHESIS ERROR
L051      BRA.L ERROR              PRINT ERROR MESSAGE

FACT3     MOVE.B #6,D1
          BRA.S L051

TERM      BSR.S FACT               GET FACTOR
TERM0     BSR.L SKIPSP             SKIP SPACES
          CMP.B #'*',D0
          BNE.S TERM1
          ADD.L #1,A2
          BSR.L SKIPSP             SKIP SPACES

          BSR.S FACT
          BSR.L MPY
          BRA.S TERM0

TERM1     CMP.B #'/',D0
          BNE.S TERM2
          ADD.L #1,A2
          BSR.S FACT
          BSR.L DIV
          BRA.S TERM0

TERM2     RTS

EXPR      BSR.L SKIPSP             SKIP SPACES
          CMP.B #'-',D0
          BNE.S L058
          ADD.L #1,A2
          BSR.S TERM               EVALUATE TERM
          BSR.S NEG
          BRA.S EXPR1

L058      CMP.B #'+',D0
          BNE.S L05C
          ADD.L #1,A2
L05C      BSR.S TERM               EVALUATE TERM
EXPR1     BSR.L SKIPSP             SKIP SPACES
          CMP.B #'+',D0
          BNE.S L05D
          ADD.L #1,A2
          BSR.S TERM
          BSR.L ADD
          BRA.S EXPR1

L05D      CMP.B #'-',D0
          BNE.S L05F
          ADD.L #1,A2
          BSR.S TERM
          BSR.L SUB
          BRA.S EXPR1

L05F      RTS

NEGOP     MOVE.L A2,-(A3)          PUSH X
          BSR.L INXSEV
          BRA.S L061

* NEGATE FLOATING POINT NUMBER (AESTK)-->

NEG       MOVE.L A2,-(A3)          PUSH X
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          LEA -2(A2),A2
          BRA.S L062
* ALTERNATE ENTRY, A2 POINTS TO IT
NEGACC    MOVE.L A2,-(A3)          PUSH X
L061      BSR.L INXFIV
L062      MOVEM.W D0-D1,-(A7)      PUSH
          MOVE.B #6,D1
NEGA11    MOVE.B #$99,D0           FIRST FIND 9'S COMPLEM
          SUB.B 0(A2),D0
          MOVE.B D0,0(A2)
          SUB.L #1,A2
          SUB.B #1,D1
          BNE.S NEGA11
          ADD.L #7,A2              POINT PAST MANTISSA BYTE 6
          LEA ZEROES+6,A5      AND POINT TO STRING OF ZEROES
          OR.B #$11,CCR            SET CARRY AND X
          ABCD -(A5),-(A2)
          ABCD -(A5),-(A2)         +1 TO CONV 9'S TO 10'S COMPL
          ABCD -(A5),-(A2)
          ABCD -(A5),-(A2)
          ABCD -(A5),-(A2)
          ABCD -(A5),-(A2)
          MOVE.L (A3)+,A2          PULL X
          MOVEM.W (A7)+,D0-D1
          RTS
ZEROES    DC.B 0,0,0,0,0,0         FOR NEGATE ABOVE

ALLEFT    MOVE.B D0,-(A7)          SHIFT FLT PT NUMBER 1 LEFT
          BSR.S LLEFT
          MOVE.B 0(A2),D0
          AND.B #$F,D0
          MOVE.B D0,0(A2)
          MOVE.B (A7)+,D0
          RTS

* REVISED LLEFT ROUTINE. A2 POINTS TO FIRST OF SIX BYTES
* TO BE SHIFTED LEFT 4 BITS

LLEFT     MOVE.B (A2),D6           BYTE 0
          ASL.L #8,D6
          MOVE.B 1(A2),D6          BYTE 1
          MOVE.B 2(A2),D7          BYTE 2
          ASL.L #8,D7
          MOVE.B 3(A2),D7          BYTE 3
          ASL.L #8,D7
          MOVE.B 4(A2),D7          BYTE 4
          ASL.L #8,D7
          MOVE.B 5(A2),D7          BYTE 5
          ASL.L #1,D7
          ROXL.L #1,D6             LEFT 1
          ASL.L #1,D7
          ROXL.L #1,D6             LEFT 2
          ASL.L #1,D7
          ROXL.L #1,D6             LEFT 3
          ASL.L #1,D7
          ROXL.L #1,D6             LEFT 4
          MOVE.B D7,5(A2)          BYTE 5
          LSR.L #8,D7
          MOVE.B D7,4(A2)          BYTE 4
          LSR.L #8,D7
          MOVE.B D7,3(A2)          BYTE 3
          LSR.L #8,D7
          MOVE.B D7,2(A2)          BYTE 2
          MOVE.B D6,1(A2)          BYTE 1
          LSR.L #8,D6
          MOVE.B D6,0(A2)          BYTE 0
          RTS

* REVISED LRIGHT ROUTINE. A2 POINTS TO FIRST OF SIX BYTES
* TO BE SHIFTED RIGHT 4 BITS

LRIGHT    MOVE.B (A2),D6
          ASL.L #4,D6              SAVE THE SIGN FROM BYTE 0
          MOVE.B (A2),D6           BYTE 0
          ASL.L #8,D6
          MOVE.B 1(A2),D6          BYTE 1
          MOVE.B 2(A2),D7          BYTE 2
          ASL.L #8,D7
          MOVE.B 3(A2),D7          BYTE 3
          ASL.L #8,D7
          MOVE.B 4(A2),D7          BYTE 4
          ASL.L #8,D7
          MOVE.B 5(A2),D7          BYTE 5
          ASR.L #1,D6
          ROXR.L #1,D7             RIGHT 1
          ASR.L #1,D6
          ROXR.L #1,D7             RIGHT 2
          ASR.L #1,D6
          ROXR.L #1,D7             RIGHT 3
          ASR.L #1,D6
          ROXR.L #1,D7             RIGHT 4
          MOVE.B D7,5(A2)          BYTE 5
          LSR.L #8,D7
          MOVE.B D7,4(A2)          BYTE 4
          LSR.L #8,D7
          MOVE.B D7,3(A2)          BYTE 3
          LSR.L #8,D7
          MOVE.B D7,2(A2)          BYTE 2
          MOVE.B D6,1(A2)          BYTE 1
          LSR.L #8,D6
          MOVE.B D6,0(A2)          BYTE 0
          RTS

NORMPA    MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE
          CLR.B NORSGN
          BSR.L TSTZER
          BCC.S NORMEZ
          MOVE.B 0(A2),D0
          BPL.S NORM1
          MOVE.B D0,NORSGN
          BSR.L NEGACC
NORM00    MOVE.B #$F,D0
          AND.B 0(A2),D0
          MOVE.B D0,0(A2)
NORM1     MOVE.B 0(A2),D0
          BNE.S NORMEX
          BSR.L ALLEFT
          SUB.B #1,6(A2)           DEC 6,X
          BRA.L NORM1

NORMEZ    CLR.B 6(A2)              CLR 6,X
NORMEX    CLR.B 5(A2)              CLR 5,X
          MOVE.B 6(A2),D0          LDA 6,X
          CMP.B #101,D0
          BLT.S NORME0
          MOVE.B D1,-(A7)
          MOVE.B #5,D1
          MOVE.B #$99,D0
NORM01    MOVE.B D0,(A2)+
          SUB.B #1,D1
          BNE.S NORM01
          MOVE.B #100,D0
          MOVE.B D0,1(A2)
          LEA -5(A2),A2
          MOVE.B (A7)+,D1
          BRA.S NORM00

NORME0    CMP.B #-99,D0
          BGT.S NORME1
          BSR.L CLRACC
NORME1    MOVE.B NORSGN,D7     TST
          BEQ.S NORME2
          BSR.L NEGACC
NORME2    BSR.L PUSHAE
          MOVE.L (A3)+,A2          PULL X
          RTS

SUB       BSR.L NEG
ADD       MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE
          BSR.L TSTZER
          BCC.S ADD4
          BSR.L LRIGHT
          ADD.B #1,6(A2)           INC 6,X
          BSR.L PULLAE
          BSR.L TSTZER
          BCC.S ADD1
ADD0      BSR.L LRIGHT
          ADD.B #1,6(A2)           INC 6,X
          MOVE.B 6(A2),D0          LDA 6,X
          CMP.B $D(A2),D0
          BEQ.S ADD2
          BLT.S ADD0
          BSR.S SWAP
          BRA.S ADD0

ADD1      BSR.S SWAP
ADD2      BSR.S ADDER
          BSR.L PUSHAE
          BSR.L NORMPA
ADD4      MOVE.L (A3)+,A2          PULL X
          RTS

SWAP      MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          MOVE.B D0,-(A7)
          MOVE.B D1,-(A7)
          MOVE.B #7,D1
SWAP1     MOVE.B 0(A2),D0
          MOVE.B D0,-(A7)
          MOVE.B 7(A2),D0
          MOVE.B D0,0(A2)
          MOVE.B (A7)+,D0
          MOVE.B D0,7(A2)
          ADD.L #1,A2
          SUB.B #1,D1
          BNE.S SWAP1
SWAP2     MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          MOVE.B (A7)+,D1
          MOVE.B (A7)+,D0
          RTS

* REVISED ADDER ROUTINE - ADDS TWO 6-BYTE BCD NUMBERS AT
* (AESTK) AND (AESTK+7)

ADDER     MOVE.L AESTK,A2      POINT TO FIRST ITEM TO ADD
          ADD.L #6,A2              POINT PAST SIXTH BYTE OF 1ST
          LEA 7(A2),A5             AND PAST SECOND ITEM
          AND.B #$EA,CCR           CLEAR X, Z, AND C
          ABCD -(A5),-(A2)         ADD BYTE 5
          ABCD -(A5),-(A2)         BYTE 4
          ABCD -(A5),-(A2)         BYTE 3
          ABCD -(A5),-(A2)         BYTE 2
          ABCD -(A5),-(A2)         BYTE 1
          ABCD -(A5),-(A2)         BYTE 0
          RTS

DIV       MOVE.L A2,-(A3)          PUSH X
          BSR.L CLRACC
          BSR.L PULLAE             DENOMINATOR
          BSR.L TSTZER             CHECK IF 0
          BCS.S L082
          MOVE.B #8,D1             ERROR 8=DIVIDE BY ZERO
          BRA.L ERROR              PRINT ERROR MESSAGE

L082      NEG.B 6(A2)
          BSR.S MDSIGN             CHECK SIGN AND SHIFT DEN RIGHT
          BSR.L LRIGHT             SHIFT NUM RIGHT TOO
          BSR.L NEGOP              NEGATE DENOM
          MOVE.B #11,D0
DIV2      CLR.L D1
DIV3      ADD.B #1,D1
          BSR.S ADDER
          TST.B 0(A2)
          BPL.S DIV3
          SUB.B #1,D1
          BSR.L NEGOP
          BSR.S ADDER
          BSR.L NEGOP
          BSR.L INXSEV
          BSR.L INXSEV
          BSR.L LLEFT
          ADD.B 5(A2),D1
          MOVE.B D1,5(A2)
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          BSR.L LLEFT
          SUB.B #1,D0
          BNE.S DIV2
          BSR.L PUSHAE
          BSR.L SWAP
          ADD.B #1,TNUMB
          BRA.L MDEXIT

MDSIGN    BSR.L LRIGHT
          CLR.L D0
          TST.B 0(A2)
          BPL.S MDS2
          BSR.L NEGACC             NEGATE IF -
          MOVE.B #$80,D0
MDS2      BSR.L PULLAE
          TST.B 0(A2)
          BPL.S MDS3
          BSR.L NEGACC             NEGATE IF -
          ADD.B #$80,D0
MDS3      MOVE.B D0,TSIGN          80 IF -, 0 IF +
          MOVE.B 6(A2),D0
          ADD.B $D(A2),D0
          BVC.S MDS4
          MOVE.B #$78,D0
          BCC.S MDS4
          NEG.B D0
MDS4      MOVE.B D0,TNUMB          POWER OF ANSWER
          RTS

MPY       MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE
          BSR.S MDSIGN
          MOVE.L A2,MPYXX          WHERE TO PUT ANSWER
          BSR.L PUSHAE             RESERVE ROOM
          BSR.L SWAP
          BSR.L CLRACC             CLEAR CURRENT TERM
          MOVE.B #9,D0
MPY4      MOVE.L MPYXX,A2      POINT TO 1ST
          MOVE.B 0(A2),D1
          BSR.L ALLEFT
MPY5      TST.B D1
          BEQ.S MPY6
          BSR.L ADDER
          SUB.B #1,D1
          BRA.S MPY5

MPY6      MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          BSR.L INXSEV
          BSR.L LRIGHT
          SUB.B #1,D0
          BNE.S MPY4
MDEXIT    BSR.L PULLAE
          BSR.L SWAP
          MOVE.B TNUMB,D0
          MOVE.B D0,6(A2)
          BSR.L PUSHAE
          BSR.L NORMPA
          MOVE.B TSIGN,D7
          BPL.S MDEX2
          BSR.L NEG
MDEX2     MOVE.L (A3)+,A2          PULL X
          RTS

* FIND LINE NUMBER IN PACKLN IN THE SOURCE CODE

BASFIN    MOVE.W HIGHLN,D1
          SUB.W PACKLN,D1
          BCS.S HIBALL             IF ABOVE HIGHEST LINE
FINDN1    MOVE.L SOURCE,A2     PTR TO BEG OF BASIC SOURCE
FIND0     MOVE.W PACKLN,D1
          MOVE.B (A2),D7
          ASL.W #8,D7              LINE NUMBER FROM SOURCE
          MOVE.B 1(A2),D7
          SUB.W D7,D1              COMPARE
          BCS.S L090
          BEQ.S L092
L091      ADD.L #1,A2
L093      ADD.L #1,A2
          MOVE.B 0(A2),D0
          CMP.B #$F1,D0
          BNE.S L093
          ADD.L #1,A2
          CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BNE.S FIND0
HIBALL    MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
L090      MOVE.L A2,WORKBA
          OR.B #$11,CCR            SEC
          RTS
L092      MOVE.L A2,WORKBA         ADDR WHERE TO PUT IT
          RTS

* SKIP SPACES POINTED TO BY X, LEAVE CHAR IN A

SKIPSP    MOVE.B 0(A2),D0
          CMP.B #$20,D0            IS IT A SPACE?
          BNE.S L095
          ADD.L #1,A2
          BRA.S SKIPSP             LEAVE CHAR IN D0

L095      RTS

* READ LINE NUM FROM INPUT LINE & PUT IN PACKLN

LINENO    BSR.L TSTN
          BCC.S L096
LINE0     MOVE.B #7,D1             ERR 7 = NONEXISTENT LINE NUM
          BRA.L ERROR              PRINT ERROR MESSAGE

L096      MOVE.L A2,BUFNXT
          BSR.L PULLAE
          MOVE.B 6(A2),D1          LDB 6,X
          BLS.S LINE0
          CMP.B #4,D1
          BGT.S LINE0
          MOVE.B #5,D0
          SUB.B D1,D0              SBA
L099      TST.B D0
          BEQ.S L098
          BSR.L LRIGHT
          SUB.B #1,D0
          BRA.S L099

L098      MOVE.B 1(A2),D0
          LEA PACKLN,A5
          MOVE.B D0,(A5)
          MOVE.B 2(A2),D0          2,X
          MOVE.B D0,1(A5)          PACKLN+1
          MOVE.L BUFNXT,A2
          AND.B #$EE,CCR           CLC
          RTS

* SAVE START ADDR OF NEXT LINE INTO BASLIN

NXTLIN    MOVE.L BASPNT,A2
L09A      MOVE.B (A2)+,D0
          CMP.B #$F1,D0
          BNE.S L09A
          MOVE.L A2,BASLIN
          RTS

* FIND FUNCTION IN COMMAND TABLE

FCODE     MOVE.L A2,BUFNXT
          LEA IMPLET+1,A2
          BRA.S LOOP3

CCINT     MOVE.L A2,BUFNXT
          LEA INTER-1,A2
          BRA.S LOOP3

* FIND COMMAND IN KEYWORD COMMAND TABLE
CCODE     BSR.L SKIPSP
          MOVE.L A2,BUFNXT
          LEA COMMAN-1,A2      KEYWORD COMMAND TABLE-1
LOOP3     MOVE.L BUFNXT,A4
L09F      ADD.L #1,A2
L09D      MOVE.B (A4)+,D0          PULU A
          CMP.B #$20,D0            IS IT SPACE?
          BEQ.S L09D
          MOVE.B 0(A2),D1
          CMP.B #$F1,D1
          BEQ.S L09E
          CMP.B D1,D0
          BEQ.S L09F
LOOP5     ADD.L #1,A2
          LEA BCOMEN,A5
          CMP.L A2,A5
          BEQ.S CCEXIT
          LEA FUNEND,A5
          CMP.L A5,A2
          BEQ.L DBLLTR
          MOVE.B 0(A2),D1
          CMP.B #$F1,D1
          BNE.S LOOP5
          MOVE.B 1(A2),D1          CHECK NEXT BYTE AFTER THE F1
          CMP.B #$F1,D1            IS IT ANOTHER F1?
          BNE.S LOOP5A             NO
          ADD.L #1,A2              YES, SO SKIP OVER IT TOO
LOOP5A    LEA 2(A2),A2
          BRA.S LOOP3

L09E      ADD.L #1,A2
          MOVE.B (A2),D7           LOOK AT NEXT AFTER F1 DELIM
          CMP.B #$F1,D7            IS IT ANOTHER F1?
          BEQ.S L09E               YES, SO SKIP OVER IT
          LEA -1(A4),A4
          MOVE.L A4,BUFNXT
          MOVE.L A4,BASPNT
          RTS

CCEXIT    LEA IMPLET,A2
          RTS

* NEW - INITIALIZE ALL EMPTY
NEWSUB    LEA FILE,A2          NEW
          MOVE.L A2,SOURCE         PTR TO BEG OF BASIC SOURCE
          MOVE.L A2,NEXTBA         PTR TO NEXT EMPTY
          MOVE.L A2,ARRTAB
          CLR.W HIGHLN
          CLR.B PRCNT
          RTS


* COLD START

UBASIC    MOVE.B #1,BAFLAG         SIGNAL BASIC IS RUNNING
          LEA SIGNON,A2
          BSR.L OUTPUT             PRINT STRING & BCRLF PRINT SIGNON
          LEA BSTACK,A7
          LEA EROR25,A5
          MOVEM.L A5-A5,-(A7)         PUT ERROR 25 ADDR ON STACK
          BSR.S NEWSUB             INIT ALL EMPTY
          BRA.L RUN

SIGNON    DC.B $0D,$0A
          FCC 'You are now in BASIC.'
          DC.B $0D,$0A,$F1

* WARM START, BASBRK, CTROL-C, END, ETC

BASOFT    EQU *
READY     LEA BSTACK,A7
          LEA EROR25,A5
          MOVEM.L A5-A5,-(A7)         PUT ERROR 25 ADDR ON STACK
          LEA XSTACK,A3        X STACK POINTER
          LEA RDYMSG,A2        PRINT "READY"
          BSR.L OUTPUT
NEWLIN    CLR.B PRCNT
          BSR.L KEYBD0             GET NEXT LINE INTO BASBUF
          LEA BASBUF,A2
          BSR.L SKIPSP             SKIP SPACES
          BSR.L TESTNO             TEST FOR NUMBER
          BCS.S L0A8               IF NOT NUMBER
          BSR.L NUMBER
          BRA.S NEWLIN

L0A8      CMP.B #$F1,D0
          BEQ.S NEWLIN
          BSR.L CCODE              FIND COM CODE, RETURN ADDR
          CLR.L D7
          MOVE.W 0(A2),D7          GET OFFSET TO ROUTINE
          LEA COMMAN,A2        POINT TO COMMAND TABLE
          ADD.L D7,A2              ADD IN OFFSET
          JMP 0(A2)                AND GO TO ROUTINE


* ERROR ROUTINE - PRINT ERROR MESSAGE FOR CODE IN D1

ERROR     LEA BSTACK,A7
          LEA EROR25,A5
          MOVEM.L A5-A5,-(A7)         PUT ERROR 25 ADDR ON STACK
          BSR.L BCRLF
          LEA ERRMS1,A2        PRINT "ERROR"
          BSR.L OUTNCR

          MOVE.B D1,D7
          AND.W #$F,D7             UNITS DIGIT ONLY
          ASR.B #4,D1
          AND.W #$F,D1             TENS DIGIT ONLY
          MULU #10,D1              *10
          ADD.W D7,D1              COMBINE TO MAKE BINARY
          SUB.W #1,D1              TABLE STARTS WITH 0
          MULU #21,D1              EACH STRING IS 21 BYTES
          LEA ERRTAB,A2
          ADD.L D1,A2              POINT TO ERROR STRING
          BSR.L OUTNCR             PRINT ERROR STRING

          LEA FILE-1,A5            POINT BETWEEN LINBUF AND FILE
          MOVE.L BASPNT,D0     POINTER TO TEXT BEING DONE
          CMP.L A5,D0
          BCS.S ERROR3             DIRECT IF D0< HERE
          LEA ERRMS2,A2        PRINT "IN LINE"
          BSR.L OUTNCR
          MOVE.L BASNUM,A2     CURR LINE INTERPRETED
ERROR2    BSR.L BOUT4H             PRINT LINE NUMBER
ERROR3    BSR.L BCRLF
          BRA.L READY


ERRTAB    DC.B 'Variable >255',$F1,0,0,0,0,0,0,0
          DC.B 'Error in INPUT',$F1,0,0,0,0,0,0
          DC.B 'Illegal/missing char',$F1
          DC.B 'Missing quote',$F1,0,0,0,0,0,0,0
          DC.B 'Error in DIM',$F1,0,0,0,0,0,0,0,0
          DC.B 'Illegal arithmetic',$F1,0,0
          DC.B 'Line not found',$F1,0,0,0,0,0,0
          DC.B 'Divide by zero',$F1,0,0,0,0,0,0
          DC.B 'Too many GOSUBs',$F1,0,0,0,0,0
          DC.B 'RETURN without GOSUB',$F1
          DC.B 'Illegal variable',$F1,0,0,0,0
          DC.B 'Miscellaneous error',$F1,0
          DC.B 'Parenthesis error',$F1,0,0,0
          DC.B 'Memory full',$F1,0,0,0,0,0,0,0,0,0
          DC.B 'Bad subscript',$F1,0,0,0,0,0,0,0
          DC.B 'Too many FORs',$F1,0,0,0,0,0,0,0
          DC.B 'NEXT without FOR',$F1,0,0,0,0
          DC.B 'Loop nesting error',$F1,0,0
          DC.B 'Error in READ',$F1,0,0,0,0,0,0,0
          DC.B 'Error in ON',$F1,0,0,0,0,0,0,0,0,0
          DC.B 'Line too long',$F1,0,0,0,0,0,0,0
          DC.B 'Number too large',$F1,0,0,0,0
          DC.B 'File name error',$F1,0,0,0,0,0
          DC.B 'Disk I/O error',$F1,0,0,0,0,0,0
          DC.B 'Bad Function Use',$F1,0,0,0,0

EROR25    MOVE.B #$25,D1           ERROR 25 = CALL A FUNCTION
          BRA.L ERROR              .. DIRECTLY

* RUN STATEMENT

RUN       MOVE.L SOURCE,A2     PTR TO BEG OF BASIC SOURCE
          MOVE.L A2,DATPNT
          MOVE.L A2,BASLIN
          LEA SBRSTK,A2        SUBROUTINE STACK
          MOVE.L A2,SBRPNT         SUBR STACK PTR
          LEA FORSTK,A2
          MOVE.L A2,FORPNT         FOR STACK POINTER
          MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
          MOVE.L A2,ARRTAB
          LEA FILTOP,A5            TOP OF AVAILABLE RAM
          MOVE.L A5,D7
          AND.B #$F0,D7            GO DOWN TO 16-BYTE BOUNDARY
          MOVE.L D7,MEMENB         BASIC'S MEMEND
* NOW ZERO OUT MEMORY FROM (A2) UP TO MEMENB
ZERLO1    CLR.B (A2)+              CLEAR ONE
          MOVE.L A2,D6
          AND.B #$0F,D6            16-BYTE BOUNDARY NEXT?
          BNE.S ZERLO1             NO, CLEAR ONE MORE BYTE
ZERLO2    CLR.L (A2)+
          CLR.L (A2)+              CLEAR 16 BYTES AT A TIME
          CLR.L (A2)+
          CLR.L (A2)+
          CMP.L A2,D7              AT MEMEND?
          BNE.S ZERLO2             NO, DO MORE
          BRA.L BASIC

* LIST COMMAND

CLIST     MOVE.L NEXTBA,D0         NET EMPTY
          CMP.L SOURCE,D0          COMPARE WITH BEG
          BEQ.L REMARK             QUIT IF NOTHING TO LIST
          MOVE.L BASPNT,A2
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #$F1,D0
          BEQ.S CLIST4             IF NO LINE NUMBERS SPECIFIED
          BSR.L LINENO
          MOVE.L A2,BASPNT
          BSR.L FINDN1
          MOVE.L A2,INDEX3
          MOVE.L BASPNT,A2
          BSR.L SKIPSP
          CMP.B #$F1,D0
          BEQ.S CLIST3
          ADD.L #1,A2
          BSR.L LINENO
CLIST3    ADD.B #1,PACKLN+1        GO PAST DESIRED LINE NUM
          BSR.L FINDN1
          MOVE.L INDEX3,A2
          BRA.S CLIST5

CLIST4    MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
          MOVE.L A2,WORKBA
          MOVE.L SOURCE,A2     PTR TO BEG OF BASIC SOURCE
CLIST5    CMP.L WORKBA,A2
          BEQ.S CLEXT
          CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BEQ.S CLEXT
          BSR.L OUTLIN             OUTPUT SOURCE LINE X>
          ADD.L #1,A2
          BRA.S CLIST5

CLEXT     BRA.L REMARK

NUMBER    BSR.L LINENO             LINE NUMBER INTO PACKLN
          BSR.L BASFIN             DOES IT EXIST?
          BCC.S DELREP             YES, DELETE OLD AND REPLACE
          MOVE.L BUFNXT,A2     NO, POINT TO REST OF LINE
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #$F1,D0            LINE EMPTY?
          BEQ.S NEXIT              YES, QUIT
          MOVE.L WORKBA,A2
          CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BEQ.S CAPPEN             APPEND IF AT END
          BSR.L INSERT             ELSE INSERT NEW LINE
          BRA.S NEXIT

DELREP    MOVE.L BUFNXT,A2
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #$F1,D0            ANYTHING TO DELETE?
          BNE.S REPLAC             YES
          MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
          CMP.L SOURCE,A2      PTR TO BEG OF BASIC SOURCE
          BEQ.S NEXIT
          BSR.S DELETE
          BRA.S NEXIT

REPLAC    BSR.S DELETE
          BSR.S INSERT
NEXIT     RTS

CAPPEN    BSR.S INSERT
          MOVE.W PACKLN,A2
          MOVE.W A2,HIGHLN
          BRA.S NEXIT

DELETE    MOVE.L WORKBA,A2     LINE TO DELETE
          MOVE.L NEXTBA,A4     PTR TO NEXT EMPTY
          LEA 2(A2),A2
          LEA -2(A4),A4
DEL2      MOVE.B (A2)+,D0          LOOK FOR F1 AT END OF DEL LINE
          LEA -1(A4),A4            STEP BACK AT SAME TIME
          CMP.B #$F1,D0
          BNE.S DEL2
          MOVE.L A4,NEXTBA         STORE NEXT EMPTY
          MOVE.L A4,ARRTAB
          MOVE.L A2,A4
          MOVE.L WORKBA,A2
DEL4      CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BEQ.S DELEX
          MOVE.B (A4)+,D0          PULU A
          MOVE.B D0,(A2)+
          BRA.S DEL4

DELEX     RTS

INSERT    MOVE.L BUFNXT,A2     POINT TO INPUT LINE TEXT
          BSR.L CCODE              FIND COM CODE, POINT TO OFFSET

          MOVE.L A2,KEYWD
          MOVE.L NEXTBA,A2     PTR TO NEXT EMPTY
          MOVE.L A2,INDEX1
          MOVE.L ENDBUF,D1
          SUB.L BUFNXT,D1      LENGTH OF LINE PAST KWD
          ADD.L #7,D1              PLUS 7 BYTES
          ADD.L NEXTBA,D1      PTR TO NEXT EMPTY
          CMP.L MEMENB,D1      BASIC'S MEMEND
          BHI.S OVERFL             MEMORY OVERFLOW
          MOVE.L D1,NEXTBA         PTR TO NEXT EMPTY
          MOVE.L D1,A2             PTR TO NEXT EMPTY
          MOVE.L A2,ARRTAB
          MOVE.L A2,A4
          MOVE.L INDEX1,A2     BEG OF NEW LINE
INS2      CMP.L WORKBA,A2
          BEQ.S BUFWRT
          MOVE.B -(A2),D0          MOVE UP IF NOT NEEDED
          MOVE.B D0,-(A4)
          BRA.S INS2

BUFWRT    MOVE.B PACKLN,(A2)+  GET PACKED LINE NUMBER
          MOVE.B PACKLN+1,(A2)+ SECOND BYTE
          MOVE.B KEYWD+0,(A2)+
          MOVE.B KEYWD+1,(A2)+
          MOVE.B KEYWD+2,(A2)+ POINTER TO OFFSET
          MOVE.B KEYWD+3,(A2)+
          MOVE.L BUFNXT,A4
L0CF      MOVE.B (A4)+,D0
          MOVE.B D0,(A2)+
          CMP.B #$F1,D0
          BNE.S L0CF
          RTS

OVERFL    MOVE.B #$14,D1           MEMORY FULL ERROR
          BRA.L ERROR              PRINT ERROR MESSAGE

BASIC     LEA COMMAN,A2        KEYWORD COMMAND TABLE
          MOVE.L A2,KEYWD
          LEA ASTACK,A2        ARITH EXPR STACK
          MOVE.L A2,AESTK          ARITH EXPR STACK PTR
          MOVE.L BASLIN,A2
          MOVE.L A2,BASNUM         CURR LINE INTERPRETED
          CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BNE.S L0D0               NOT BSTARTING FRESH
L0D1      BRA.L READY

* WHEN RUNNING, BASLIN POINTS TO NEXT LINE TO DO (A LARGE ADDRD);
* OTHERWISE, IT POINTS TO THE KEYBOARD BASBUF BUFFER (A SMALL ADDR)
L0D0      MOVE.L BASLIN,D7
          LEA FILE-1,A5            POINTER BETWEEN
          CMP.L A5,D7              COMPARE THE TWO
          BCS.S L0D1               READY IF PTR TO KBD BUFF
          LEA 2(A2),A2             ELSE RUN: SKIP LINENUM
          MOVE.B (A2)+,D7
          ASL.L #8,D7
          MOVE.B (A2)+,D7          GET TOKEN
          ASL.L #8,D7
          MOVE.B (A2)+,D7
          ASL.L #8,D7
          MOVE.B (A2)+,D7
          MOVE.L A2,BASPNT         SAVE POINTER TO NEXT
          MOVE.L D7,A2             TOKEN
          MOVE.W (A2),D7           OFFSET
          LEA COMMAN,A2
          ADD.W D7,A2              COMPUTE ROUTINE ADDRESS
          JMP 0(A2)                AND GO DO IT

THEN      MOVE.L BASPNT,A2
          BSR.L SKIPSP             SKIP SPACES
          BSR.L TESTNO             TEST FOR NUMBER
          BCC.L GOTO
          BRA.L IF2

ONERR     MOVE.B #$20,D1           ERROR IN ON STATEMENT
          BRA.L ERROR              PRINT ERROR MESSAGE

ONGO      MOVE.L BASPNT,A2
          BSR.L EXPR
          BSR.L FIX
          TST.B D1
          BEQ.S ONERR
          SUB.B #1,D1
          MOVE.B D1,ONLOOP
          BSR.L CCODE              FIND COM CODE, RETURN OFFSET

          CLR.L D7
          MOVE.W 0(A2),D7          GET OFFSET TO ROUTINE
          LEA COMMAN,A2        POINT TO COMMAND TABLE
          ADD.L D7,A2              ADD IN OFFSET

          LEA GOTO,A5
          CMP.L A5,A2
          BEQ.S GOTOP3
          LEA GOSUB,A5
          CMP.L A5,A2
          BEQ.S L0D7
          BRA.S ONERR

GOSUB     CLR.B ONLOOP             CLEAR ONLOOP
L0D7      MOVE.L BASLIN,A2     POINT TO NEXT LINE OF SOURCE
          BSR.L NXTLIN
          MOVE.L SBRPNT,A2     SUBR STACK PTR
          LEA SBRSTK+32,A5
          CMP.L A5,A2              SUBROUTINE STACK+32
          BNE.S GOSUB1
          MOVE.B #9,D1             EXCESSIVE SUBROUTINE NESTING
          BRA.L ERROR              PRINT ERROR MESSAGE

GOSUB1    MOVE.L BASLIN,(A2)+  ADDR OF NEXT AFTER GOSUB ON STK
          MOVE.L A2,SBRPNT         SUBR STACK PTR
          BRA.S GOTOP3

GOTO      CLR.B ONLOOP             CLEAR ONLOOP
GOTOP3    MOVE.L BASPNT,A2
GOTO1     BSR.L LINENO
          SUB.B #1,ONLOOP
          BMI.S L0D9
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #',',D0
          BNE.L ONERR
          ADD.L #1,A2
          BRA.S GOTO1

L0D9      BSR.L BASFIN             FIND LINE NUMBER
          BCC.S GOTO2
          MOVE.B #7,D1             NONEXISTENT LINE NUMBER
          BRA.L ERROR              PRINT ERROR MESSAGE

GOTO2     MOVE.L A2,BASLIN
          BRA.L BASIC

RETURN    MOVE.L SBRPNT,A2     SUBR STACK PTR
          LEA SBRSTK,A5
          CMP.L A5,A2              COMP W SUBROUTINE STACK
          BNE.S L0DC
          MOVE.B #$10,D1           RETURN W/O GOSUB
          BRA.L ERROR              PRINT ERROR MESSAGE

L0DC      LEA -4(A2),A2
          MOVE.L A2,SBRPNT         FIX UP SBR STACK POINTER
          MOVE.L 0(A2),A2          PULL SUBR RETURN ADDR
          BRA.S GOTO2

STOP      LEA STOMSG,A2
          BSR.L OUTNCR             PRINT STRING TO F1
          BSR.L PRINSP             PRINT A SPACE
          MOVE.L BASLIN,A2
          BRA.L ERROR2             PRINT ERROR MESSAGE

STOMSG    FCC 'STOP IN LINE',$F1

INPUT     MOVE.L BASPNT,D0
          BNE.S L0DD
          MOVE.B #2,D1             ERROR IN INPUT
          BRA.L ERROR              PRINT ERROR MESSAGE

L0DD      BSR.L KEYBD
          LEA BASBUF,A2
          MOVE.L A2,BUFNXT
          MOVE.L BASPNT,A2
INPUT1    BSR.L TSTV
          BCS.S INPEX
          MOVE.L A2,BASPNT
          MOVE.L BUFNXT,A2
INPUT2    BSR.S INNUM
          BCC.S INPUT4
          CMP.B #$F1,D0
          BEQ.S L0E2
          LEA BWHAT,A2
          BSR.L OUTPUT             PRINT STRING & BCRLF
L0E2      BSR.L KEYBD
          LEA BASBUF,A2
          BRA.S INPUT2

INPUT4    BSR.L STORE
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #',',D0
          BNE.S INPUT5
          ADD.L #1,A2
INPUT5    MOVE.L A2,BUFNXT
          MOVE.L BASPNT,A2
          BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #',',D0
          BEQ.S INPUT1
INPEX     SUB.L #1,A2
          CLR.B PRCNT              CLEAR PRCNT
          CMP.B #$F1,D0
          BNE.S DBLLTR
          BRA.L REMARK

DBLLTR    MOVE.B #3,D1             ILLEGAL CHAR OR VARIABLE
          BRA.L ERROR              PRINT ERROR MESSAGE

INNUM     BSR.L SKIPSP             SKIP SPACES
          MOVE.B D0,TSIGN
          ADD.L #1,A2
          CMP.B #'-',D0
          BEQ.S INNUM0
          SUB.L #1,A2
TSTN      CLR.B TSIGN              TEST FOR A NUMBER
INNUM0    CLR.L D0
          MOVE.B D0,SIGDIG
          MOVE.B D0,DECFLG
          MOVE.B D0,TOGGLE
          BSR.L CLRACC             CLEAR FP ACCUM
          LEA INDEX4,A5
          MOVE.L AESTK,(A5)
          MOVE.B #5,D1
INTST1    BSR.L SKIPSP             SKIP SPACES
          BSR.L TESTNO             TEST FOR NUMBER CHECK IF A NUMBER
          BCC.S L0E8               YES
          CMP.B #'.',D0
          BNE.S L0E9
          MOVE.B D0,DECFLG
          ADD.L #1,A2
          BRA.S INTST1

L0E9      OR.B #$11,CCR
          RTS

L0E8      SUB.L #1,A2
INTST2    ADD.L #1,A2
          MOVE.B 0(A2),D0
          BSR.L TESTNO             TEST FOR NUMBER
          BCS.S MAYEXP             IF NOT A NUMBER
          SUB.B #'0',D0
          BNE.S INTST3
          MOVE.B SIGDIG,D7
          BNE.S INTST4
          MOVE.B DECFLG,D7
          BEQ.S INTST2
          SUB.B #1,EXP
          BRA.S INTST2

INTST3    MOVE.B D0,SIGDIG
INTST4    MOVE.L A2,-(A3)
          MOVE.L INDEX4,A2
          TST.B D1
          BEQ.S INTST6
          MOVE.B TOGGLE,D7
          BNE.S INTST5
          ADD.B 0(A2),D0
          MOVE.B D0,(A2)+
          SUB.B #1,D1
          BRA.S INTS55

INTST5    ASL.B #4,D0
          MOVE.B D0,0(A2)          STA 0,X
INTS55    NOT.B TOGGLE
INTST6    MOVE.L A2,INDEX4
          MOVE.B DECFLG,D7
          BNE.S INTS66
          ADD.B #1,EXP
INTS66    MOVE.L (A3)+,A2          PULL X
          BRA.S INTST2

MAYEXP    MOVE.B DECFLG,D7
          BNE.S MAYEX2
          CMP.B #'.',D0
          BNE.S MAYEX2
          MOVE.B D0,DECFLG
          BRA.L INTST2

MAYEX2    CLR.L D1
          CMP.B #'E',D0
          BNE.S INNEX
          ADD.L #1,A2
          MOVE.B 0(A2),D0
          CMP.B #'-',D0
          BEQ.S INTST9
          CMP.B #'+',D0
          BNE.S INTST8
          ADD.L #1,A2
INTST8    BSR.S FORMEX
          BRA.S INNEX

INTST9    ADD.L #1,A2
          BSR.S FORMEX
          NEG.B D1
INNEX     MOVE.B EXP,D0
          ADD.B D1,D0
          MOVE.L A2,-(A3)
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
          MOVE.B D0,6(A2)
          BSR.L PUSHAE
          MOVE.L (A3)+,A2          PULL X
          MOVE.B TSIGN,D7
          BEQ.S L0F8
          BSR.L NEG
L0F8      AND.B #$EE,CCR
          RTS

CLRACC    MOVE.L A2,-(A3)          PUSH X
          MOVE.B D1,-(A7)
          MOVE.B #7,D1
          MOVE.L AESTK,A2      ARITH EXPR STACK PTR
L0F9      CLR.B (A2)+             CLEAR AE STACK
          SUB.B #1,D1
          BNE.S L0F9
          CLR.B EXP
          MOVE.B (A7)+,D1
          MOVE.L (A3)+,A2          PULL X
          RTS

FORMEX    MOVE.B 0(A2),D0
          BSR.L TESTNO             TEST FOR NUMBER
          BCC.S L0FA
          MOVE.B #2,D1             ERROR IN INPUT
          BRA.L ERROR              PRINT ERROR MESSAGE

L0FA      SUB.B #'0',D0
          MOVE.L D0,D1
          ADD.L #1,A2
          MOVE.B 0(A2),D0
          BSR.L TESTNO             TEST FOR NUMBER
          BCS.S L0FB
          ASL.B #1,D1
          MOVE.L D1,D0
          ASL.B #2,D1
          ADD.B D1,D0
          MOVE.L D0,D1
          MOVE.B (A2)+,D0
          SUB.B #'0',D0
          ADD.B D1,D0
          MOVE.L D0,D1
L0FB      RTS

* READ STATEMENT

READ      MOVE.L BASPNT,A2     GET POINTER
READ1     BSR.L TSTV               CHECK READ VARIABLE
          BCS.L READEX             IF ERROR
          MOVE.L A2,BASPNT         SAVE CURRENT POINTER
          MOVE.L DATPNT,A2
          CMP.L SOURCE,A2      CHECK IF DATA PTR AT BEGINNING
          BEQ.S READ33             YES, BSTART FRESH
* COME HERE WITH A2-> DATA ITEM TO READ
READ2     BSR.L INNUM
          BCC.S READ4
          MOVE.B -(A2),D0
          CMP.B #$F1,D0
          BEQ.S READ3
RDERR     MOVE.B #$19,D1           ERROR IN READ
          BRA.L ERROR              PRINT ERROR MESSAGE

READ3     CMP.L NEXTBA,A2      PTR TO NEXT EMPTY
          BEQ.S RDERR              QUIT IF AT END
          MOVE.B (A2)+,D0
          CMP.B #$F1,D0            LOOK FOR END OF STATEMENT
          BNE.S READ3              KEEP LOOKING

READ33    MOVE.B 2(A2),D0          GET STATEMENT TOKEN
          ASL.L #8,D0
          MOVE.B 3(A2),D0
          ASL.L #8,D0
          MOVE.B 4(A2),D0
          ASL.L #8,D0
          MOVE.B 5(A2),D0
          LEA DATLOC,A5
          CMP.L A5,D0              IS IT DATA STATEMENT?
          BNE.S READ3              NO, KEEP READING
          LEA 6(A2),A2             YES, POINT TO FIRST DATA
          BRA.S READ2              CONTINUE

READ4     BSR.L STORE
          ADD.L #1,A2
          MOVE.L A2,DATPNT
          MOVE.L BASPNT,A2
          BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #',',D0
          BEQ.L READ1
READEX    SUB.L #1,A2
          CMP.B #$F1,D0
          BNE.S RDERR
          BRA.L REMARK

RESTOR    MOVE.L SOURCE,A2     PTR TO BEG OF BASIC SOURCE
          MOVE.L A2,DATPNT
          MOVE.L BASPNT,A2
          BRA.L REMARK

PRINT     MOVE.L BASPNT,A2
PRINT0    BSR.L SKIPSP             SKIP SPACES
          CMP.B #'"',D0            IS IT A STRING?
          BNE.S PRINT4             NO
          ADD.L #1,A2              YES, SKIP PAST "
PRINT1    MOVE.B (A2)+,D0
          CMP.B #'"',D0
          BEQ.L PRIN88
          CMP.B #$F1,D0
          BNE.S PRINT2
          MOVE.B #4,D1
          BRA.S PRINTE

PRINT2    BSR.L OUTCHA
          BRA.S PRINT1

PRINT4    CMP.B #$F1,D0            END?
          BNE.S PRINT8             NO
          SUB.L #1,A2
          MOVE.B (A2)+,D0
          CMP.B #';',D0
          BEQ.S PRINT5
          BSR.L BCRLF
          CLR.B PRCNT
PRINT5    ADD.L #1,A2
          MOVE.L A2,BASLIN
          BRA.L BASIC

PRINTE    BRA.L ERROR              PRINT ERROR MESSAGE

CHR       MOVE.L BASPNT,A2
          BSR.L FIX
          MOVE.L D1,D0
          BSR.L OUTCHA
PRINT6    LEA BSTACK,A7
          LEA EROR25,A5
          MOVEM.L A5-A5,-(A7)         PUT ERROR 25 ADDR ON STACK
          BRA.S PRIN88

TAB       MOVE.L BASPNT,A2
          BSR.L FIX
          SUB.B PRCNT,D1
          BLS.S PRINT6
PRIN77    BSR.L PRINSP             PRINT A SPACE
          SUB.B #1,D1
          BNE.S PRIN77
          BRA.S PRINT6

PRINT8    BSR.L EXPR               EVALUATE EXPRESSION
          BSR.L PRN
PRIN88    BSR.L SKIPSP             SKIP SPACES
          CMP.B #',',D0
          BNE.S PRIN99
          ADD.L #1,A2
BPLOOP    MOVE.B PRCNT,D0
          MOVE.L D0,D1
          AND.B #$F0,D1
          SUB.B D1,D0
          BEQ.S PRI999
          BSR.L PRINSP             PRINT A SPACE
          BRA.S BPLOOP

PRIN99    CMP.B #';',D0
          BNE.S PREND
          ADD.L #1,A2
PRI999    BRA.L PRINT0

PREND     CMP.B #$F1,D0
          BEQ.L PRINT4
          MOVE.B #6,D1
          BRA.L PRINTE

OUTPNT    MOVE.B #'.',D0
          BRA.S OUTCHA

OUTZER    CLR.L D0
OUTDIG    AND.B #$F,D0
          ADD.B #'0',D0
OUTCHA    MOVE.B D0,-(A7)
          BSR.L OUTCH
          MOVE.B (A7)+,D0
ENLINE    MOVE.B D1,-(A7)
          MOVE.B PRCNT,D1
          ADD.B #1,D1
          CMP.B #71,D1
          BLS.S ENLEXT
          CMP.B #79,D1
          BEQ.S L113
          CMP.B #$20,D0
          BNE.S ENLEXT
L113      BSR.L BCRLF
          CLR.L D1
ENLEXT    MOVE.B D1,PRCNT
          MOVE.B (A7)+,D1
          RTS

PRN       MOVE.L A2,-(A3)          PUSH X
          BSR.L PULLAE             SUBTRACT 7 FROM AESTK ARITH EXPR STACK PTR
          CLR.L D0
          MOVE.B D0,DECFLG
          TST.B 0(A2)              CHECK IF ZERO
          BNE.S PRN1
          BSR.S OUTZER
PRN0      MOVE.L (A3)+,A2          PULL X
          BRA.L PRINSP             PRINT A SPACE

PRN1      TST.B 0(A2)
          BPL.S PRN2
          MOVE.B #'-',D0
          BSR.S OUTCHA
          BSR.L NEGACC
PRN2      MOVE.B 6(A2),D0          CHECK EXPONENT
          CMP.B #9,D0
          BGT.S PRISCI             IF SCIENTIFIC
          CMP.B #-1,D0
          BLT.S PRISCI
          TST.B D0
          BGT.S PRN4
          BSR.L OUTZER
          BSR.L OUTPNT
          MOVE.B D0,DECFLG
PRN3      TST.B 6(A2)
          BPL.S PRN5
          BSR.L OUTZER
          ADD.B #1,6(A2)
          BRA.S PRN3

PRN4      MOVE.B DECFLG,D7
          BNE.S PRN5
* OUTPUT DIGITS UNTIL DECIMAL POINT
PRN44     MOVE.B 0(A2),D0
          BSR.L OUTDIG
          BSR.L ALLEFT
          SUB.B #1,6(A2)
          BNE.S PRN44
          BSR.L TSTZER             IS REST ZERO?
          BCC.S PRN0
          BSR.L OUTPNT
PRN5      BSR.S PRTAIL
          BRA.S PRN0

PRISCI    MOVE.B 0(A2),D0
          BSR.L OUTDIG
          BSR.L ALLEFT
          BSR.L OUTPNT
          BSR.S PRTAIL
          MOVE.B #'E',D0
          BSR.L OUTCHA
          MOVE.B 6(A2),D1
          SUB.B #1,D1
          BPL.S PRISC2
          MOVE.B #'-',D0
          BSR.L OUTCHA
          NEG.B D1
PRISC2    CLR.L D0
PRSCI3    ADD.B #1,D0
          SUB.B #10,D1
          BPL.S PRSCI3
          SUB.B #1,D0
          ADD.B #10,D1
          BSR.L OUTDIG
          MOVE.L D1,D0
          BSR.L OUTDIG
          BRA.L PRN0

PRTAIL    BSR.S TSTZER
          BCC.S PRTAEX
          MOVE.B 0(A2),D0
          BSR.L OUTDIG
          BSR.L ALLEFT
          BRA.S PRTAIL

PRTAEX    RTS

* REVISED TEST ZERO ROUTINE - CHECKS WHETHER AESTK NUMBER = 0

TSTZER    MOVE.L AESTK,A5
          MOVE.L A5,D7
          BTST #0,D7               CHECK ODD OR EVEN
          BEQ.S TZEVEN             EVEN
TZODD     TST.B (A5)               BYTE 0
          BNE.S TSTZNZ             NOT ZERO
          TST.L 1(A5)              BYTES 1-5
          BNE.S TSTZNZ             NOT ZERO
          TST.B 5(A5)              BYTE 6
          BNE.S TSTZNZ             NOT ZERO
TSTZZE    AND.B #$EE,CCR           ZERO
          RTS
TZEVEN    TST.L (A5)               BYTES 0-3
          BNE.S TSTZNZ             NOT ZERO
          TST.W 4(A5)              BYTES 4-5
          BEQ.S TSTZZE             ZERO
TSTZNZ    OR.B #$11,CCR            NOT ZERO
          RTS

LET       MOVE.L BASPNT,A2
          BSR.L TSTV
          BCC.S L126
LET0      MOVE.B #$12,D1
LET00     BRA.L ERROR              PRINT ERROR MESSAGE

L126      BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #'=',D0
          BEQ.S L127
LET2      MOVE.B #6,D1
          BRA.S LET00

L127      BSR.L EXPR
          CMP.B #$F1,D0
          BNE.S LET2
          BSR.L STORE
REMARK    BSR.L NXTLIN
          BRA.L BASIC

GETPAR    MOVE.L A2,-(A3)          PUSH X
          MOVE.L BASPNT,A2
          BSR.L EXPR
          ADD.L #1,A2
          CMP.B #',',D0
          BEQ.S GETPA2
          CMP.B #')',D0
          BNE.S DIMERR
          MOVE.L A2,BASPNT
          MOVE.L (A3)+,A2          PULL X
          AND.B #$EE,CCR
          RTS

GETPA2    BSR.L PAREXP
          MOVE.L A2,BASPNT
          MOVE.L (A3)+,A2          PULL X
          OR.B #$11,CCR
          RTS

DIM       MOVE.L BASPNT,A2
L12F      BSR.L FINVAR             EVALUATE VARIABLE
          BVS.S DIMERR             IF ERROR
          BCS.S DIM1
DIMERR    MOVE.B #5,D1             ERROR IN DIM
          BRA.L ERROR

DIM1      CMP.B #'(',D0            (?
          BNE.S DIMERR             NO
          MOVE.L A2,BASPNT         YES, SAVE POINTER TO VAR
          MOVE.L VARPNT,A2
          MOVE.B D1,0(A2)          SAVE VAR NAME
          MOVE.B D0,1(A2)          SAVE (
          BSR.S GETPAR             GET SECOND PARAMETER
          BCC.S DIM3               IF MISSING
          BSR.L FIX                CVT 2ND TO INT IN D1
          BRA.S DIM4

DIM3      CLR.L D1                 2ND IS 0 IF NONE
DIM4      MOVE.B D1,3(A2)          SAVE 2ND SIZE
          BSR.L FIX                CVT 1ST TO INT IN D1
          MOVE.L D1,D0
          MOVE.B D0,2(A2)          SAVE 1ST SIZE
          BSR.S DIMCAL             CALC SIZE OF ARRAY
          MOVE.L BASPNT,A2
          BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #',',D0            ANOTHER DIM ON SAME LINE?
          BEQ.S L12F               YES, GO DO IT
          SUB.L #1,A2              NO
          BRA.L REMARK             QUIT

* CALCULATE SIZE OF DIM ARRAY AND STORE
DIMCAL    MOVE.L A2,-(A3)          PUSH X
          MOVE.B 3(A2),D1          GET 2ND SIZE
          BSR.S SUBCAL             FIND WHERE IS LAST ELEMENT
          BSR.L INXSIX             ADD 6 FOR LAST ELEMENT
          MOVE.L A2,ARRTAB         STORE IN ARRAY TAB
          MOVE.L A2,D7
          MOVE.L (A3)+,A2          PULL X
          MOVE.B D7,7(A2)
          LSR.L #8,D7              SAVE NEXT FREE ADDR
          MOVE.B D7,6(A2)
          LSR.L #8,D7
          MOVE.B D7,5(A2)
          LSR.L #8,D7
          MOVE.B D7,4(A2)
          RTS

* SUBCAL - ENTER WITH D0 AND D1 = TWO SUBSCRIPTS, RETURN WITH
*          A2 = ADDRESS OF ELEMENT IN MEMORY
SUBCAL    TST.B D0
          BNE.S SUBC1
SUBERR    MOVE.B #$15,D1           SUBSCRIPT ERROR
          BRA.L ERROR              PRINT ERROR MESSAGE

SUBC1     CMP.B 2(A2),D0
          BHI.S SUBERR
          CMP.B 3(A2),D1           CHECK IF VALIDLY STORED
          BHI.S SUBERR
          MOVE.B D0,-(A7)          PUSH PARAMETER 1
          MOVE.B 2(A2),D0
          MOVE.B D0,ANUMB
          TST.B D1                 CHECK PARAMETER B
          BEQ.S SUBC6              IF ZERO
SUBC4     SUB.B #1,D1
          BEQ.S SUBC6
          MOVE.B ANUMB,D0
SUBC5     BSR.L INXSIX
          SUB.B #1,D0
          BNE.S SUBC5
          BRA.S SUBC4

SUBC6     MOVE.B (A7)+,D0
SUBC7     BSR.L INXSIX
          SUB.B #1,D0
          BNE.S SUBC7
          ADD.L #2,A2              ADD 2 FOR EXTRA BYTES IN ADDR
          BSR.L IXCHEK             CHECK IT
          RTS

FOR       MOVE.L BASPNT,A2     POINT TO LOOP VAR IN SOURCE
          BSR.L TSTV               CHECK AND PASS IT
          BCC.S FOR1               IF A VALID VAR
          BRA.L LET0               ELSE ERROR 12

FOR1      MOVE.L A2,BASPNT         POINT TO THE =
          MOVE.L AESTK,A2
          LEA -7(A2),A2
          MOVE.B 0(A2),D0
          ASL.L #8,D0
          MOVE.B 1(A2),D0
          ASL.L #8,D0              ADDRESS OF LOOP VAR
          MOVE.B 2(A2),D0
          ASL.L #8,D0
          MOVE.B 3(A2),D0
          LEA FORSTK,A2        FOR STACK
L13A      CMP.L FORPNT,A2      CHECK WHETHER AT END OF STACK
          BEQ.S FOR14              YES, AT END
          CMP.L 0(A2),D0           NO, BUT VAR ALREADY THERE?
          BEQ.S FOR14              YES, USE IT
FOR12     ADD.L #20,A2             NO, KEEP LOOKING
          BRA.S L13A

FOR14     LEA FORSTK+200,A5
          CMP.L A5,A2              AT END OF STACK SPACE?
          BNE.S FOR11              NO, OK TO GO ON
          MOVE.B #16,D1            YES, TOO MANY
          BRA.L ERROR              PRINT ERROR MESSAGE

FOR11     MOVE.L D0,(A2)+          SAVE VARIABLE ADDRESS
          MOVE.L A2,FORPNT         SAVE FOR STACK POINTER
          MOVE.L BASPNT,A2     BACK TO SOURCE LINE
          BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #'=',D0
          BNE.L LET2               ERROR 6

FOR3      BSR.L EXPR               EVALUATE FIRST EXPRESSION
          BSR.L STORE              STORE IT INTO VARIABLE (6B)
          BSR.L CCINT              SEARCH TABLE FOR 'TO'
          LEA TOPNT,A5
          CMP.L A5,A2              IS IT TO?
          BNE.L LET2               NO, ERROR
          MOVE.L BASPNT,A2     YES, POINT TO 2ND EXPR
          BSR.L EXPR               EVALUATE IT
          MOVE.L A2,BASPNT         SAVE POINTER
          MOVE.L FORPNT,A2
          BSR.L STOREX             PUT TO NUMBER IN FOR STACK
          BSR.L INXSIX             UP 6
          MOVE.L A2,FORPNT         SAVE FOR STACK POINTER
          MOVE.L BASPNT,A2
          BSR.L CCINT              SEARCH TABLE FOR 'STEP'
          LEA STEPNT,A5
          CMP.L A5,A2              IS IT STEP?
          BNE.S FOR4               NO, DEFAULT TO 1
          MOVE.L BASPNT,A2     YES, POINT TO EXPRESSION
          BSR.L EXPR               EVALUATE IT
          MOVE.L A2,BASPNT         SAVE POINTER
          BRA.S FOR5               GO USE IT

FOR4      MOVE.L AESTK,A2      DEFAULT TO 1 IF NO STEP SIZE
          BSR.L CLRACC
          MOVE.B #1,D0
          MOVE.B D0,0(A2)          1 MANTISSA
          MOVE.B D0,6(A2)          1 CHARACTERISTIC
          BSR.L PUSHAE
FOR5      MOVE.L FORPNT,A2     FOR STACK POINTER
          BSR.L STOREX             STORE STEP IN FOR STACK
          BSR.L INXSIX             UP 6
          MOVE.L A2,FORPNT         SAVE FOR POINTER
          MOVE.L BASPNT,A2     POINT TO SOURCE LINE
          BSR.L SKIPSP             SKIP SPACES
          CMP.B #$F1,D0            MUST BE AT END
FOR8      BNE.L LET2               ELSE ERROR
          ADD.L #1,A2
          MOVE.L A2,BASLIN         BEGINNING OF NEXT STATEMENT
          MOVE.L FORPNT,A2     FOR STACK POINTER
          MOVE.L BASLIN,(A2)+  ADDR OF NEXT LINE INTO FOR STK
          MOVE.L A2,FORPNT         SAVE FOR STACK POINTER
          BRA.L BASIC              AND CONTINUE

NEXT      MOVE.L BASPNT,A2
          BSR.L TSTV               CHECK VARIABLE AFTER NEXT
          BCC.S NEXT1              IF VALID
          BRA.L LET0               ELSE ERROR 12

NEXT1     BSR.L SKIPSP             SKIP SPACES
          CMP.B #$F1,D0            END OF LINE?
          BNE.S FOR8               NO, ERROR 6
          ADD.L #1,A2
          MOVE.L A2,BASLIN         SAVE POINTER
          BSR.L PULLAE             POINT TO VARIABLE ON STACK
          MOVE.B 0(A2),D0
          ASL.L #8,D0
          MOVE.B 1(A2),D0
          ASL.L #8,D0
          MOVE.B 2(A2),D0          ADDRESS OF VARIABLE
          ASL.L #8,D0
          MOVE.B 3(A2),D0
          MOVE.L FORPNT,A2     FOR STACK POINTER
          LEA FORSTK,A5
          CMP.L A5,A2              CHECK WHETHER STACK EMPTY
          BEQ.L NEXT6              YES, ERROR 17
NEXT2     MOVE.L A2,FORPNT         NO: BSTART FROM END
          LEA FORSTK,A5
          CMP.L A5,A2              AT BEGINNING?
          BEQ.L NEXT5              YES, ERROR 18
          LEA -20(A2),A2           GO BACK 20
          CMP.L 0(A2),D0           CHECK PREV ENTRY
          BNE.S NEXT2              IF NOT THE SAME
          MOVE.L A2,FORNOW         SAVE ENTRY FOR THIS VARIABLE
          MOVE.L 0(A2),A2          POINT TO VARIABLE
          BSR.L INDX               PUT ITS VALUE ON STACK
          MOVE.L FORNOW,A2
          LEA 10(A2),A2            POINT TO STEP VALUE
          MOVE.B #2,D0
          TST.B 0(A2)
          BPL.S L149
          ADD.B #3,D0
L149      MOVE.B D0,NCMPR
          BSR.L INDX               COPY STEP TO STACK
          BSR.L ADD                ADD STEP TO VARIABLE
          LEA FORTMP,A2
          BSR.L STOREX             TEMP SAVE IT
          BSR.L PUSHAE
          MOVE.L FORNOW,A2
          LEA 4(A2),A2             POINT TO TEST VALUE
          BSR.L INDX               PUT ON STACK
          BSR.L CMPR               COMPARE WITH VARIABLE
          BCC.S NEXT4              IF NEED TO REPEAT AGAIN
          MOVE.L FORNOW,A2
          MOVE.L A2,FORPNT         ELSE REMOVE CURR ENTRY
          BRA.L BASIC

NEXT4     LEA FORTMP,A2        NEW VALUE FOR VARIABLE
          BSR.L INDX
          MOVE.L FORNOW,A2
          MOVE.L 0(A2),A2
          BSR.L STOREX             PUT INTO VARIABLE ITSELF
          MOVE.L FORNOW,A2
          MOVE.L 16(A2),A2         GET ADDRESS OF NEXT LINE
          MOVE.L A2,BASLIN         SAVE IT
          BRA.L BASIC              AND RETURN

NEXT5     MOVE.B #$18,D1
          BRA.S L14D

NEXT6     MOVE.B #$17,D1           NEXT W/O FOR
L14D      BRA.L ERROR

IF        MOVE.L BASPNT,A2
          BSR.L EXPR
          BSR.S RELOP
          MOVE.B D0,NCMPR
          BSR.L EXPR
          MOVE.L A2,BASPNT
          BSR.L CMPR
          BCC.S IF2
          BRA.L REMARK

IF2       MOVE.L BASPNT,A2
          BSR.L CCODE              FIND COM CODE, RETURN ADDR

          CLR.L D7
          MOVE.W 0(A2),D7          GET OFFSET TO ROUTINE
          LEA COMMAN,A2        POINT TO COMMAND TABLE
          ADD.L D7,A2              ADD IN OFFSET
          JMP 0(A2)                AND GO TO ROUTINE


RELOP     BSR.L SKIPSP             SKIP SPACES
          ADD.L #1,A2
          CMP.B #'=',D0
          BNE.S RELOP0
          MOVE.B #0,D0
          RTS

RELOP0    MOVE.B (A2),D1
          CMP.B #'<',D0
          BNE.S RELOP4
          CMP.B #'=',D1
          BNE.S RELOP1
          ADD.L #1,A2
          MOVE.B #2,D0
          RTS

RELOP1    CMP.B #'>',D1
          BNE.S RELOP3
RELOP2    ADD.L #1,A2
          MOVE.B #3,D0
          RTS

RELOP3    MOVE.B #1,D0
          RTS

RELOP4    CMP.B #'>',D0
          BEQ.S REL44
          MOVE.B #6,D1
          BRA.L ERROR              PRINT ERROR MESSAGE

REL44     CMP.B #'=',D1
          BNE.S RELOP5
          ADD.L #1,A2
          MOVE.B #5,D0
          RTS

RELOP5    CMP.B #'<',D1
          BEQ.S RELOP2
          MOVE.B #4,D0
          RTS

CMPR      BSR.L SUB
          BSR.L PULLAE
          MOVE.B (A2),D0
          CLR.L D1
          MOVE.B NCMPR,D1
          ASL.B #2,D1
          LEA COMPR1,A2         POINT TO TABLE
          TST.B D0
          JMP 0(A2,D1)


COMPR1     BEQ.S OKCMPR
          BRA.S NOCMPR

          BMI.S OKCMPR
          BRA.S NOCMPR

          BMI.S OKCMPR
          BRA.S COMPR1

          BNE.S OKCMPR
          BRA.S NOCMPR

          BEQ.S NOCMPR
          BMI.S NOCMPR
          BPL.S OKCMPR
NOCMPR    OR.B #$11,CCR
          RTS

OKCMPR    AND.B #$EE,CCR
          RTS

INT       BSR.L PULLAE
          MOVE.B #9,D1
          SUB.B 6(A2),D1
INT2      TST.B D1
          BLE.S INT4
          BSR.L LRIGHT
          ADD.B #1,6(A2)
          SUB.B #1,D1
          BRA.S INT2

INT4      CLR.B 5(A2)
          BSR.L PUSHAE
          BSR.L NORMPA
          BRA.L PULLAE

SGN       BSR.L PULLAE
          MOVE.B (A2),D0
          BEQ.S DUMRTS
          MOVE.B D0,TSIGN
          BSR.L CLRACC
          MOVE.B #1,D0
          MOVE.B D0,0(A2)
          MOVE.B D0,6(A2)
          MOVE.B TSIGN,D7
          BPL.S DUMRTS
SGN33     BRA.L NEGACC

DUMRTS    RTS

ABS       BSR.L PULLAE
          TST.B (A2)
          BPL.S DUMRTS
          BRA.S SGN33

RANDOM    BSR.L PULLAE
          BSR.L TSTZER
          BCC.S RAND1
          BSR.L PUSHAE
          BRA.S L15E

RAND1     LEA RANNUM,A2
          BSR.L INDX
L15E      LEA MUL4RN,A2
          BSR.L INDX
          BSR.L MPY
          BSR.L PULLAE
          BSR.L ALLEFT
          MOVE.B 1(A2),D0
          MOVE.B D0,-(A7)
          MOVE.B 3(A2),D0
          MOVE.B D0,1(A2)
          MOVE.B (A7)+,D0
          MOVE.B D0,3(A2)
          CLR.B 6(A2)
          BSR.L PUSHAE
          BSR.L NORMPA
          LEA RANNUM,A2
          BRA.L STOREX

MUL4RN    DC.B $08,$37,$25,$41,$69,$00

* BFIX FUNCTION - CONVERTS FLOAT TO FIX, LIKE FIX, BUT FOR
* LARGER NUMBERS

BFIX      MOVEM.L A2-A2,-(A3)         PUSH X
          BSR.L PULLAE             POINT TO FLOAT ARG
          MOVE.B 6(A2),D0          CHECK CHARACTERISTIC
          CMP.B #9,D0              NG IF >9
          BLE.S BFIX1
BFIXER    MOVE.B #22,D1            ERR 22 = NUMBER TOO LARGE
          BRA.L ERROR              PRINT ERROR MESSAGE

BFIX1     CLR.L D1
          CLR.L D7
          TST.B 6(A2)              TST 6,X
BFIX2     BLS.S BFIXEX
          ASL.L #1,D1              X2
          BCS.S BFIXER             ERROR IF CARRY OUT
          MOVE.L D1,-(A7)          TEMP ON STACK
          ASL.L #2,D1              X8
          BCS.S BFIXER             ERROR IF CARRY OUT
          ADD.L (A7)+,D1           X10
          BCS.S BFIXER             ERROR IF CARRY OUT
          MOVE.B (A2),D7           NEXT DIGIT
          ADD.L D7,D1              ADD DIGIT INTO D1
          BCS.S BFIXER             ERROR IF CARRY OUT
          BSR.L ALLEFT
          SUB.B #1,6(A2)
          BRA.S BFIX2

BFIXEX    MOVE.L (A3)+,A2          PULL X
          RTS


* PEEK ROUTINE

MPIK      MOVEM.L A2-A2,-(A3)         PUSH X
          BSR.S BFIX               FLOAT TO BIG FIX
          MOVE.L D1,A5
          CLR.L D4
          MOVE.B (A5),D4           GET BYTE BEING PEEKED
          MOVE.L AESTK,A2
          BSR.L CLRACC             CLEAR AE STACK
          MOVE.B #9,6(A2)          POWER=9
          DIVU #100,D4             HUNDREDS DIGIT
          MOVE.B D4,4(A2)          ...INTO STACK
          BSR.L LLEFT
          SWAP D4
          AND.L #$FF,D4
          DIVU #10,D4              TENS DIGIT
          ADD.B 4(A2),D4
          MOVE.B D4,4(A2)          ...INTO STACK
          BSR.L LLEFT
          SWAP D4                  UNITS DIGIT
          ADD.B 4(A2),D4
          MOVE.B D4,4(A2)          ...INTO STACK
          BSR.L PUSHAE
          BSR.L NORMPA
          BSR.L PULLAE
          MOVEM.L (A3)+,A2-A2
          RTS

* POKE ROUTINE

EKOP      BSR.L GETPAR             GET PARAMETER
          BCC.L FACT2              IF ERROR
          BSR.L FIX                GET CONTENTS
          MOVE.L D1,D4             SAVE IT
          BSR.L BFIX               GET ADDRESS
          MOVE.L D1,A5
          MOVE.B D4,(A5)           STORE NUMBER
          MOVE.L BASPNT,A2
          MOVE.L A2,BASLIN
          BRA.L BASIC

* SOUND ROUTINE

SOUND     BSR.L GETPAR             GET PARAMETER
          BCC.L FACT2              IF ERROR
          BSR.L FIX
          MOVE.B D1,DUART1+DCTUPR   SET TONE FREQUENCY
          MOVE.B #0,DUART1+DCTLOW
          BSR.L FIX                GET TIME FOR SOUND
          LSL #8,D1
          MOVE.B #$04,DUART1+DOPORT TURN ON CTR/TMR OUTPUT ON OP3
SOULOO    DIVU #1,D1               WAIT A BIT
          DIVU #1,D1
          DIVU #1,D1
          DIVU #1,D1
          DBRA D1,SOULOO
          MOVE.B #$00,DUART1+DOPORT TURN OFF CTR/TMR OUTPUT
          MOVE.L BASPNT,A2
          MOVE.L A2,BASLIN
          BRA.L BASIC

* MAIN CHARACTER I/O ROUTINES.

BASOCH    MOVE.B D0,D4
          JSR OUTEEE               OUTPUT THE CHARACTER
OUTRTS    RTS


CNISAB    JSR INEEE                GET CHARACTER FROM SK*DOS
          MOVE.B D5,D0
          BRA.L BASBK0

* JUMP VECTOR TO ALLOW BOOT OF OTHER DOS. DISABLED RIGHT NOW,
* CAN BE REPLACED BY JUMP TO ANOTHER BOOT ROUTINE LATER

X1BOOT    JMP.L COMEND


          END