VolksForth/sources/msdos/extend.fth
2020-07-20 23:47:02 +02:00

188 lines
12 KiB
Forth

\ *** Block No. 0 Hexblock 0
\ ks 11 mai 88
Dieses File enth„lt Definitionen, die zum Laden der weiteren
System- und Applikationsfiles ben”tigt werden.
Unter anderem finden sich hier auch MS-DOS spezifische
Befehle wie zum Beispiel das Allokieren von Speicher-
platz ausserhalb des auf 64k begrenzten Forthsystems
und einige Routinen, die das Arbeiten mit dem Video-
Display erleichtern sowie einige Operatoren zur String-
manipulation.
\ *** Block No. 1 Hexblock 1
\ loadscreen for often used words ks cas 25sep16
Onlyforth \needs Assembler 2 loadfrom asm.fb
' save-buffers Alias sav
' name &12 + Constant 'name
' page Alias cls
1 8 +thru .( Systemerweiterung geladen) cr
\ *** Block No. 2 Hexblock 2
\ Postkernel words ks 22 dez 87
: blank ( addr quan -- ) bl fill ;
Code stash ( u1 u2 -- u1 u1 u2 )
S W mov W ) push Next end-code
\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ;
: >expect ( addr len -- ) stash expect span @ over place ;
: .field ( addr len quan -- )
over - >r type r> 0 max spaces ;
: tab ( n -- ) col - 0 max spaces ;
\ *** Block No. 3 Hexblock 3
\ postkernel ks 08 m„r 89
\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT
\needs end-code : end-code toss also ;
: u? ( addr -- ) @ u. ;
: adr ' >body state @ 0=exit [compile] Literal ; immediate
: Abort( ( f -- ) IF [compile] .( true abort" !" THEN
[compile] ( ;
: arguments ( n -- )
depth 1- > Error" zu wenige Parameter" ;
\ *** Block No. 4 Hexblock 4
\ MS-DOS memory management
Code lallocate ( pages -- seg ff / rest err# )
R push D R mov $48 # A+ mov $21 int CS
?[ A D xchg A pop R push A R xchg
][ R pop A push 0 # D mov ]? Next end-code
Code lfree ( seg -- err# )
E: push D E: mov $49 # A+ mov $21 int CS
?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code
\ *** Block No. 5 Hexblock 5
\ postkernel ks 03 aug 87
c/row c/col * 2* Constant c/dis \ characters per display
Code video@ ( -- seg ) D push R D mov $F # A+ mov
$10 int R D xchg 0 # D- mov 7 # A- cmp
0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next
end-code
: savevideo ( -- seg / ff )
[ c/dis b/seg /mod swap 0<> - ] Literal lallocate
IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ;
: restorevideo ( seg -- ) ?dup 0=exit
dup 0 video@ 0 c/dis lmove lfree drop ;
\ *** Block No. 6 Hexblock 6
\ string operators append attach ks 21 jun 87
| : .stringoverflow true Abort" String zu lang" ;
Code append ( char addr -- )
D W mov D pop W ) A- mov 1 # A- add CS
?[ ;c: .stringoverflow ; Assembler ]?
A- W ) mov 0 # A+ mov A W add
D- W ) mov D pop Next end-code
Code attach ( addr len addr1 -- ) D W mov C pop
I D mov I pop W ) A- mov A- A+ mov C- A+ add CS
?[ ;c: .stringoverflow ; Assembler ]?
A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc
rep byte movs D I mov D pop Next end-code
\ *** Block No. 7 Hexblock 7
\\ string operators append attach detract ks 21 jun 87
: append ( char addr -- )
under count + c! dup c@ 1+ swap c! ;
: attach ( addr len addr.to -- )
>r under r@ count + swap move r@ c@ + r> c! ;
: detract ( addr -- char )
dup c@ 1- dup 0> and over c!
count >r dup count -rot swap r> cmove ;
\ *** Block No. 8 Hexblock 8
\ ?" string operator ks 09 feb 88
\ : (?" ( 8b -- index ) "lit under count rot
\ scan IF swap - exit THEN 2drop false ;
| Create months ," janfebm„raprmaijunjulaugsepoktnovdez"
: >months ( n -- addr len ) 3 * 2- months + 3 ;
| Code (?" ( 8b -- index )
A D xchg I ) C- mov 0 # C+ mov C I add
I W mov I inc std 0<>rep byte scas cld
0= ?[ C inc ]? C D mov Next
end-code
: ?" compile (?" ," align ; immediate restrict
\ *** Block No. 9 Hexblock 9
\ Conditional compilation ks 12 dez 88
| Defer cond
: .THEN ; immediate
: .ELSE ( -- ) 0
BEGIN name nullstring? IF drop exit THEN
find IF cond -1 case? ?exit ELSE drop THEN
REPEAT ; immediate
: .IF ( f -- ) ?exit [compile] .ELSE ; immediate
| : (cond ( n cfa -- n' )
['] .THEN case? IF 1- exit THEN
['] .ELSE case? IF dup 0= + exit THEN
['] .IF = 0=exit 1+ ; ' (cond is cond
\ *** Block No. 10 Hexblock A