Kernel 0.94

This commit is contained in:
Rémy GIBERT
2020-11-26 20:47:57 +01:00
parent 3dcd4e47cb
commit 13de2fc64a
12 changed files with 383 additions and 264 deletions

Binary file not shown.

Binary file not shown.

Binary file not shown.

View File

@@ -1,9 +1,34 @@
NEW
AUTO 3,1
*--------------------------------------
CP.RUN >LDYA J.KEYWORDS,x
CP.RUN bcs .1 > A2
>LDYA J.KEYWORDS,x
clc
jmp EmitJsrYA
.1 jmp (J.CP-$A4,x)
*--------------------------------------
CP.VARIABLE
*--------------------------------------
CP.CONSTANT
*--------------------------------------
CP.ACODE
*--------------------------------------
CP.FCODE
*--------------------------------------
CP.DO
*--------------------------------------
CP.LOOP
*--------------------------------------
CP.pLOOP
*--------------------------------------
CP.I
*--------------------------------------
CP.LEAVE
clc
rts
*--------------------------------------
CP.IF jsr EmitPullA
jsr EmitPullA
@@ -33,6 +58,8 @@ CP.IF jsr EmitPullA
lda #0
jsr EmitByte
clc
jmp EmitByte
*--------------------------------------
CP.ELSE
@@ -61,6 +88,63 @@ CP.ENDIF ldy RP
clc
rts
*--------------------------------------
CP.BEGIN
*--------------------------------------
CP.UNTIL
*--------------------------------------
CP.REPEAT
*--------------------------------------
CP.WHILE
*--------------------------------------
CP.COMMENT
clc
rts
*--------------------------------------
EmitPullA lda #$B2 lda (zp)
jsr EmitByte
lda #pStack
jsr EmitByte
lda #$E6 inc zp
jsr EmitByte
lda #pStack
bra EmitByte
*--------------------------------------
EmitPushA pha
lda #$A9 LDA imm
jsr EmitByte
pla
jsr EmitByte
lda #$C6 DEC zp
jsr EmitByte
lda #pStack
jsr EmitByte
lda #$92 STA (zp)
jsr EmitByte
lda #pStack
bra EmitByte
*--------------------------------------
EmitJsrYA pha
lda #$20
jsr EmitByte
tya
jsr EmitByte
pla
*--------------------------------------
EmitByte sta (ZPCodePtr)
inc ZPCodePtr
bne .8
inc ZPCodePtr+1
.8 rts
*--------------------------------------
MAN
SAVE usr/src/bin/forth.s.cp
LOAD usr/src/bin/forth.s

View File

@@ -438,13 +438,16 @@ KW.EQ jsr CheckStackPop4
sec
sbc (pStack)
tax
inc pStack
lda (pStack),y
sbc (pStack),y
sbc (pStack)
inc pStack
bcc .1
tay
bne .1
txa
bne .1
@@ -454,7 +457,7 @@ KW.EQ jsr CheckStackPop4
.1 clc
lda #0
ror
sbc #0
sta (pStack)
ldy #1
sta (pStack),y
@@ -720,6 +723,9 @@ KW.VOCABULARY
KW.FORTH
KW.EDITOR
KW.ASSEMBLER
clc
rts
*--------------------------------------
KW.VLIST
clc
rts
@@ -757,7 +763,6 @@ KW.BCOLON bit bCompile
clc
.9 rts
KW.COLON.SYN lda #E.SYN
sec
rts
@@ -960,21 +965,12 @@ KW.I ldy RP
rts
*--------------------------------------
KW.LEAVE
clc
rts
*--------------------------------------
KW.IF
clc
rts
*--------------------------------------
KW.ELSE
clc
rts
*--------------------------------------
KW.ENDIF
clc
rts
*--------------------------------------
KW.BEGIN
*--------------------------------------
@@ -982,12 +978,12 @@ KW.UNTIL
*--------------------------------------
KW.REPEAT
*--------------------------------------
KW.WHILE
clc
KW.WHILE lda #E.FUNDEF
sec
rts
*--------------------------------------
KW.COMMENT clc
KW.COMMENT
clc
rts
*--------------------------------------
MAN

View File

