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