VolksForth/sources/AtariST/GEM/BASICS.fth

171 lines
10 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\\ *** GEM - Basics *** 26may86we
Die Routinen in dieser Library entsprechen dem, was auch dem
Pascal-, C- oder Modula-Programmierer zur Verf<EFBFBD>gung steht.
F<EFBFBD>r eine genaue Beschreibung der einzelnen Routinen verweisen
wir auf die GEM-Dokumentation des ST-Entwicklungspaketes bzw.
entsprechende Literatur.
Aus diesem Grunde wurden die - teilweise kryptischen - Namen
von Digital Research beibehalten; auch die <EFBFBD>bergabeparameter
der einzelnen Funktionen sind unver<EFBFBD>ndert geblieben.
Der Aufbau einer FORTH-Library mit 'Super-Befehlen' ist in
Arbeit.
Die Worte in diesem File werden sowohl f<EFBFBD>r VDI- als auch f<EFBFBD>r
AES-Funktionen ben<EFBFBD>tigt.
\ *** Block No. 1 Hexblock 1
\ VDI GEM Arrays and Controls Loadscreen 02nov86we
Onlyforth
\needs >absaddr : >absaddr 0 forthstart d+ ;
\needs Code 2 loadfrom assemble.scr
Vocabulary GEM GEM definitions also
1 8 +thru
\ *** Block No. 2 Hexblock 2
\ VDI GEM Arrays 05aug86we
Create intin &60 allot Create ptsin &256 allot
Create intout &90 allot Create ptsout &24 allot
Create addrin 8 allot Create addrout 4 allot
Variable grhandle
| : gemconstant ( addr n -- addr+n) over Constant + ;
Create contrl $16 allot
contrl 2 gemconstant opcode
2 gemconstant #intin
2 gemconstant #intout ' #intout Alias #ptsout
2 gemconstant #addrin
2 gemconstant #addrout
2 gemconstant function drop
\ *** Block No. 3 Hexblock 3
\ global array, Parameter blocks 02nov86we
Create global $20 allot
global &10 + Constant ap_ptree
| : gemarray ( n0 ... nk-1 k --) Create 0 ?DO , LOOP ;
addrout addrin intout intin global contrl 6 gemarray (AESpb
ptsout intout ptsin intin contrl 5 gemarray (VDIpb
Create AESpb &24 allot Create VDIpb &20 allot
: setarrays
6 0 DO (AESpb I 2* + @ >absaddr AESpb I 2* 2* + 2! LOOP
5 0 DO (VDIpb I 2* + @ >absaddr VDIpb I 2* 2* + 2! LOOP ;
\ *** Block No. 4 Hexblock 4
\ Array-Handling 09sep86we
Code array! ( n0 ... nk-1 adr k --)
SP )+ D0 move SP )+ D6 move D6 reg) A0 lea
D0 A0 adda D0 A0 adda 1 D0 subq
D0 DO SP )+ A0 -) move LOOP Next end-code
Code 4! ( n1 .. n4 addr -- )
SP )+ D6 move 8 D6 addq D6 reg) A0 lea 3 # D0 move
D0 DO SP )+ A0 -) move LOOP Next end-code
Code 4@ ( addr -- n1 .. n4 )
SP )+ D6 move D6 reg) A0 lea 3 # D0 move
D0 DO A0 )+ SP -) move LOOP Next end-code
\ *** Block No. 5 Hexblock 5
\ AES-Aufruf 09sep86we
Code AES ( opcode #intin #intout #addrin -- intout@ )
SP )+ contrl 6 + R#) move \ #addrin
SP )+ contrl 4 + R#) move \ #intout
SP )+ contrl 2+ R#) move \ #intin
SP ) D0 move SP )+ contrl R#) move \ opcode
contrl 8 + R#) clr \ #addrout
&112 D0 cmpi \ Funktions-Nr. von rsrc_gaddr
0= IF 1 # contrl 8 + R#) move THEN
AESpb # D6 move D6 reg) A0 lea A0 D1 lmove
.w $C8 # D0 move 2 trap
intout R#) SP -) move Next end-code
\ *** Block No. 6 Hexblock 6
\ VDI-Aufruf 09sep86we
Code VDI ( opcode #ptsin #intin --)
SP )+ contrl 6 + R#) move
SP )+ contrl 2+ R#) move SP )+ contrl R#) move
grhandle R#) contrl &12 + R#) move
VDIpb # D6 move D6 reg) A0 lea A0 D1 lmove
$73 D0 moveq 2 trap
Next end-code
\ *** Block No. 7 Hexblock 7
\ appl_init appl_exit graf_handle bp 12oct86
: appl_init global &14 + $10 erase &10 0 1 0 AES drop ;
: appl_exit &19 0 1 0 AES drop ;
| : sizeconstant ( addr n -- addr+n@ )
over Create , + Does> @ @ ;
Create sizes 8 allot $08 $10 $13 $13 sizes 4!
sizes 2 sizeconstant cwidth 2 sizeconstant cheight
2 sizeconstant bwidth 2 sizeconstant bheight drop
: graf_handle &77 0 5 0 AES grhandle !
intout 2+ sizes 8 cmove ;
\ *** Block No. 8 Hexblock 8
\ opnvwk clrwk clsvwk updwk 02nov86we
: opnvwk
intin &10 0 DO 1 over I 2* + ! LOOP drop
2 intin &20 + ! &100 0 &11 VDI
contrl &12 + @ grhandle ! ;
: clrwk 3 0 0 VDI ;
: clsvwk &101 0 0 VDI ;
: updwk 4 0 0 VDI ;
\ *** Block No. 9 Hexblock 9
\ s_clip grinit grexit show_c hide_c 02nov86we
: s_clip ( x1 y1 x2 y2 clipflag -- )
intin ! ptsin 4 array! &129 2 1 VDI ;
: grinit setarrays appl_init graf_handle opnvwk ;
: grexit clsvwk appl_exit ;
2Variable objc_tree 0. objc_tree 2!
Variable c_flag c_flag off
: show_c ( -- ) c_flag @ intin ! &122 0 1 VDI ;
: hide_c ( -- ) &123 0 0 VDI ;
\\ st_load_fonts st_unload_fonts
w<EFBFBD>r auch ganz h<EFBFBD>bsch, hamse aber nich!