mirror of
https://github.com/forth-ev/VolksForth.git
synced 2025-01-09 13:32:05 +00:00
MiniOOF cleanup
This commit is contained in:
parent
daa9d08efa
commit
40a2305bf0
28
sources/6502/2words.fth
Normal file
28
sources/6502/2words.fth
Normal file
@ -0,0 +1,28 @@
|
||||
\ 2! 2@ 2variable 2constant
|
||||
|
||||
cr .( Loading 2words ...)
|
||||
|
||||
\needs code INCLUDE" D:TAS65.FTH"
|
||||
|
||||
code 2! ( d addr -- )
|
||||
tya setup jsr 3 # ldy
|
||||
[[ sp )y lda n )y sta dey 0< ?]
|
||||
1 # ldy poptwo jmp end-code
|
||||
|
||||
code 2@ ( addr -- d )
|
||||
sp x) lda n sta sp )y lda n 1+ sta
|
||||
sp 2dec 3 # ldy
|
||||
[[ n )y lda sp )y sta dey 0< ?]
|
||||
xyNext jmp end-code
|
||||
|
||||
: 2VARIABLE ( -- )
|
||||
create 4 allot ;
|
||||
|
||||
: 2CONSTANT ( d -- )
|
||||
CREATE , , DOES> ( -- d ) 2@ ;
|
||||
|
||||
\ 2dup exists
|
||||
\ 2swap exists
|
||||
\ 2drop exists
|
||||
|
||||
cr .( 2Words loaded. )
|
@ -1,23 +1,23 @@
|
||||
\ Mini-OOF by Bernd Paysan
|
||||
|
||||
CR .( loading Mini-OOF ... )
|
||||
|
||||
|
||||
: METHOD ( m v -- m' v )
|
||||
CREATE OVER , SWAP 2+ SWAP
|
||||
DOES> ( ... o -- ... )
|
||||
@ OVER @ + @ EXECUTE ;
|
||||
|
||||
: VAR ( m v size -- )
|
||||
: VAR ( m v size -- )
|
||||
CREATE OVER , +
|
||||
DOES> ( o -- addr )
|
||||
DOES> ( o -- addr )
|
||||
@ + ;
|
||||
|
||||
: CLASS ( class -- class methods vars )
|
||||
DUP 2@ ;
|
||||
|
||||
: END-CLASS ( -- class methods vars )
|
||||
CREATE HERE >R , DUP ,
|
||||
4 ?DO ['] NOOP , 2 +LOOP
|
||||
CREATE HERE >R , DUP ,
|
||||
4 ?DO ['] NOOP , 2 +LOOP
|
||||
2+ DUP 2+ R> ROT @ 4 /STRING MOVE ;
|
||||
|
||||
: DEFINES ( xt class -- )
|
||||
@ -32,121 +32,3 @@ CR .( loading Mini-OOF ... )
|
||||
CREATE OBJECT 2 , 4 ,
|
||||
|
||||
CR .( Mini-OOF loaded. )
|
||||
|
||||
\ Mini OOF Example
|
||||
|
||||
\needs class INCLUDE" D:MINIOOF.F"
|
||||
|
||||
CR .( loading OOF Example )
|
||||
|
||||
CR .( creating object class "animal" )
|
||||
|
||||
object class
|
||||
2 var sound
|
||||
2 var color
|
||||
2 var kind
|
||||
method init
|
||||
method say
|
||||
method present
|
||||
end-class animal
|
||||
|
||||
CR .( Implementing Methods )
|
||||
|
||||
: m-say ( o -- )
|
||||
cr ." it says "
|
||||
sound @ COUNT TYPE ;
|
||||
|
||||
' m-say animal defines say
|
||||
|
||||
: m-present ( o -- )
|
||||
cr ." This animal is a "
|
||||
DUP color @ COUNT TYPE BL EMIT
|
||||
kind @ COUNT TYPE ." !" ;
|
||||
|
||||
' m-present animal defines present
|
||||
|
||||
: m-init ( say color kind o -- )
|
||||
>R
|
||||
R@ SOUND !
|
||||
R@ COLOR !
|
||||
R> KIND ! ;
|
||||
|
||||
' m-init animal defines init
|
||||
|
||||
CR .( creating animal objects )
|
||||
|
||||
animal new constant dog
|
||||
animal new constant cat
|
||||
animal new constant eagle
|
||||
|
||||
CR .( initializing objects )
|
||||
|
||||
: S>A DROP 1- ; ( convert string to address )
|
||||
|
||||
S" MAMAL" S>A
|
||||
S" BLACK" S>A
|
||||
S" BARK BARK" S>A dog init
|
||||
|
||||
S" MAMAL" S>A
|
||||
S" SILVER" S>A
|
||||
S" MEOW MEOW" S>A cat init
|
||||
|
||||
S" BIRD" S>A
|
||||
S" BROWN" S>A
|
||||
S" ARK ARK" S>A eagle init
|
||||
|
||||
CR .( now lets the objects speak )
|
||||
|
||||
CR
|
||||
|
||||
dog present dog say
|
||||
cat present cat say
|
||||
eagle present eagle say
|
||||
|
||||
CR .( Finish! )
|
||||
CR
|
||||
|
||||
\ String Ext.
|
||||
|
||||
CR .( loading String extensions )
|
||||
|
||||
: S" ASCII " PARSE
|
||||
HERE 2DUP ! 1+
|
||||
OVER 1+ ALLOT
|
||||
2DUP 4 ROLL SWAP ROT
|
||||
1+ MOVE SWAP ;
|
||||
|
||||
CR .( String extensions loaded )
|
||||
|
||||
|
||||
\ 2! 2@ 2variable 2constant
|
||||
|
||||
cr .( Loading 2words ...)
|
||||
|
||||
\needs code INCLUDE" D:TAS65.F"
|
||||
|
||||
code 2! ( d addr -- )
|
||||
tya setup jsr 3 # ldy
|
||||
[[ sp )y lda n )y sta dey 0< ?]
|
||||
1 # ldy poptwo jmp end-code
|
||||
|
||||
code 2@ ( addr -- d )
|
||||
sp x) lda n sta sp )y lda n 1+ sta
|
||||
sp 2dec 3 # ldy
|
||||
[[ n )y lda sp )y sta dey 0< ?]
|
||||
xyNext jmp end-code
|
||||
|
||||
: 2VARIABLE ( -- )
|
||||
create 4 allot ;
|
||||
|
||||
: 2CONSTANT ( d -- )
|
||||
CREATE , , DOES> ( -- d ) 2@ ;
|
||||
|
||||
\ 2dup exists
|
||||
\ 2swap exists
|
||||
\ 2drop exists
|
||||
|
||||
cr .( 2Words loaded. )
|
||||
|
||||
|
||||
|
||||
|
72
sources/generic/oof-example.fth
Normal file
72
sources/generic/oof-example.fth
Normal file
@ -0,0 +1,72 @@
|
||||
\ Mini OOF Example
|
||||
|
||||
\needs class INCLUDE" D:MINIOOF.F"
|
||||
|
||||
CR .( loading OOF Example )
|
||||
|
||||
CR .( creating object class "animal" )
|
||||
|
||||
object class
|
||||
2 var sound
|
||||
2 var color
|
||||
2 var kind
|
||||
method init
|
||||
method say
|
||||
method present
|
||||
end-class animal
|
||||
|
||||
CR .( Implementing Methods )
|
||||
|
||||
: m-say ( o -- )
|
||||
cr ." it says "
|
||||
sound @ COUNT TYPE ;
|
||||
|
||||
' m-say animal defines say
|
||||
|
||||
: m-present ( o -- )
|
||||
cr ." This animal is a "
|
||||
DUP color @ COUNT TYPE BL EMIT
|
||||
kind @ COUNT TYPE ." !" ;
|
||||
|
||||
' m-present animal defines present
|
||||
|
||||
: m-init ( say color kind o -- )
|
||||
>R
|
||||
R@ SOUND !
|
||||
R@ COLOR !
|
||||
R> KIND ! ;
|
||||
|
||||
' m-init animal defines init
|
||||
|
||||
CR .( creating animal objects )
|
||||
|
||||
animal new constant dog
|
||||
animal new constant cat
|
||||
animal new constant eagle
|
||||
|
||||
CR .( initializing objects )
|
||||
|
||||
: S>A DROP 1- ; ( convert string to address )
|
||||
|
||||
S" MAMAL" S>A
|
||||
S" BLACK" S>A
|
||||
S" BARK BARK" S>A dog init
|
||||
|
||||
S" MAMAL" S>A
|
||||
S" SILVER" S>A
|
||||
S" MEOW MEOW" S>A cat init
|
||||
|
||||
S" BIRD" S>A
|
||||
S" BROWN" S>A
|
||||
S" ARK ARK" S>A eagle init
|
||||
|
||||
CR .( now lets the objects speak )
|
||||
|
||||
CR
|
||||
|
||||
dog present dog say
|
||||
cat present cat say
|
||||
eagle present eagle say
|
||||
|
||||
CR .( Finish! )
|
||||
CR
|
11
sources/generic/strings.fth
Normal file
11
sources/generic/strings.fth
Normal file
@ -0,0 +1,11 @@
|
||||
\ String Ext.
|
||||
|
||||
CR .( loading String extensions )
|
||||
|
||||
: S" ASCII " PARSE
|
||||
HERE 2DUP ! 1+
|
||||
OVER 1+ ALLOT
|
||||
2DUP 4 ROLL SWAP ROT
|
||||
1+ MOVE SWAP ;
|
||||
|
||||
CR .( String extensions loaded )
|
Loading…
Reference in New Issue
Block a user