486 lines
14 KiB
Modula-2
486 lines
14 KiB
Modula-2
fl
|
|
|
|
hex
|
|
|
|
: mod:basics ;
|
|
|
|
\ Copyright (c) 2010 Sal Sanci
|
|
\ Anpassung für Hive-System 2011 dr235
|
|
|
|
\ ------------------------------------------------------ BASICS
|
|
|
|
\ this words needs to align with the assembler code
|
|
: _stptr 5 _cv ;
|
|
: _sttop 2e _cv ;
|
|
|
|
\ _words ( cstr -- )
|
|
: _words lastnfa
|
|
begin
|
|
2dup swap dup if npfx else 2drop -1 then
|
|
if dup .strname space then
|
|
nfa>next dup 0=
|
|
until 2drop cr ;
|
|
|
|
\ words name ( -- ) prints the words in the forth dictionary
|
|
: words parsenw _words ;
|
|
|
|
\ .long ( n -- ) emit 8 hex digits
|
|
: .long dup 10 rshift .word .word ;
|
|
|
|
\ st? ( -- ) prints out the stack
|
|
: st? ." ST: " _stptr COG@ 2+ dup _sttop <
|
|
if _sttop swap - 0
|
|
do _sttop 2- i - COG@ .long space loop
|
|
else drop
|
|
then cr ;
|
|
|
|
\ variable ( -- ) skip blanks parse the next word and create
|
|
\ a variable, allocate a long, 4 bytes
|
|
: variable
|
|
lockdict create $C_a_dovarl w, 0 l, forthentry freedict ;
|
|
|
|
\ constant ( x -- ) skip blanks parse the next word and create
|
|
\ a constant, allocate a long, 4 bytes
|
|
: constant
|
|
lockdict create $C_a_doconl w, l, forthentry freedict ;
|
|
|
|
\ waitpeq ( n1 n2 -- ) \ wait until state n1 is equal to
|
|
\ ina anded with n2
|
|
: waitpeq _execasm2>0 1E0 _cnip ;
|
|
|
|
\ locknew ( -- n2 ) allocate a lock, result is in n2, -1
|
|
\ if unsuccessful
|
|
: locknew -1 4 hubop -1 = if drop -1 then ;
|
|
|
|
\ (forget) ( cstr -- ) wind the dictionary back to the word
|
|
\ which follows - caution
|
|
: (forget) dup
|
|
if
|
|
find if
|
|
pfa>nfa nfa>lfa dup here W! W@ wlastnfa W!
|
|
else .cstr 3f emit cr then
|
|
else drop then ;
|
|
|
|
\ forget ( -- ) wind the dictionary back to the word which
|
|
\ follows - caution
|
|
: forget parsenw (forget) ;
|
|
|
|
\ free ( -- ) display free main bytes and current cog longs
|
|
: free dictend W@ here W@ - . ." bytes free - " par
|
|
coghere W@ - . ." cog longs free" cr ;
|
|
|
|
\ ifnot: name ( -- ) - bedingte compilierung; wenn name schon
|
|
\ im wörterbuch vorhanden, wird bis zum nächsten semikolon
|
|
\ der eingabestrom ignoriert
|
|
: ifnot: parsenw nip find if begin key 3B = until
|
|
key drop then ;
|
|
\ bei konstrukte, die keine doppelpunkdefinition sind, muss der
|
|
\ block mit diesem Wort abgeschlossen werden
|
|
: :; ;
|
|
|
|
\ --------------------------------------------------------- BUS
|
|
|
|
\ bin ( -- ) - umschaltung auf duales zahlensystem
|
|
\ : bin 2 base W! ;
|
|
\ +---------------------------- /hs
|
|
\ |+--------------------------- /wr
|
|
\ ||+-------------------------- busclk
|
|
\ |||+------------------------- hbeat
|
|
\ ||||+------------------------ al
|
|
\ |||||+----------------------- /bel
|
|
\ ||||||+---------------------- /adm
|
|
\ |||||||+--------------------- /ram2
|
|
\ ||||||||+-------------------- /ram1
|
|
\ ||||||||| +--------- a0..10
|
|
\ ||||||||| |
|
|
\ ||||||||| | +- d0..7
|
|
\ |||||||||+---------++------+
|
|
\ 00000000000000000000000000000000
|
|
\ bin 00000111111111111111111100000000 constant dinp hex
|
|
\ bin 00000111111111111111111111111111 constant dout hex
|
|
\ bin 00000010000000000000000000000000 constant boff hex
|
|
\ bin 00000100011110000000000000000000 constant _s1 hex
|
|
\ bin 00000000001110000000000000000000 constant _b1 hex
|
|
\ bin 00000010001110000000000000000000 constant _b2 hex
|
|
\ bin 00000110001110000000000000000000 constant _b3 hex
|
|
\ bin 00000000010110000000000000000000 constant _a1 hex
|
|
\ bin 00000010010110000000000000000000 constant _a2 hex
|
|
\ bin 00000110010110000000000000000000 constant _a3 hex
|
|
\ bin 00001000000000000000000000000000 constant ?hs hex
|
|
|
|
8000000 constant ?hs
|
|
|
|
: [inp] \ ( -- ) bus eingabe
|
|
7FFFF00 dira COG! ; \ dinp
|
|
|
|
: [out] \ ( -- ) bus ausgabe
|
|
7FFFFFF dira COG! ; \ dout
|
|
|
|
: [off] \ ( -- ) bus aus
|
|
2000000 dira COG! 0 outa COG! ; \ boff
|
|
|
|
: [end] \ ( -- ) buskommunikation beendet
|
|
4780000 outa COG! [inp] ; \ _s1
|
|
|
|
: [hs=1] \ ( -- ) wartet auf hs = 1
|
|
?hs dup waitpeq ;
|
|
|
|
: [hs=0] \ ( -- ) warten auf hs = 0
|
|
0 ?hs waitpeq ;
|
|
|
|
: [s!] \ ( c ctrl -- ) sende 8 bit an einen slave
|
|
[out] [hs=1] swap ff and or outa COG! [hs=0] [end] ;
|
|
|
|
: [s@] \ ( ctrl -- c ) empfängt 8 bit von einem slave
|
|
[inp] [hs=1] outa COG! [hs=0] ina COG@ ff and [end] ;
|
|
|
|
: [b!] \ ( c -- ) sende 8 bit an bellatrix
|
|
2380000 [s!] ; \ _b2
|
|
|
|
: [a!] \ ( c -- ) sende 8 bit an administra
|
|
2580000 [s!] ; \ _a2
|
|
|
|
: [b@] \ ( -- c ) empfängt 8 bit von bellatrix
|
|
6380000 [s@] ; \ _b3
|
|
|
|
: [a@] \ ( -- c ) empfängt 8 bit von administra
|
|
6580000 [s@] ; \ _a3
|
|
|
|
: <8 \ ( -- )
|
|
8 lshift ;
|
|
|
|
\ [b.l!] ( 32b -- ) - long an bellatrix senden
|
|
: [b.l!]
|
|
dup 18 rshift [b!]
|
|
dup 10 rshift [b!]
|
|
dup 8 rshift [b!]
|
|
[b!] ;
|
|
|
|
\ [b.l@] ( -- 32b ) - long von bellatrix einlesen
|
|
: [b.l@]
|
|
[b@] <8
|
|
[b@] or <8
|
|
[b@] or <8
|
|
[b@] or ;
|
|
|
|
\ [a.s@] ( -- ) - einen cstring von administra empfangen
|
|
\ und im pad speichern
|
|
: [a.s@]
|
|
[a@] pad 2dup C! 1+ swap
|
|
0 do dup [a@] swap C! 1+ loop drop ;
|
|
|
|
\ [a.s!] ( cstr -- ) - einen cstring an administra senden
|
|
: [a.s!]
|
|
dup C@ dup [a!] \ ( -- cstr len ) len senden
|
|
0 do \ ( cstr len -- cstr )
|
|
1+ dup C@ [a!] \ ( cstr -- cstr+1 ) zeichen senden
|
|
loop drop ; \ ( cstr -- )
|
|
|
|
\ [a.w@] ( -- 16b ) - 16bit-wert von administra einlesen
|
|
: [a.w@]
|
|
[a@] <8 [a@] or ;
|
|
|
|
\ [a.l!] ( 32b -- ) - long an administra senden
|
|
: [a.l!]
|
|
dup 18 rshift [a!]
|
|
dup 10 rshift [a!]
|
|
dup 8 rshift [a!]
|
|
[a!] ;
|
|
|
|
\ [a.l@] ( -- 32b ) - long von administra einlesen
|
|
: [a.l@]
|
|
[a@] <8
|
|
[a@] or <8
|
|
[a@] or <8
|
|
[a@] or ;
|
|
|
|
wvariable b[lock] \ nummer der semaphore für den
|
|
\ zugriff auf die bus-hardware
|
|
|
|
\ b[ ( -- ) bus belegen; wartet bis semaphore freigegeben ist
|
|
: b[ begin b[lock] W@ lockset -1 <> until [inp] ;
|
|
|
|
\ ]b ( -- ) bus freigeben
|
|
\ ! busclk bleibt auf ausgabe, da dieses signal sonst
|
|
\ kein definierten pegel besitzt !
|
|
: ]b [off] b[lock] W@ lockclr drop ;
|
|
|
|
\ administra-kommandoformate
|
|
|
|
: b[a! b[ [a!] ;
|
|
: b[a!a! b[ [a!] [a!] ;
|
|
: adm:fkt! b[a! ]b ; \ ( fkt -- )
|
|
: adm:fkt!b@ b[a! [a@] ]b ; \ ( fkt -- b )
|
|
: adm:fkt!b! b[a!a! ]b ; \ ( b fkt -- )
|
|
: adm:fkt!b!b@ b[a!a! [a@] ]b ; \ ( b fkt -- b )
|
|
: adm:fkt!s@ b[a! [a.s@] ]b ; \ ( fkt -- )
|
|
: adm:fkt!s!b@ b[a! [a.s!] [a@] ]b ; \ ( s fkt -- b )
|
|
: adm:fkt!b!l@ b[a!a! [a.l@] ]b ; \ ( b fkt -- l )
|
|
|
|
\ ----------------------------------------------------- SD0.LIB
|
|
|
|
\ marker-funktionen
|
|
|
|
\ adm:dmact ( dmnr -- ) - marker aktivieren
|
|
: adm:dmact 19 adm:fkt!b!b@ drop ;
|
|
|
|
\ adm:dmset ( dmnr -- ) - marker setzen
|
|
: adm:dmset 1A adm:fkt!b! ;
|
|
|
|
\ dateisystem-funktionen
|
|
|
|
\ adm:volname ( -- ) - name des volumes im pad ablegen
|
|
: adm:volname 0C adm:fkt!s@ ;
|
|
|
|
\ adm:mount ( -- err ) - medium mounten
|
|
: adm:mount 01 adm:fkt!b@ ;
|
|
|
|
\ adm:unmount ( -- err ) - medium unmounten
|
|
: adm:unmount 18 adm:fkt!b@ ;
|
|
|
|
\ adm:checkmounted ( -- t/f )
|
|
: adm:checkmounted 0D adm:fkt!b@ ;
|
|
|
|
\ adm:diropen ( -- ) - verzeichnisabfrage initialisieren
|
|
: adm:diropen 02 adm:fkt! ;
|
|
|
|
\ adm:nextfile ( -- st )
|
|
\ st = 0 - keine gültige datei
|
|
\ st = 1 - dateiname im pad gültig
|
|
\ bei gültigem eintrag befindet sich der dateiname im pad
|
|
: adm:nextfile b[ 3 [a!] [a@] dup if [a.s@] then ]b ;
|
|
|
|
\ adm:fattrib ( nr -- attrib ) - dateiattribut abfragen
|
|
: adm:fattrib 0B adm:fkt!b!l@ ;
|
|
|
|
\ adm:chdir ( cstr -- err ) - verzeichnis öffnen
|
|
: adm:chdir 16 adm:fkt!s!b@ ;
|
|
|
|
\ adm:getc ( -- c ) - ein zeichen aus der geöffneten datei lesen
|
|
: adm:getc 06 adm:fkt!b@ ;
|
|
|
|
\ adm:eof ( -- eof ) - abfrage ob end of file erreicht ist
|
|
: adm:eof 1E adm:fkt!b@ ;
|
|
|
|
\ adm:open ( cstr modus -- err ) - datei öffnen
|
|
\ modus "R" $52 - Read
|
|
\ modus "W" $57 - Write
|
|
\ modus "A" $41 - Append
|
|
: adm:open b[ 4 [a!] [a!] [a.s!] [a@] ]b ;
|
|
|
|
\ adm:close ( -- ) - datei schließen
|
|
: adm:close 05 adm:fkt!b@ ;
|
|
|
|
\ ----------------------------------------------------- SCR.LIB
|
|
|
|
\ [dscr] ( scrnr -- ) display-screen setzen
|
|
: [dscr] 0 [b!] 59 [b!] [b!] ;
|
|
|
|
\ [wscr] ( scrnr -- ) schreib-screen setzen
|
|
: [wscr] 0 [b!] 58 [b!] [b!] ;
|
|
|
|
\ [key?] ( -- c ) - ungekapselte tastaturstatusabfrage
|
|
: [key?] 0 [b!] 1 [b!] [b@] ;
|
|
|
|
\ [key] ( -- c ) - ungekapselte tastaturabfrage
|
|
: [key] 0 [b!] 2 [b!] [b@] ;
|
|
|
|
\ [emit] ( c -- ) - ungekapselte zeichenausgabe
|
|
: [emit] emit? if emit then ;
|
|
|
|
\ ----------------------------------------------------- TOOLS
|
|
|
|
\ cls ( -- ) - screen löschen
|
|
: cls 01 emit ;
|
|
|
|
\ .tab ( -- ) - tabulator
|
|
: .tab 09 emit ;
|
|
|
|
\ .err ( err -- ) - fehlermeldung ausgeben
|
|
\ 0 no error
|
|
\ 1 fsys unmounted
|
|
\ 2 fsys corrupted
|
|
\ 3 fsys unsupported
|
|
\ 4 not found
|
|
\ 5 file not found
|
|
\ 6 dir not found
|
|
\ 7 file read only
|
|
\ 8 end of file
|
|
\ 9 end of directory
|
|
\ 10 end of root
|
|
\ 11 dir is full
|
|
\ 12 dir is not empty
|
|
\ 13 checksum error
|
|
\ 14 reboot error
|
|
\ 15 bpb corrupt
|
|
\ 16 fsi corrupt
|
|
\ 17 dir already exist
|
|
\ 18 file already exist
|
|
\ 19 out of disk free space
|
|
\ 20 disk io error
|
|
\ 21 command not found
|
|
\ 22 timeout
|
|
\ 23 parameter error
|
|
: .err dup if ERR then drop ;
|
|
|
|
\ .pad ( -- ) - ausgabe eines strings im pad
|
|
: .pad pad .cstr ;
|
|
|
|
\ .vname ( -- ) - ausgabe des namens der eingelegten sd-card
|
|
: .vname adm:volname .pad ;
|
|
|
|
\ mount ( -- ) - sd-card mounten
|
|
: mount adm:mount .err ." Medium : " .vname cr ;
|
|
|
|
\ unmount ( -- ) - sd-card unmounten
|
|
: unmount adm:unmount .err ;
|
|
|
|
\ mount? ( -- ) - test ob medium mounted ist
|
|
\ wird als exception gewertet
|
|
: mount? adm:checkmounted 0= if 1 .err then ;
|
|
|
|
\ padbl ( -- ) fills this cogs pad with blanks
|
|
: padbl pad padsize bl fill ;
|
|
|
|
\ .entry ( -- st ) - einen verzeichniseintrag ausgeben
|
|
: .entry
|
|
adm:nextfile 13 adm:fattrib if 0F emit else space then
|
|
dup if .pad .tab then ;
|
|
|
|
\ .len ( st -- st ) - dateilänge ausgeben
|
|
: .len dup if 0 adm:fattrib . then ;
|
|
|
|
\ lscnt ( cnt1 st -- cnt2 st ) - spaltenformatierung für ls
|
|
\ cnt - spaltenzähler, st - flag verzeichnisende
|
|
: lscnt
|
|
swap 1+ dup 4 = if cr drop 0 else .tab then swap ;
|
|
|
|
\ lsl ( -- ) - verzeichnis anzeigen, long-format
|
|
: lsl mount?
|
|
adm:diropen begin .entry .len cr 0= until padbl ;
|
|
|
|
\ ls ( -- ) - verzeichnis in spalten anzeigen
|
|
: ls mount?
|
|
adm:diropen 0 begin .entry lscnt 0= until drop padbl cr ;
|
|
|
|
\ cd name ( -- ) - verzeichnis wechseln
|
|
: cd mount? parsenw adm:chdir .err ;
|
|
|
|
\ open name ( -- ) - datei lesend öffnen und auf fehler prüfen
|
|
: open
|
|
mount? parsenw dup
|
|
if 52 adm:open else drop 23 then .err ;
|
|
|
|
\ close ( -- ) - geöffnete datei schließen
|
|
: close adm:close .err ;
|
|
|
|
\ dload name - datei compilieren; log im gleichen screen
|
|
\ load name - datei compilieren; log screen 3
|
|
\ sys name - datei aus sys compilieren; log screen 3
|
|
\ die datei wird in der nächsten freien cog compiliert
|
|
\ fl ist für load nicht nötig und bringt in dem kontext
|
|
\ die cog-zuordnung durcheinander
|
|
|
|
: (load)
|
|
begin adm:getc emit adm:eof until ;
|
|
|
|
: (dload)
|
|
open cogid nfcog iolink
|
|
(load)
|
|
cogid iounlink close ;
|
|
|
|
: (sload)
|
|
open cogid 3 dup b[ [wscr] ]b iolink
|
|
(load)
|
|
cogid dup b[ [wscr] ]b iounlink close ;
|
|
|
|
: load
|
|
." Loading... " (sload) ;
|
|
|
|
: dload
|
|
(dload) ;
|
|
|
|
: sys
|
|
2 adm:dmset 1 adm:dmact ." Loading... " (sload) 2 adm:dmact ;
|
|
|
|
\ ------------------------------------------------- SPIN-LOADER
|
|
|
|
\ (spin) ( cstr -- ) - c" reg.sys" (spin)
|
|
: (spin)
|
|
dup C@ 1+
|
|
0 do
|
|
dup i + C@
|
|
ldvar 1+ i + C!
|
|
loop drop
|
|
1 ldvar C!
|
|
;
|
|
|
|
\ spin name ( -- ) - spinobjekt "name" starten
|
|
: spin
|
|
parsenw (spin) ;
|
|
|
|
\ regime ( -- ) - startet dir trios-cli "regime"
|
|
: regime
|
|
0 adm:dmact
|
|
c" reg.sys" (spin) ;
|
|
|
|
\ ----------------------------------------------------- DRV:INT
|
|
|
|
|
|
wvariable icog \ nummer der drv:int-cog
|
|
wvariable lcog \ nummer interaktiven cog
|
|
|
|
\ xint ( n -- ) io von cog n auf drv:int umschalten
|
|
: xint icog W@ ioconn ;
|
|
|
|
\ [cogscr] ( nr -- ) - umschaltung screen + cog
|
|
: [cogscr]
|
|
dup 2dup lcog W! xint [dscr] [wscr] ;
|
|
|
|
\ =n ( n1 n2 -- n1 n1=n2 )
|
|
: =n 2dup = swap drop ;
|
|
|
|
\ [esc] ( -- ) - manager für esc-funktionen im drv:int
|
|
: [esc]
|
|
begin [key?] until [key]
|
|
71 =n if 1b [emit] then \ esc - q : esc-char/quit
|
|
31 =n if 1 [cogscr] then \ esc - 1 : cog-screen 0
|
|
32 =n if 2 [cogscr] then \ esc - 2 : cog-screen 1
|
|
33 =n if 3 [cogscr] then \ esc - 3 : cog-screen 2
|
|
62 =n if lcog W@ cogreset then \ esc - b : break (cog)
|
|
72 =n if reboot then \ esc - r : reset (chip)
|
|
drop ; \ esc - esc : pause
|
|
|
|
\ drv:int ( -- ) treiber für bellatrix-terminal
|
|
\ diese cog fragt in einer endlosschleife ab, ob zeichen
|
|
\ versendet oder empfangen werden sollen. um die zeichenausgabe
|
|
\ zu beschleunigen, findet ausgabe und eingabe in einem
|
|
\ verhältnis von 512:1 statt. per esc-code können spezielle
|
|
\ funktionen im driver ausgelöst werden.
|
|
: drv:int
|
|
\ name und typ der cog einstellen
|
|
cogid dup cogstate 10 swap C! c" drv:int" over
|
|
cognumpad ccopy
|
|
20 delms 0D emit \ verzögertes cr für prompt
|
|
begin
|
|
\ input --> vga/video
|
|
200 0 do key? \ eingabezeichen vorhanden?
|
|
if key b[ [b!] ]b then loop \ cog ---> bel.vga
|
|
\ output <-- keyboard
|
|
b[ [key?] \ tastenstatus bellatrix?
|
|
if [key] dup 1b = if drop [esc] else [emit] thens ]b
|
|
0 until ;
|
|
|
|
\ ----------------------------------------------------- SYSINIT
|
|
|
|
: start \ ( -- ) initialisierung hive
|
|
locknew b[lock] W! \ b-semaphore
|
|
0 dup cogstate 10 swap C! c" drv:ldr" over
|
|
cognumpad ccopy
|
|
5 dup icog W! c" drv:int" swap cogx 1 b[ [cogscr] ]b ;
|
|
: _ob onboot ;
|
|
: onboot _ob start ;
|
|
|
|
|
|
|