deac/presentation.fs
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

[x] -> {x}. einige bugs bei stackoperationen ausgebessert

Browse source
This commit is contained in:
Denis Knauf 2010-12-23 22:30:28 +01:00
parent ef5123fde5
commit f6f7aa8ef1
1 changed files with 57 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

98
presentation.fs
View file

@ -11,45 +11,50 @@
; ;
: <presentation> ( -- 0 addr0 ) 0 here ; : <presentation> ( -- 0 addr0 ) 0 here ;
: </presentation> ( 0 <addr...> -- faddr paddr 0 ) : </presentation> ( 0 <addr...> -- faddr laddr paddr 0 )
0 , here .s \ 0 <addr...> faddr
dup begin swap dup , 0= until begin swap dup \ 0 <addr..> addr0 faddr
here 0 while
s" New page at " type here . s" to " type dup . newline type
, \ 0 <addr..> faddr
repeat .s
drop \ faddr
here dup 0 \ faddr laddr paddr 0
; ;
: csi ( -- ) 27 emit 91 emit ; : csi ( -- ) 27 emit 91 emit ;
: sgr ( u -- ) csi 0 0 d.r 109 emit ; : sgr ( u -- ) csi 0 0 d.r 109 emit ;
: beep 7 type ; : beep 7 type ;
\ Es folgen ein paar blockorientierte Kennzeichnungen. \ Es folgen ein paar blockorientierte Kennzeichnungen.
: [h] ( addr -- addr ) ; : {h} ( addr -- addr ) ;
: [/h] ( addr -- addr ) ; : {/h} ( addr -- addr ) ;
: [p] ( addr -- addr ) ; : {p} ( addr -- addr ) ;
: [/p] ( addr -- addr ) ; : {/p} ( addr -- addr ) ;
: <h> ( -- addr u0 ) ['] [h] , here 0 ; : <h> ( -- addr u0 ) ['] {h} , here 0 ;
: </h> ( addr len -- ) ['] [/h] , swap ! ; : </h> ( addr len -- ) ['] {/h} , swap ! ;
: <p> ( -- addr u0 ) ['] [p] , here 0 ; : <p> ( -- addr u0 ) ['] {p} , here 0 ;
: </p> ( addr len -- ) ['] [/p] , swap ! ; : </p> ( addr len -- ) ['] {/p} , swap ! ;
\ Es folgen ein paar syntaktische Textauszeichnungen. \ Es folgen ein paar syntaktische Textauszeichnungen.
: [i] ( addr -- addr ) 7 sgr ; : {i} ( addr -- addr ) 7 sgr ;
: [/i] ( addr -- addr ) 27 sgr ; : {/i} ( addr -- addr ) 27 sgr ;
: [b] ( addr -- addr ) 1 sgr ; : {b} ( addr -- addr ) 1 sgr ;
: [/b] ( addr -- addr ) 22 sgr ; : {/b} ( addr -- addr ) 22 sgr ;
: [u] ( addr -- addr ) 4 sgr ; : {u} ( addr -- addr ) 4 sgr ;
: [/u] ( addr -- addr ) 24 sgr ; : {/u} ( addr -- addr ) 24 sgr ;
: [fc] ( addr -- addr ) dup @ 30 + sgr 1 cells + ; : {fc} ( addr -- addr ) dup @ 30 + sgr 1 cells + ;
: [/fc] ( addr -- addr ) 39 sgr ; : {/fc} ( addr -- addr ) 39 sgr ;
: [bc] ( addr -- addr ) dup @ 40 + sgr 1 cells + ; : {bc} ( addr -- addr ) dup @ 40 + sgr 1 cells + ;
: [/bc] ( addr -- addr ) 49 sgr ; : {/bc} ( addr -- addr ) 49 sgr ;
: <i> ( -- ) ['] [i] , ; : <i> ( -- ) ['] {i} , ;
: </i> ( -- ) ['] [/i] , ; : </i> ( -- ) ['] {/i} , ;
: <u> ( -- ) ['] [u] , ; : <u> ( -- ) ['] {u} , ;
: </u> ( -- ) ['] [/u] , ; : </u> ( -- ) ['] {/u} , ;
: <b> ( -- ) ['] [b] , ; : <b> ( -- ) ['] {b} , ;
: </b> ( -- ) ['] [/b] , ; : </b> ( -- ) ['] {/b} , ;
: <fc> ( -- ) ['] [fc] , ; : <fc> ( -- ) ['] {fc} , ;
: </fc> ( -- ) ['] [/fc] , ; : </fc> ( -- ) ['] {/fc} , ;
: <bc> ( -- ) ['] [bc] , ; : <bc> ( -- ) ['] {bc} , ;
: </bc> ( -- ) ['] [/bc] , ; : </bc> ( -- ) ['] {/bc} , ;
: <np> ( -- addr ) \ Wir legen jede Anfangsadresse einer Seite auf den Stack (Achtung, in umgekehrter Reihenfolge : <np> ( -- addr ) \ Wir legen jede Anfangsadresse einer Seite auf den Stack (Achtung, in umgekehrter Reihenfolge
here here
@ -74,40 +79,41 @@
: page_steps ( laddr paddr 0 [u] -- laddr naddr ) : page_steps ( laddr paddr 0 [u] -- laddr naddr )
\ u muss ungleich 0 sein. falls u nicht vorhanden: 1 \ u muss ungleich 0 sein. falls u nicht vorhanden: 1
dup 0= if 1 then nip cells - dup 0= if 1 then \ laddr paddr 0 u
nip cells -
; ;
: validpage? ( faddr laddr paddr -- faddr laddr paddr u ) : validpage? ( faddr laddr paddr -- faddr laddr paddr u )
2dup > \ faddr laddr paddr u 2dup > \ faddr laddr paddr u
2over drop over \ faddr laddr paddr x faddr x ) 2over drop rot tuck <
>= and rot and
; ;
: showpage' ( paddr -- ) : showpage' ( paddr -- )
dup 1 cells + @ swap @ swap \ paddr naddr addr dup cell+ \ paddr paddr+cell
@ swap @ \ naddr addr \ Seiteninhaltsadressen
0 sgr \ Alle Bildschirmeigenschaften zuruecksetzen 0 sgr \ Alle Bildschirmeigenschaften zuruecksetzen
csi s" 2J" type \ Bildschirm leeren \ csi s" 2J" type \ Bildschirm leeren
begin 2dup > begin 2dup >
while while
dup 1 cells + swap \ ... xtaddr+1 xtaddr dup cell+ swap \ naddr xtaddr xtaddr
@ \ ... xtaddr xt @ \ naddr xtaddr xt
execute \ verschiebt eventuell den Zeiger noch weiter, da es Parameter erwartet. execute \ verschiebt eventuell den Zeiger noch weiter, wenn es Parameter erwartet.
repeat repeat
drop drop drop drop
; ;
: showpage ( faddr laddr paddr -- faddr laddr paddr 0 ) : showpage ( faddr laddr paddr -- faddr laddr paddr 0 )
validpage? validpage?
if showpage' 0= if beep then
else beep dup showpage' 0
then 0
; ;
: p ( faddr laddr paddr 0 [u] -- faddr laddr paddr 0 ) : n ( faddr laddr paddr 0 [u] -- faddr laddr paddr 0 )
page_steps \ faddr paddr x page_steps \ faddr laddr paddr x
showpage showpage
; ;
: g ( faddr laddr paddr 0 u -- faddr laddr paddr 0 ) : g ( faddr laddr paddr 0 u -- faddr laddr paddr 0 )
cells cells
showpage showpage
; ;
: p ( faddr paddr 0 [u] -- faddr paddr 0 ) : p ( faddr laddr paddr 0 [u] -- faddr laddr paddr 0 )
negate n negate n
; ;