mirror of
https://github.com/forth-ev/VolksForth.git
synced 2025-04-04 20:31:57 +00:00
Update cpmfiles/ including binary v4th.com
This commit is contained in:
Philip Zembrod
parent
bce5954787
commit
b701e46bb0
Binary file not shown.
@ -3,8 +3,12 @@ Onlyforth
|
||||
$9000 displace !
|
||||
Target definitions $100 here!
|
||||
|
||||
use source.fb
|
||||
2 $75 thru \ Standard 8080-System
|
||||
include vf-core.fth
|
||||
include vf-io.fth
|
||||
include vf-bufs.fth
|
||||
include vf-sys.fth
|
||||
include vf-bdos.fth
|
||||
include vf-end.fth
|
||||
|
||||
cr .( unresolved: ) .unresolved ( ' .blk is .status )
|
||||
|
||||
|
||||
148
8080/CPM/cpmfiles/vf-bdos.fth
Normal file
148
8080/CPM/cpmfiles/vf-bdos.fth
Normal file
@ -0,0 +1,148 @@
|
||||
\ *** Block No. 119, Hexblock 77
|
||||
|
||||
\ CP/M-Interface 05Oct87
|
||||
Vocabulary Dos Dos definitions also
|
||||
Label >bios pchl
|
||||
Code biosa ( arg fun -- res )
|
||||
1 lhld D pop D dcx D dad D dad D dad
|
||||
D pop IP push D IP mvx >bios call
|
||||
Label back
|
||||
IP pop 0 H mvi A L mov Hpush jmp end-code
|
||||
|
||||
Code bdosa ( arg fun -- res )
|
||||
H pop D pop IP push L C mov 5 call back jmp
|
||||
end-code
|
||||
|
||||
: bios ( arg fun -- ) biosa drop ;
|
||||
: bdos ( arg fun -- ) bdosa drop ;
|
||||
|
||||
|
||||
\ *** Block No. 120, Hexblock 78
|
||||
|
||||
\ Character-IO Constants Character input 05Oct87
|
||||
|
||||
Target Dos also
|
||||
|
||||
$08 Constant #bs $0D Constant #cr
|
||||
$0A Constant #lf $1B Constant #esc
|
||||
$09 Constant #tab $7F Constant #del
|
||||
$07 Constant #bel $0C Constant #ff
|
||||
|
||||
: con! ( c -- ) 4 bios ;
|
||||
: (key? ( -- ? ) 0 2 biosa 0= not ;
|
||||
: getkey ( -- c ) 0 3 biosa ;
|
||||
|
||||
: (key ( -- c ) BEGIN pause (key? UNTIL getkey ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 121, Hexblock 79
|
||||
|
||||
\ Character output 07Oct87 UH 27Feb88
|
||||
|
||||
| Code ?ctrl ( c -- c' ) H pop L A mov
|
||||
$20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code
|
||||
|
||||
: (emit ( c -- ) ?ctrl con! pause ;
|
||||
|
||||
: (cr #cr con! #lf con! ;
|
||||
: (del #bs con! bl con! #bs con! ;
|
||||
: (at? ( -- row col ) 0 0 ;
|
||||
|
||||
: tipp ( addr len -- ) 0 ?DO count emit LOOP drop ;
|
||||
|
||||
Output: display [ here output ! ]
|
||||
(emit (cr tipp (del noop 2drop (at? ;
|
||||
|
||||
|
||||
\ *** Block No. 122, Hexblock 7a
|
||||
|
||||
\ Line input 04Oct87
|
||||
|
||||
| : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ;
|
||||
|
||||
: (decode ( addr pos1 key -- addr pos2 )
|
||||
#bs case? IF backspace exit THEN
|
||||
#del case? IF backspace exit THEN
|
||||
#cr case? IF dup span ! space exit THEN
|
||||
dup emit >r 2dup + r> swap c! 1+ ;
|
||||
|
||||
: (expect ( addr len -- ) span ! 0
|
||||
BEGIN span @ over u> WHILE key decode REPEAT 2drop ;
|
||||
|
||||
Input: keyboard [ here input ! ]
|
||||
(key (key? (decode (expect ;
|
||||
|
||||
|
||||
\ *** Block No. 123, Hexblock 7b
|
||||
|
||||
\ Default Disk Interface: Constants and Primitives 18Nov87
|
||||
|
||||
$80 Constant b/rec b/blk b/rec / Constant rec/blk
|
||||
|
||||
Dos definitions
|
||||
' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb
|
||||
|
||||
: dos-error? ( n -- f ) $FF = ;
|
||||
|
||||
$5C Constant fcb
|
||||
: reset ( -- ) 0 &13 bdos ;
|
||||
: openfile ( fcb -- f ) &15 bdosa dos-error? ;
|
||||
: closefile ( fcb -- f ) &16 bdosa dos-error? ;
|
||||
: dma! ( dma -- ) &26 bdos ;
|
||||
: rec@ ( fcb -- f ) &33 bdosa ;
|
||||
: rec! ( fcb -- f ) &34 bdosa ;
|
||||
|
||||
\ *** Block No. 124, Hexblock 7c
|
||||
|
||||
\ Default Disk Interface: open and close 20Nov87
|
||||
|
||||
Target Dos also Defer drvinit Dos definitions
|
||||
|
||||
| Variable opened
|
||||
: default ( -- ) opened off
|
||||
fcb 1+ c@ bl = ?exit $80 count here place #tib off
|
||||
fcb dup dosfcb> dup isfile ! fromfile !
|
||||
openfile Abort" default file not found!" opened on ;
|
||||
' default Is drvinit
|
||||
|
||||
: close-default ( -- ) opened @ not ?exit
|
||||
fcb closefile Abort" can't close default-file!" ;
|
||||
' close-default Is save-dos-buffers
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 125, Hexblock 7d
|
||||
|
||||
\ Default Disk Interface: read/write 14Feb88
|
||||
|
||||
Target Dos also
|
||||
|
||||
| : rec# ( 'dosfcb -- 'rec# ) &33 + ;
|
||||
|
||||
: (r/w ( adr blk file r/wf -- flag ) >r
|
||||
dup 0= Abort" no Direct Disk IO supported! " >dosfcb
|
||||
swap rec/blk * over rec# 0 over 2+ c! !
|
||||
r> rot b/blk bounds
|
||||
DO I dma! 2dup IF rec@ drop
|
||||
ELSE rec! IF 2drop true endloop exit THEN THEN
|
||||
over rec# 0 over 2+ c! 1 swap +!
|
||||
b/rec +LOOP 2drop false ;
|
||||
|
||||
' (r/w Is r/w
|
||||
|
||||
\ *** Block No. 126, Hexblock 7e
|
||||
|
||||
\ Postlude 20Nov87
|
||||
|
||||
Defer postlude
|
||||
|
||||
| : (bye ( -- ) postlude 0 0 bdos ;
|
||||
|
||||
| : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ;
|
||||
|
||||
: .size ( -- ) base push decimal
|
||||
cr ." Size: &" #pages u. ." Pages" ;
|
||||
|
||||
' .size Is postlude
|
||||
|
||||
190
8080/CPM/cpmfiles/vf-bufs.fth
Normal file
190
8080/CPM/cpmfiles/vf-bufs.fth
Normal file
@ -0,0 +1,190 @@
|
||||
\ *** Block No. 94, Hexblock 5e
|
||||
|
||||
\ buffer mechanism 20Oct86 07Oct87
|
||||
|
||||
User isfile 0 isfile ! \ addr of file control block
|
||||
Variable fromfile 0 fromfile !
|
||||
Variable prev 0 prev ! \ Listhead
|
||||
| Variable buffers 0 buffers ! \ Semaphor
|
||||
$408 Constant b/buf \ physikalische Groesse
|
||||
$400 Constant b/blk
|
||||
\ \\ Struktur eines Buffers: 0 : link
|
||||
\ 2 : file
|
||||
\ 4 : blocknummer
|
||||
\ 6 : statusflags
|
||||
\ 8 : Data ... 1 Kb ...
|
||||
\ Statusflag bits : 15 1 -> updated
|
||||
\ file : -1 -> empty buffer, 0 -> no fcb, direct access
|
||||
\ else addr of fcb ( system dependent )
|
||||
|
||||
\ *** Block No. 95, Hexblock 5f
|
||||
|
||||
\ search for blocks in memory 30Jun86
|
||||
| Variable pred
|
||||
\ DE:blk BC:file HL:bufadr
|
||||
|
||||
Label thisbuffer? ( Zero = this buffer )
|
||||
H push H inx H inx M A mov C cmp 0=
|
||||
?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp
|
||||
0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret
|
||||
|
||||
Code (core? ( blk file -- adr\blk file )
|
||||
IP H mvx Ipsave shld
|
||||
user' offset D lxi UP lhld D dad
|
||||
M E mov H inx M D mov
|
||||
B pop H pop H push B push D dad xchg
|
||||
prev lhld
|
||||
thisbuffer? call 0= ?[
|
||||
|
||||
\ *** Block No. 96, Hexblock 60
|
||||
|
||||
\ search for blocks in memory 30Jun86
|
||||
|
||||
Label blockfound
|
||||
D pop D pop 8 D lxi D dad H push ' exit @ jmp ]?
|
||||
[[ pred shld
|
||||
M A mov H inx M H mov A L mov
|
||||
H ora 0= ?[ IPsave lhld H IP mvx Next ]?
|
||||
thisbuffer? call 0= ?]
|
||||
xchg pred lhld D ldax A M mov
|
||||
H inx D inx D ldax A M mov D dcx
|
||||
prev lhld xchg E M mov H inx D M mov
|
||||
H dcx prev shld
|
||||
blockfound jmp end-code
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 97, Hexblock 61
|
||||
|
||||
\ (core? 29Jun86
|
||||
\ \\
|
||||
\
|
||||
\ | : this? ( blk file bufadr -- flag )
|
||||
\ dup 4+ @ swap 2+ @ d= ;
|
||||
\
|
||||
\ | : (core? ( blk file -- dataaddr / blk file )
|
||||
\ BEGIN over offset @ + over prev @ this?
|
||||
\ IF rdrop 2drop prev @ 8 + exit THEN
|
||||
\ 2dup >r offset @ + >r prev @
|
||||
\ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN
|
||||
\ dup r> r> 2dup >r >r rot this? 0=
|
||||
\ WHILE nip REPEAT
|
||||
\ dup @ rot ! prev @ over ! prev ! rdrop rdrop
|
||||
\ REPEAT ;
|
||||
|
||||
|
||||
\ *** Block No. 98, Hexblock 62
|
||||
|
||||
\ (diskerr 29Jul86 07Oct87
|
||||
|
||||
: (diskerr
|
||||
." error! r to retry " key $FF and
|
||||
capital Ascii R = not Abort" aborted" ;
|
||||
|
||||
Defer diskerr
|
||||
' (diskerr Is diskerr
|
||||
|
||||
Defer r/w
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 99, Hexblock 63
|
||||
|
||||
\ backup emptybuf readblk 20Oct86
|
||||
|
||||
| : backup ( bufaddr -- ) dup 6+ @ 0<
|
||||
IF 2+ dup @ 1+ \ buffer empty if file = -1
|
||||
IF input push output push standardi/o
|
||||
BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
|
||||
WHILE ." write " diskerr
|
||||
REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ;
|
||||
|
||||
: emptybuf ( bufaddr -- ) 2+ dup on 4+ off ;
|
||||
|
||||
| : readblk ( blk file addr -- blk file addr )
|
||||
dup emptybuf
|
||||
input push output push standardi/o >r
|
||||
BEGIN over offset @ + over r@ 8 + -rot 1 r/w
|
||||
WHILE ." read " diskerr REPEAT r> ;
|
||||
|
||||
\ *** Block No. 100, Hexblock 64
|
||||
|
||||
\ take mark updates? core? 10Mar86 19Nov87
|
||||
|
||||
| : take ( -- bufaddr) prev
|
||||
BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL
|
||||
buffers lock dup backup ;
|
||||
|
||||
| : mark ( blk file bufaddr -- blk file )
|
||||
2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off
|
||||
buffers unlock ;
|
||||
|
||||
| : updates? ( -- bufaddr / flag)
|
||||
prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ;
|
||||
|
||||
: core? ( blk file -- addr /false ) (core? 2drop false ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 101, Hexblock 65
|
||||
|
||||
\ block & buffer manipulation 20Oct86 18Nov87
|
||||
|
||||
: (buffer ( blk file -- addr )
|
||||
BEGIN (core? take mark REPEAT ;
|
||||
|
||||
: (block ( blk file -- addr )
|
||||
BEGIN (core? take readblk mark REPEAT ;
|
||||
|
||||
Code isfile@ ( -- addr ) user' isfile D lxi
|
||||
UP lhld D dad fetch jmp end-code
|
||||
|
||||
: buffer ( blk -- addr ) isfile@ (buffer ;
|
||||
|
||||
: block ( blk -- addr ) isfile@ (block ;
|
||||
|
||||
\ : isfile@ ( -- addr ) isfile @ ;
|
||||
|
||||
\ *** Block No. 102, Hexblock 66
|
||||
|
||||
\ block & buffer manipulation 05Oct87
|
||||
|
||||
: update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ;
|
||||
|
||||
Defer save-dos-buffers
|
||||
|
||||
: save-buffers ( -- ) buffers lock
|
||||
BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers
|
||||
buffers unlock ;
|
||||
|
||||
: empty-buffers ( -- ) buffers lock prev
|
||||
BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ;
|
||||
|
||||
: flush save-buffers empty-buffers ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 103, Hexblock 67
|
||||
|
||||
\ Allocating buffers 10Oct87
|
||||
$10000 Constant limit Variable first
|
||||
|
||||
: allotbuffer ( -- )
|
||||
first @ r0 @ - b/buf 2+ u< ?exit
|
||||
b/buf negate first +! first @ dup emptybuf
|
||||
prev @ over ! prev ! ;
|
||||
|
||||
: freebuffer ( -- ) first @ limit b/buf - u<
|
||||
IF first @ backup prev
|
||||
BEGIN dup @ first @ - WHILE @ REPEAT
|
||||
first @ @ swap ! b/buf first +! THEN ;
|
||||
|
||||
: all-buffers BEGIN first @ allotbuffer first @ = UNTIL ;
|
||||
|
||||
| : init-buffers prev off limit first ! all-buffers ;
|
||||
|
||||
1557
8080/CPM/cpmfiles/vf-core.fth
Normal file
1557
8080/CPM/cpmfiles/vf-core.fth
Normal file
File diff suppressed because it is too large
Load Diff
36
8080/CPM/cpmfiles/vf-end.fth
Normal file
36
8080/CPM/cpmfiles/vf-end.fth
Normal file
@ -0,0 +1,36 @@
|
||||
\ *** Block No. 116, Hexblock 74
|
||||
|
||||
\ Rest of Standard-System 04Oct87 07Oct87
|
||||
|
||||
\ 2 +load \ Operating System
|
||||
|
||||
Host ' Transient 8 + @ Transient Forth Context @ 6 + !
|
||||
|
||||
Target Forth also definitions
|
||||
|
||||
Vocabulary Assembler Assembler definitions
|
||||
Transient Assembler
|
||||
>Next Constant >Next
|
||||
hpush Constant hpush
|
||||
dpush Constant dpush
|
||||
|
||||
Target Forth also definitions
|
||||
: forth-83 ; \ last word in Dictionary
|
||||
|
||||
\ *** Block No. 117, Hexblock 75
|
||||
|
||||
\ System patchup 04Oct87
|
||||
|
||||
$EF00 r0 !
|
||||
$EB00 s0 !
|
||||
s0 @ 6 + origin 2+ ! \ link Maintask to itself
|
||||
|
||||
\ s0 und r0 werden beim Booten neu an die Speichergroesse
|
||||
\ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask
|
||||
|
||||
here dp !
|
||||
|
||||
Host Tudp @ Target udp !
|
||||
Host Tvoc-link @ Target voc-link !
|
||||
Host move-threads
|
||||
|
||||
189
8080/CPM/cpmfiles/vf-io.fth
Normal file
189
8080/CPM/cpmfiles/vf-io.fth
Normal file
@ -0,0 +1,189 @@
|
||||
\ *** Block No. 84, Hexblock 54
|
||||
|
||||
\ .status push load 20Oct86
|
||||
|
||||
Defer .status ' noop Is .status
|
||||
|
||||
| Create: pull r> r> ! ;
|
||||
|
||||
: push ( addr -- ) r> swap dup >r @ >r pull >r >r ;
|
||||
restrict
|
||||
|
||||
: (load ( blk offset -- )
|
||||
isfile push loadfile push fromfile push blk push >in push
|
||||
>in ! blk ! isfile@ loadfile ! .status interpret ;
|
||||
|
||||
: load ( blk --) ?dup 0=exit 0 (load ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 85, Hexblock 55
|
||||
|
||||
\ +load thru +thru --> rdepth depth 20Oct86
|
||||
|
||||
: +load ( offset --) blk @ + load ;
|
||||
|
||||
: thru ( from to --) 1+ swap DO I load LOOP ;
|
||||
: +thru ( off0 off1 --) 1+ swap DO I +load LOOP ;
|
||||
|
||||
: --> 1 blk +! >in off .status ; immediate
|
||||
|
||||
: rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ;
|
||||
: depth ( -- +n) sp@ s0 @ swap - 2/ ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 86, Hexblock 56
|
||||
|
||||
\ quit (quit abort UH 25Jan88
|
||||
|
||||
: (prompt ( -- )
|
||||
state @ IF cr ." ] " ELSE ." ok" cr THEN .status ;
|
||||
|
||||
Defer prompt ' (prompt Is prompt
|
||||
|
||||
: (quit BEGIN prompt query interpret REPEAT ;
|
||||
|
||||
Defer 'quit ' (quit Is 'quit
|
||||
: quit r0 @ rp! level off [compile] [ 'quit ;
|
||||
|
||||
: standardi/o [ output ] Literal output 4 cmove ;
|
||||
|
||||
Defer 'abort ' noop Is 'abort
|
||||
: abort end-trace clearstack 'abort standardi/o quit ;
|
||||
|
||||
\ *** Block No. 87, Hexblock 57
|
||||
|
||||
\ (error Abort" Error" 20Oct86 18Nov87
|
||||
|
||||
Variable scr 1 scr ! Variable r# 0 r# !
|
||||
|
||||
: (error ( string -- ) standardi/o space here .name
|
||||
count type space ?cr
|
||||
blk @ ?dup IF scr ! >in @ r# ! THEN quit ;
|
||||
' (error errorhandler !
|
||||
|
||||
: (abort" "lit swap IF >r clearstack r>
|
||||
errorhandler perform exit THEN drop ; restrict
|
||||
|
||||
| : (err" "lit swap IF errorhandler perform exit THEN
|
||||
drop ; restrict
|
||||
: Abort" compile (abort" ," align ; immediate restrict
|
||||
: Error" compile (err" ," align ; immediate restrict
|
||||
|
||||
\ *** Block No. 88, Hexblock 58
|
||||
|
||||
\ -trailing 30Jun86 18Nov87
|
||||
|
||||
Code -trailing ( addr n1 -- addr n2 )
|
||||
D pop H pop H push
|
||||
D dad xchg D dcx
|
||||
Label -trail H A mov L ora hpush jz
|
||||
D ldax BL cpi hpush jnz
|
||||
H dcx D dcx -trail jmp end-code
|
||||
|
||||
\ \\
|
||||
\ : -trailing ( addr n1 -- addr n2)
|
||||
\ 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 89, Hexblock 59
|
||||
|
||||
\ space spaces 30Jun86
|
||||
|
||||
$20 Constant bl
|
||||
|
||||
: space bl emit ;
|
||||
: spaces ( u --) 0 ?DO space LOOP ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 90, Hexblock 5a
|
||||
|
||||
\ hold <# #> sign # #s 17Oct86
|
||||
|
||||
| : hld ( -- addr) pad 2- ;
|
||||
|
||||
: hold ( char -- ) -1 hld +! hld @ c! ;
|
||||
|
||||
: <# hld hld ! ;
|
||||
|
||||
: #> ( 32b -- addr +n ) 2drop hld @ hld over - ;
|
||||
|
||||
: sign ( n -- ) 0< IF Ascii - hold THEN ;
|
||||
|
||||
: # ( +d1 -- +d2) base @ ud/mod rot 9 over <
|
||||
IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ;
|
||||
|
||||
: #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
|
||||
|
||||
\ *** Block No. 91, Hexblock 5b
|
||||
|
||||
\ print numbers 24Dec83
|
||||
|
||||
: d.r -rot under dabs <# #s rot sign #>
|
||||
rot over max over - spaces type ;
|
||||
|
||||
: .r swap extend rot d.r ;
|
||||
|
||||
: u.r 0 swap d.r ;
|
||||
|
||||
: d. 0 d.r space ;
|
||||
|
||||
: . extend d. ;
|
||||
|
||||
: u. 0 d. ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 92, Hexblock 5c
|
||||
|
||||
\ .s list c/l l/s 05Oct87
|
||||
|
||||
: .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ;
|
||||
|
||||
$40 Constant c/l \ Screen line length
|
||||
$10 Constant l/s \ lines per screen
|
||||
|
||||
: list ( blk -- )
|
||||
scr ! ." Scr " scr @ u.
|
||||
l/s 0 DO
|
||||
cr I 2 .r space scr @ block I c/l * + c/l -trailing type
|
||||
LOOP cr ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 93, Hexblock 5d
|
||||
|
||||
\ multitasker primitives 20Nov87
|
||||
|
||||
Code end-trace \ patch Next to its original state
|
||||
$0A A mvi ( IP ldax ) >next sta
|
||||
$6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code
|
||||
|
||||
Code pause >next here 2- ! end-code
|
||||
|
||||
: lock ( addr -- ) dup @ up@ = IF drop exit THEN
|
||||
BEGIN dup @ WHILE pause REPEAT up@ swap ! ;
|
||||
|
||||
: unlock ( addr -- ) dup lock off ;
|
||||
|
||||
Label wake H pop H dcx UP shld
|
||||
6 D lxi D dad M A mov H inx M H mov A L mov sphl
|
||||
H pop RP shld IP pop Next end-code
|
||||
222
8080/CPM/cpmfiles/vf-sys.fth
Normal file
222
8080/CPM/cpmfiles/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…
x
Reference in New Issue
Block a user