@@ -169,7 +169,8 @@ J.KEYWORDS .DA KW.DUP
.DA KW.ASSEMBLER
.DA KW.VLIST
.DA KW.BCOLON
.DA KW.ECOLON
.DA KW.ECOLON A2
*--------------------------------------
.DA KW.VARIABLE
.DA KW.CONSTANT
.DA KW.ACODE
@@ -187,6 +188,24 @@ J.KEYWORDS .DA KW.DUP
.DA KW.REPEAT
.DA KW.WHILE
.DA KW.COMMENT
*--------------------------------------
J.CP .DA CP.VARIABLE
.DA CP.CONSTANT
.DA CP.ACODE
.DA CP.FCODE
.DA CP.DO
.DA CP.LOOP
.DA CP.pLOOP
.DA CP.I
.DA CP.LEAVE
.DA CP.IF
.DA CP.ELSE
.DA CP.ENDIF
.DA CP.BEGIN
.DA CP.UNTIL
.DA CP.REPEAT
.DA CP.WHILE
.DA CP.COMMENT
.DA 0
*--------------------------------------
CS.INIT clc
@@ -196,6 +215,7 @@ CS.RUN >PUSHW L.MSG.GREETINGS
>PUSHW A2osX.KVER
>PUSHBI 2
>SYSCALL PrintF
* >DEBUG
bcs CS.INIT.RTS
jsr CS.RUN.ARGS
@@ -387,6 +407,9 @@ CS.FORTH.Run.File
lda (ZPCLBuf)
beq .8
cmp #'\'
beq .8
cmp #'#'
bne .1
@@ -535,9 +558,9 @@ CS.RUN.GetNum >PUSHW ZPCLBufPtr
bit bCompile
bpl .9
.1 >PULLA
.1 >PULLYA
jsr EmitPushA
>PULLA
tya
jmp EmitPushA
.9 rts
@@ -707,49 +730,6 @@ CheckStackPop4 lda pStack
.9 lda #E.STACKERROR
sec
rts
*--------------------------------------
EmitPullA lda #$B2 lda (zp)
jsr EmitByte
lda #pStack
jsr EmitByte
lda #$E6 inc zp
lda #pStack
bra EmitByte
*--------------------------------------
EmitPushA pha
lda #$A9 LDA imm
jsr EmitByte
pla
jsr EmitByte
lda #$C6 DEC zp
jsr EmitByte
lda #pStack
jsr EmitByte
lda #$92 STA (zp)
jsr EmitByte
lda #pStack
bra EmitByte
*--------------------------------------
EmitJsrYA pha
lda #$20
jsr EmitByte
tya
jsr EmitByte
pla
*--------------------------------------
EmitByte sta (ZPCodePtr)
inc ZPCodePtr
bne .8
inc ZPCodePtr+1
.8 rts
*--------------------------------------
.INB usr/src/bin/forth.s.cl
.INB usr/src/bin/forth.s.cp

View File

@@ -13,7 +13,7 @@ NEW
.INB inc/libtcpip.i
.INB inc/net.http.i
*--------------------------------------
TIMEOUT.MAX .EQ 200 20 sec.
TIMEOUT.MAX .EQ 600 60 sec.
*--------------------------------------
.DUMMY
.OR ZPBIN
@@ -558,13 +558,13 @@ CS.RUN.GETRESPONSE
ldy #S.IP.TOTAL.LENGTH+1
lda (ZPRespBufPtr),y
sec
sbc #S.TCP-S.IP
sbc #S.TCP-S.ETH.EII
sta ZPRespBufLen
dey
lda (ZPRespBufPtr),y
sbc /S.TCP-S.IP
sbc /S.TCP-S.ETH.EII
sta ZPRespBufLen+1
lda ZPRespBufPtr
@@ -648,34 +648,19 @@ CS.RUN.GETHEADER
.9 rts
*--------------------------------------
CS.RUN.CHECKLEN ldx #3
ldy #Received
.1 lda (pData),y
pha
iny
dex
bpl .1
ldx #3
ldy #Length+3
sec
.2 pla
eor (pData),y
.1 lda Received,x
eor Length,x
bne .9
dey
dex
bpl .2
bpl .1
clc
.99 rts
.9 dex
bmi .99
pla
bra .9
.9 rts
*--------------------------------------
CS.DOEVENT lda (pEvent)
bpl .9 is it a TIMER event?

85
EXAMPLES/MANDELBROT.F.txt Normal file
View File

@@ -0,0 +1,85 @@
NEW
AUTO 3,1
#!/bin/forth
\ Setup constants to remove magic numbers to allow
\ for greater zoom with different scale factors.
20 CONSTANT MAXITER
-39 CONSTANT MINVAL
40 CONSTANT MAXVAL
20 5 lshift CONSTANT RESCALE
RESCALE 4 * CONSTANT S_ESCAPE
\ These variables hold values during the escape calculation.
0 VARIABLE CREAL
0 VARIABLE CIMAG
0 VARIABLE ZREAL
0 VARIABLE ZIMAG
0 VARIABLE COUNT
\ Compute squares, but rescale to remove extra scaling factor.
: ZR_SQ ZREAL @ DUP RESCALE */ ;
: ZI_SQ ZIMAG @ DUP RESCALE */ ;
\ Translate escape count to ascii greyscale.
: .CHAR
S" ..,'~!^:;[/<&?oxOX# "
DROP + 1
TYPE ;
\ Numbers above 4 will always escape, so compare to a scaled value.
: ESCAPES?
S_ESCAPE > ;
\ Increment count and compare to max iterations.
: COUNT_AND_TEST?
COUNT @ 1+ DUP COUNT !
MAXITER > ;
\ stores the row column values from the stack for the escape calculation.
: INIT_VARS
5 lshift DUP CREAL ! ZREAL !
5 lshift DUP CIMAG ! ZIMAG !
1 COUNT ! ;
\ Performs a single iteration of the escape calculation.
: DOESCAPE
ZR_SQ ZI_SQ 2DUP +
ESCAPES? IF
2DROP
TRUE
ELSE
- CREAL @ + \ leave result on stack
ZREAL @ ZIMAG @ RESCALE */ 1 lshift
CIMAG @ + ZIMAG !
ZREAL ! \ Store stack item into ZREAL
COUNT_AND_TEST?
ENDIF ;
\ Iterates on a single cell to compute its escape factor.
: DOCELL
INIT_VARS
BEGIN
DOESCAPE
UNTIL
COUNT @
.CHAR ;
\ For each cell in a row.
: DOROW
MAXVAL MINVAL DO
DUP I
DOCELL
LOOP
DROP ;
\ For each row in the set.
: MANDELBROT
CR
MAXVAL MINVAL DO
I DOROW CR
LOOP ;
\ Run the computation.
MANDELBROT
MAN
TEXT root/mandelbrot.f

