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