00001 *************************
00002 *
00003 * CF83COR2.ASM
00004 * MDJ 06-13-91
00005 *
00006 * CF83 CORE WORDS
00007 * SET #2
00008 *
00009 * INTERSTACK WORDS
00010 *
00011 * DEVICE LAYER WORDS
00012 *
00013 * INTERPRETER LAYER WORDS
00014 * FIRST PART OF TWO
00015 *
00016 *************************
00017 *
00018 * MUST ALTER  ON
00019 * ==========  ==
00020 * CF83COR1    ZTORN
00021 * CF83COR3    ZDEFNN
00022 * CF83COR5    ZHEREC
00023 * CF83COR6    ZDEFNC
00024 *
00025 *************************
00026 *
00027 ZLLOTN  EQU     $6457
00028 ZXORN   EQU     $6292
00029 COLON   EQU     $07
00030 SEMI    EQU     $0D
00031 DPDP    EQU     $1B
00032 BLKL    EQU     $2B
00033 BB1A    EQU     $30
00034 BB2A    EQU     $32
00035 BB3A    EQU     $34
00036 BB4A    EQU     $36
00037 BB1B    EQU     $38
00038 BB2B    EQU     $3A
00039 BB3B    EQU     $3C
00040 BB4B    EQU     $3E
00041 BB1O    EQU     $40
00042 BB2O    EQU     $41
00043 BB3O    EQU     $42
00044 BB1U    EQU     $44
00045 BB2U    EQU     $45
00046 BB3U    EQU     $46
00047 BB4U    EQU     $47
00048 ZLOCKP  EQU     $5338
00049 ZLOCKQ  EQU     $541A
00050 ZLOCKW  EQU     $548F
00051 TIB     EQU     $01DA
00052 CONTXT  EQU     $098B
00053 CURENT  EQU     $098D
00054 VAF26   EQU     $09F9
00055         ORG     $62A4
00056 ZTORN   FCB     2
00057         FCC     />R/
00058 TORL    FDB     ZXORN
 
 
 
 
 
 
 
 
00059         FDB     RFROMN
00060 TORC    FDB     *+2
00061 TORP    PSHS    A,B     MAKE SPACE ON RETURN STACK
00062         PSHS    A,B     SAVE REGISTERS
00063         PULU    A,B     GET NUMBER FROM U-STACK
00064         STD     2,S     MOVE NUMBER TO RETURN STACK
00065         PULS    A,B     RESTORE REGISTERS
00066         LDX     ,Y++
00067         JMP     [,X++]
00068 RFROMN  FCB     2
00069         FCC     /R>/
00070 RFROML  FDB     ZTORN
00071         FDB     RATN
00072 RFROMC  FDB     *+2
00073 RFROMP  PSHU    A,B     MAKE SPACE ON U-STACK
00074         PSHU    A,B     SAVE REGISTERS
00075         PULS    A,B     GET NUMBER FROM RETURN STACK
00076         STD     2,U     MOVE NUMBER TO U-STACK
00077         PULU    A,B     RESTORE REGISTERS
00078         LDX     ,Y++
00079         JMP     [,X++]
00080 RATN    FCB     2
00081         FCC     /R@/
00082 RATL    FDB     RFROMN
00083         FDB     BUFFN
00084 RATC    FDB     *+2
00085 RATP    PSHS    A,B     SAVE REGISTERS
00086         LDD     2,S     GET NUMBER FROM RETURN STACK
00087         PSHU    A,B     COPY NUMBER TO U-STACK
00088         PULS    A,B     RESTORE REGISTERS
00089         LDX     ,Y++
00090         JMP     [,X++]
00091 BUFFN   FCB     6
00092         FCC     /BUFFER/
00093 BUFFL   FDB     RATN
00094         FDB     SAVBN
00095 BUFFC   FDB     *+2
00096 BUFFP   JMP     ZLOCKP  BUFFER = SYNONYM FOR BLOCK
00097 SAVBN   FCB     12
00098         FCC     /SAVE-BUFFERS/
00099 SAVBL   FDB     BUFFN
00100         FDB     FLUSHN
00101 SAVBC   FDB     *+2
00102 SAVBP   PSHS    A,B,X,Y
00103         LDY     BB1A    CLEAR BLOCK BUFFER #0
00104         LDX     BB1B
00105         LDA     BB1U    GET UPDATE CODE
00106         CLR     BB1U
00107         CMPA    #0      HAS BUFFER BEEN UPDATED?
00108         BEQ     SAVB1   GO IF NO
00109         JSR     ZLOCKQ  GO CALCULATE DRIVE, TRACK, SECTOR
00110         JSR     ZLOCKW  GO WRITE BLOCK TO DISK
00111 SAVB1   LDY     BB2A    CLEAR BLOCK BUFFER #1
00112         LDX     BB2B
00113         LDA     BB2U    GET UPDATE CODE
00114         CLR     BB2U
00115         CMPA    #0      HAS BUFFER BEEN UPDATED?
00116         BEQ     SAVB2   GO IF NO
 
 
 
 
 
 
 
 
00117         JSR     ZLOCKQ  GO CALCULATE DRIVE, TRACK, SECTOR
00118         JSR     ZLOCKW  GO WRITE BLOCK TO DISK
00119 SAVB2   LDY     BB3A    CLEAR BLOCK BUFFER #2
00120         LDX     BB3B
00121         LDA     BB3U    GET UPDATE CODE
00122         CLR     BB3U
00123         CMPA    #0      HAS BUFFER BEEN UPDATED?
00124         BEQ     SAVB3   GO IF NO
00125         JSR     ZLOCKQ  GO CALCULATE DRIVE, TRACK, SECTOR
00126         JSR     ZLOCKW  GO WRITE BLOCK TO DISK
00127 SAVB3   LDY     BB4A    CLEAR BLOCK BUFFER #3
00128         LDX     BB4B
00129         LDA     BB4U    GET UPDATE CODE
00130         CLR     BB4U
00131         CMPA    #0      HAS BUFFER BEEN UPDATED
00132         BEQ     SAVB4   GO IF NO
00133         JSR     ZLOCKQ  GO CALCULATE DRIVE, TRACK, SECTOR
00134         JSR     ZLOCKW  GO WRITE BLOCK TO DISK
00135 SAVB4   PULS    A,B,X,Y
00136         LDX     ,Y++
00137         JMP     [,X++]
00138 FLUSHN  FCB     5
00139         FCC     /FLUSH/
00140 FLUSHL  FDB     SAVBN
00141         FDB     UPDATN
00142 FLUSHC  FDB     COLON
00143 FLUSHP  FDB     SAVBC
00144         FDB     FLAUX
00145         FDB     SEMI
00146 FLAUX   FDB     *+2
00147         PSHS    X
00148         LDX     #$FFFF
00149         STX     BB1B
00150         STX     BB2B
00151         STX     BB3B
00152         STX     BB4B
00153         PULS    X
00154         LDX     ,Y++
00155         JMP     [,X++]
00156 UPDATN  FCB     6
00157         FCC     /UPDATE/
00158 UPDATL  FDB     FLUSHN
00159         FDB     TIBN
00160 UPDATC  FDB     *+2
00161 UPDATP  PSHS    A,B
00162         LDB     #1
00163         LDA     BB1O
00164         CMPA    #0      IS BUFFER #0 LEAST AGED?
00165         BNE     UPDAT1  GO IF NO
00166         STB     BB1U    MARK BUFFER #0 AS UPDATED
00167         BRA     UPDAT4
00168 UPDAT1  LDA     BB2O
00169         CMPA    #0      IS BUFFER #1 LEAST AGED?
00170         BNE     UPDAT2  GO IF NO
00171         STB     BB2U    MARK BUFFER #1 AS UPDATED
00172         BRA     UPDAT4
00173 UPDAT2  LDA     BB3O
00174         CMPA    #0      IS BUFFER #2 LEAST AGED?
 
 
 
 
 
 
 
 
00175         BNE     UPDAT3  GO IF NO
00176         STB     BB3U    MARK BUFFER #2 AS UPDATED
00177         BRA     UPDAT4
00178 UPDAT3  STB     BB4U    MARK BUFFER #3 AS UPDATED
00179 UPDAT4  PULS    A,B
00180         LDX     ,Y++
00181         JMP     [,X++]
00182 TIBN    FCB     3
00183         FCC     /TIB/
00184 TIBL    FDB     UPDATN
00185         FDB     BLKN
00186 TIBC    FDB     *+2
00187 TIBP    PSHS    X
00188         LDX     #TIB    GET ADDRESS OF TIB
00189         PSHU    X       PUSH IT TO U-STACK
00190         PULS    X
00191         LDX     ,Y++
00192         JMP     [,X++]
00193 BLKN    FCB     3
00194         FCC     /BLK/
00195 BLKXL   FDB     TIBN
00196         FDB     TOBDYN
00197 BLKC    FDB     *+2
00198 BLKP    PSHS    X
00199         LDX     #BLKL   GET ADDRESS OF BLKL
00200         PSHU    X       PUSH IT TO U-STACK
00201         PULS    X
00202         LDX     ,Y++
00203         JMP     [,X++]
00204 TOBDYN  FCB     5
00205         FCC     />BODY/
00206 TOBDYL  FDB     BLKN
00207         FDB     F83N
00208 TOBDYC  FDB     *+2
00209 TOBDYP  PSHS    A,B
00210         PULU    A,B     GET WORD'S CFA FROM U-STACK     
00211         ADDD    #2      BUMP IT TO POINT TO PFA
00212         PSHU    A,B     PUSH PFA TO U-STACK
00213         PULS    A,B
00214         LDX     ,Y++
00215         JMP     [,X++]
00216 F83N    FCB     8
00217         FCC     /FORTH-83/
00218 F83L    FDB     TOBDYN
00219         FDB     HEREN
00220 F83C    FDB     *+2
00221 F83P    LDX     ,Y++    NO ACTION, JUST " ok"
00222         JMP     [,X++]
00223 HEREN   FCB     4
00224         FCC     /HERE/
00225 HEREL   FDB     F83N
00226         FDB     ZDEFNN
00227 ZHEREC  FDB     *+2
00228 HEREP   PSHS    X
00229         LDX     DPDP    GET DICTIONARY POINTER
00230         PSHU    X       PUSH IT TO THE U-STACK
00231         PULS    X
00232         LDX     ,Y++
 
 
 
 
 
 
 
 
00233         JMP     [,X++]
00234 ZDEFNN  FCB     11
00235         FCC     /DEFINITIONS/
00236 DEFNL   FDB     HEREN
00237         FDB     ZLLOTN
00238 ZDEFNC  FDB     *+2
00239 DEFNP   PSHS    A,B
00240         LDD     CONTXT  GET CONTEXT VOCABULARY POINTER
00241         STD     CURENT  COPY IT TO CURRENT VOCAB. POINTER
00242         LDD     [CURENT] GET CURRENT LAST WORD NFA
00243         STD     VAF26   STORE IT TO HOLDING VARIABLE
00244         PULS    A,B
00245         LDX     ,Y++
00246         JMP     [,X++]
00247 ZEND    NOP
00248         END
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
