mirror of
https://github.com/forth-ev/VolksForth.git
synced 2025-01-05 03:29:36 +00:00
Extract vf-sys.fth from source.fth and use it building v4th.com
This commit is contained in:
Philip Zembrod
parent
853a555eb2
commit
a88ecc8cef
@ -81,7 +81,7 @@ inctest.log: \
|
||||
$(cpmfilesdir)/v4th.com: \
|
||||
$(patsubst %, $(cpmfilesdir)/%, volks4th.com \
|
||||
include.fb log2file.fb target.fb source.fb \
|
||||
v4th.fth vf-core.fth vf-io.fth vf-bufs.fth) \
|
||||
v4th.fth vf-core.fth vf-io.fth vf-bufs.fth vf-sys.fth) \
|
||||
Makefile | emu
|
||||
rm -f $(runcpmdir)/A/0/V4TH.COM $@
|
||||
./emulator/run-in-runcpm.sh \
|
||||
|
||||
@ -6,8 +6,9 @@ Target definitions $100 here!
|
||||
include vf-core.fth
|
||||
include vf-io.fth
|
||||
include vf-bufs.fth
|
||||
include vf-sys.fth
|
||||
use source.fb
|
||||
$68 $75 thru \ Standard 8080-System
|
||||
$74 $75 thru \ Standard 8080-System
|
||||
|
||||
cr .( unresolved: ) .unresolved ( ' .blk is .status )
|
||||
|
||||
|
||||
222
8080/CPM/src/vf-sys.fth
Normal file
222
8080/CPM/src/vf-sys.fth
Normal file
@ -0,0 +1,222 @@
|
||||
\ *** Block No. 104, Hexblock 68
|
||||
|
||||
\ endpoints of forget 01Jul86
|
||||
|
||||
| : |? ( nfa -- flag ) c@ $20 and ;
|
||||
| : forget? ( adr nfa -- flag ) \ code in heap or above adr ?
|
||||
name> under 1+ u< swap heap? or ;
|
||||
|
||||
| : endpoints ( addr -- addr symb )
|
||||
heap voc-link @ >r
|
||||
BEGIN r> @ ?dup \ through all Vocabs
|
||||
WHILE dup >r 4- >r \ link on returnstack
|
||||
BEGIN r> @ >r over 1- dup r@ u< \ until link or
|
||||
swap r@ 2+ name> u< and \ code under adr
|
||||
WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap
|
||||
r@ 2+ |? IF over r@ 2+ forget?
|
||||
IF r@ 2+ (name> 2+ umax THEN \ then update symb
|
||||
THEN REPEAT rdrop REPEAT ;
|
||||
|
||||
\ *** Block No. 105, Hexblock 69
|
||||
|
||||
\ remove, -words, -tasks 20Oct86
|
||||
|
||||
: remove ( dic sym thread - dic sym )
|
||||
BEGIN dup @ ?dup \ unlink forg. words
|
||||
WHILE dup heap?
|
||||
IF 2 pick over u> ELSE 3 pick over 1+ u< THEN
|
||||
IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ;
|
||||
|
||||
| : remove-words ( dic sym -- dic sym )
|
||||
voc-link BEGIN @ ?dup
|
||||
WHILE dup >r 4- remove r> REPEAT ;
|
||||
|
||||
| : remove-tasks ( dic -- ) up@
|
||||
BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin
|
||||
IF dup @ 2+ @ over ! 2-
|
||||
ELSE @ THEN REPEAT 2drop ;
|
||||
|
||||
\ *** Block No. 106, Hexblock 6a
|
||||
|
||||
\ remove-vocs trim 20Oct86 07Oct87
|
||||
|
||||
| : remove-vocs ( dic symb -- dic symb )
|
||||
voc-link remove thru.vocstack
|
||||
DO 2dup I @ -rot uwithin
|
||||
IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP
|
||||
2dup current @ -rot uwithin
|
||||
IF [ ' Forth 2+ ] Literal current ! THEN ;
|
||||
|
||||
Defer custom-remove ' noop Is custom-remove
|
||||
|
||||
| : trim ( dic symb -- )
|
||||
over remove-tasks remove-vocs remove-words
|
||||
custom-remove heap swap - hallot dp ! 0 last ! ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 107, Hexblock 6b
|
||||
|
||||
\ deleting words from dict. 01Jul86 18Nov87
|
||||
|
||||
: clear here dup up@ trim dp ! ;
|
||||
|
||||
: (forget ( adr --) dup heap? Abort" is symbol"
|
||||
endpoints trim ;
|
||||
|
||||
: forget ' dup [ dp ] Literal @ u< Abort" protected"
|
||||
>name dup heap?
|
||||
IF name> ELSE 4- THEN (forget ;
|
||||
|
||||
: empty [ dp ] Literal @ up@ trim
|
||||
[ udp ] Literal @ udp ! ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 108, Hexblock 6c
|
||||
|
||||
\ save bye stop? ?cr 18Nov87
|
||||
|
||||
: save here up@ trim
|
||||
voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL
|
||||
up@ origin $100 cmove ;
|
||||
|
||||
: bye flush empty (bye ;
|
||||
|
||||
| : end? key #cr = IF true rdrop THEN ;
|
||||
|
||||
: stop? ( -- flag ) key? IF end? end? THEN false ;
|
||||
|
||||
: ?cr col c/l u> 0=exit cr ;
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 109, Hexblock 6d
|
||||
|
||||
\ in/output structure 07Jun86
|
||||
|
||||
| : Out: Create dup c, 2+ Does> c@ output @ + perform ;
|
||||
|
||||
: Output: Create: Does> output ! ;
|
||||
0 Out: emit Out: cr Out: type Out: del
|
||||
Out: page Out: at Out: at? drop
|
||||
|
||||
: row ( -- row) at? drop ;
|
||||
: col ( -- col) at? nip ;
|
||||
|
||||
| : In: Create dup c, 2+ Does> c@ input @ + perform ;
|
||||
|
||||
: Input: Create: Does> input ! ;
|
||||
0 In: key In: key? In: decode In: expect drop
|
||||
|
||||
|
||||
\ *** Block No. 110, Hexblock 6e
|
||||
|
||||
\ Alias only definitionen 18Nov87
|
||||
|
||||
Root definitions Forth
|
||||
|
||||
: seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab.
|
||||
|
||||
' Only Alias Only
|
||||
' Forth Alias Forth
|
||||
' words Alias words
|
||||
' also Alias also
|
||||
' definitions Alias definitions
|
||||
|
||||
Host Target
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 111, Hexblock 6f
|
||||
|
||||
\ 'restart 'cold 22Oct86 10Oct87
|
||||
|
||||
Defer 'restart ' noop Is 'restart
|
||||
|
||||
| : (restart ['] (quit Is 'quit drvinit 'restart
|
||||
[ errorhandler ] Literal @ errorhandler !
|
||||
['] noop Is 'abort clearstack
|
||||
standardi/o interpret quit ;
|
||||
|
||||
Defer 'cold ' noop Is 'cold
|
||||
|
||||
| : (cold origin up@ $100 cmove $80 count
|
||||
$50 umin >r tib r@ move r> #tib ! >in off blk off
|
||||
init-vocabularys init-buffers flush 'cold
|
||||
Onlyforth page &24 spaces logo count type cr (restart ;
|
||||
|
||||
|
||||
\ *** Block No. 112, Hexblock 70
|
||||
|
||||
\ cold bootsystem 20Oct86
|
||||
|
||||
Code cold here >cold !
|
||||
s0 lhld 6 D lxi D dad origin D lxi $3F C mvi
|
||||
[[ D ldax A M mov H inx D inx C dcr 0= ?]
|
||||
' (cold >body IP lxi
|
||||
Label bootsystem
|
||||
s0 lhld 6 D lxi D dad UP shld
|
||||
user' s0 D lxi D dad
|
||||
M E mov H inx M D mov xchg sphl
|
||||
user' r0 D lxi UP lhld D dad
|
||||
M E mov H inx M D mov xchg RP shld
|
||||
$C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker )
|
||||
Next
|
||||
end-code
|
||||
|
||||
|
||||
\ *** Block No. 113, Hexblock 71
|
||||
|
||||
\ restart boot 20Oct86
|
||||
|
||||
Code restart here >restart !
|
||||
' (restart >body IP lxi bootsystem jmp end-code
|
||||
|
||||
Label boot here >boot ! \ find link to Main:
|
||||
s0 lhld 6 D lxi D dad H B mvx origin D lxi
|
||||
[[ [[ xchg H inx H inx M E mov H inx M D mov
|
||||
D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx
|
||||
6 lhld 0 L mvi ' limit >body shld
|
||||
-$1100 D lxi D dad r0 shld \ set initial RP
|
||||
-$400 D lxi D dad s0 shld \ set initial SP
|
||||
6 D lxi D dad xchg B H mvx
|
||||
D M mov H dcx E M mov \ set link to Maintask
|
||||
>cold 2- jmp
|
||||
end-code
|
||||
|
||||
\ *** Block No. 114, Hexblock 72
|
||||
|
||||
\ "search 05Mar88
|
||||
|
||||
Label notfound H pop H pop
|
||||
IPsave lhld H IP mvx False H lxi hpush jmp
|
||||
|
||||
Code "search ( text tlen buf blen -- addr tf / ff )
|
||||
IP H mvx IPsave shld D pop H pop xthl
|
||||
H A mov L ora notfound jz
|
||||
E A mov L sub A C mov D A mov H sbb A B mov notfound jc
|
||||
B inx D pop xthl M A mov xthl H push xchg
|
||||
Label scanfirst
|
||||
A E mov ?capital call E D mov
|
||||
[[ M E mov H inx B A mov C ora notfound jz B dcx
|
||||
?capital call E A mov D cmp 0= ?]
|
||||
B D mvx B pop xchg xthl xchg H push B push D push
|
||||
|
||||
|
||||
\ *** Block No. 115, Hexblock 73
|
||||
|
||||
\ "search part 2 27Nov87
|
||||
|
||||
Label match
|
||||
B dcx B A mov C ora 0<> ?[
|
||||
D inx D ldax D push A E mov ?capital call E D mov
|
||||
M E mov H inx ?capital call E A mov D cmp D pop
|
||||
match jz H pop B pop D pop
|
||||
M A mov xthl B push H B mvx xchg scanfirst jmp ]?
|
||||
D pop D pop H pop D pop H dcx H push
|
||||
IPsave lhld H IP mvx True H lxi hpush jmp
|
||||
end-code
|
||||
Loading…
Reference in New Issue
Block a user