mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 20:34:07 +00:00
1 line
11 KiB
Plaintext
Executable File
1 line
11 KiB
Plaintext
Executable File
\ 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. \ 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 \ 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 ; \ 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" ; \ 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 \ 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 ; \ 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 \\ 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 ; \ ?" 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 \ 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 |