View File

@@ -1,11 +1,11 @@
NEW
AUTO 3,1
*--------------------------------------
IO.D2.SeekTimeR .EQ 140 LIBBLKDEV Recalibration
IO.D2.SeekTimeF .EQ 70 LIBBLKDEV Track Formatter
IO.D2.SeekTimeB .EQ 70 LIBBLKDEV Boot Block
IO.D2.SeekTimeP .EQ 70 ProDOS.FX initial
IO.D2.SeekTimeI .EQ 10 ProDOS.FX increment -> until > 128
IO.D2.SeekTimeR .EQ 130 LIBBLKDEV Recalibration
IO.D2.SeekTimeF .EQ 65 LIBBLKDEV Track Formatter
IO.D2.SeekTimeB .EQ 65 LIBBLKDEV Boot Block
IO.D2.SeekTimeP .EQ 85 ProDOS.FX initial
IO.D2.SeekTimeI .EQ 20 ProDOS.FX increment -> until > 128
*--------------------------------------
IO.D2.Ph0Off .EQ $C080
IO.D2.Ph0On .EQ $C081

View File

@@ -396,24 +396,6 @@ TrkWriter.Start lda IO.D2.ReadProt,x
TrkWriter.Size .EQ *-TrkWriter.Start
.EP
*--------------------------------------
D2.PhIn .DA #IO.D2.Ph3Off 7->0
.DA #IO.D2.Ph1On 0->1
.DA #IO.D2.Ph0Off 1->2
.DA #IO.D2.Ph2On 2->3
.DA #IO.D2.Ph1Off 3->4
.DA #IO.D2.Ph3On 4->5
.DA #IO.D2.Ph2Off 5->6
.DA #IO.D2.Ph0On 6->7
D2.PhOut .DA #IO.D2.Ph1Off 1->0
.DA #IO.D2.Ph0on 2->1
.DA #IO.D2.Ph2off 3->2
.DA #IO.D2.Ph1On 4->3
.DA #IO.D2.Ph3Off 5->4
.DA #IO.D2.Ph2On 6->5
.DA #IO.D2.Ph0Off 7->6
.DA #IO.D2.Ph3On 0->7
*--------------------------------------
ADDR.Head .HS 96AAD5
DATA.Head .HS ADAAD5
TAIL .HS EBAADE

View File

@@ -227,8 +227,8 @@ XRW.SectorIO lda #2
adc #IO.D2.SeekTimeI
sta XRW.SeekTime
ldx XRW.UnitIndex
sta XRW.D2SeekTime-1,x
* ldx XRW.UnitIndex
* sta XRW.D2SeekTime-1,x
.5 lda XRW.ReqTrack
jsr XRW.Seek
@@ -395,7 +395,7 @@ XRW.Write lda IO.D2.ReadProt,x PREWRITE MODE
sta IO.D2.WriteMode,x (5) goto write mode
ora IO.D2.WShift,x (4)
ldy #$04 (2) for five nibls
ldy #5 (2)
nop (2)
pha (3)
pla (4)

View File

@@ -275,11 +275,14 @@ BIN.RelExe ldy #H.BIN.T+1
lda (ZPPtr1),y
cmp /H.BIN.T.BIN65
beq .1
cmp /H.BIN.T.DRV65
beq .1
lda #E.IBIN
sec
rts
.1 ldy #H.BIN.JMP relocate Main JMP
jsr BIN.RelocateAtPtr1Y
@@ -292,10 +295,14 @@ BIN.RelDrv ldy #H.BIN.DRV.REL.TABLE
.1 iny
lda (ZPPtr1),y HI in A
beq .2 $00xx = end of table
dey
jsr BIN.RelocateAtPtr1Y
iny
bne .1
inc ZPPtr1+1
bra .1
*--------------------------------------