mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
171 lines
10 KiB
Forth
171 lines
10 KiB
Forth
\ *** 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 šbergabeparameter
|
||
der einzelnen Funktionen sind unver„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”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„r auch ganz h<EFBFBD>bsch, hamse aber nich!
|