Virtualization/openbios
1
0
Fork 0
mirror of https://gitlab.com/qemu-project/openbios.git synced 2024-02-13 08:34:06 +08:00
Code Issues Projects Releases Wiki Activity

initial import of openbios--main--1.0--patch-26

Browse Source 
git-svn-id: svn://coreboot.org/openbios/openbios-devel@1 f158a5a8-5612-0410-a976-696ce0be7e32
This commit is contained in:
Stefan Reinauer
2006-04-26 15:08:19 +00:00
commit 5c9eb9b45b
522 changed files with 83237 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
forth/Kconfig Normal file
View File

@@ -0,0 +1,9 @@
#
#
#
#menu "Packages"
#
#source "forth/packages/Kconfig"
#
#endmenu

5
forth/admin/README Normal file
View File

@@ -0,0 +1,5 @@
\ This directory contains code that implements
\ the Administration command group
\ (Chapter 7.4 in the IEEE 1275-1994)

49
forth/admin/banner.fs Normal file
View File

@@ -0,0 +1,49 @@
\ 7.4.10 Banner
defer builtin-logo
defer builtin-banner
0 value suppress-banner?
:noname
0 0
; to builtin-logo
:noname
builddate s" built on " version s" Welcome to OpenBIOS v" pocket
tmpstrcat tmpstrcat tmpstrcat drop
; to builtin-banner
: suppress-banner ( -- )
1 to suppress-banner?
;
: banner ( -- )
suppress-banner
stdout @ ?dup 0= if exit then
\ draw logo if stdout is a "display" node
dup ihandle>phandle " device_type" rot get-package-property if 0 0 then
" display" strcmp if
drop
else
\ draw logo ( ihandle )
dup ihandle>phandle " draw-logo" rot find-method if
( ihandle xt )
swap >r >r
0 \ line #
oem-logo? if oem-logo else builtin-logo then
( 0 addr logo-len )
200 = if
d# 64 d# 64
r> r> call-package
else
r> r> 2drop 2drop
then
else
drop
then
then
oem-banner? if oem-banner else builtin-banner then
type cr
;

25
forth/admin/build.xml Normal file
View File

@@ -0,0 +1,25 @@
<build>
<!--
build description for forth administrative command group
Copyright (C) 2003-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="devices.fs"/>
<object source="nvram.fs"/>
<object source="callback.fs"/>
<object source="help.fs"/>
<object source="iocontrol.fs"/>
<object source="banner.fs"/>
<object source="reset.fs"/>
<object source="script.fs"/>
<object source="security.fs"/>
<object source="selftest.fs"/>
<object source="userboot.fs"/>
</dictionary>
</build>

10
forth/admin/callback.fs Normal file
View File

@@ -0,0 +1,10 @@
\ 7.4.9 Client program callback
: callback ( "service-name< >" "arguments<cr>" -- )
;
: $callback ( argn ... arg1 nargs addr len -- retn ... ret2 Nreturns-1 )
;
: sync ( -- )
;

356
forth/admin/devices.fs Normal file
View File

@@ -0,0 +1,356 @@
\ tag: device tree administration
\
\ this code implements IEEE 1275-1994
\
\ Copyright (C) 2003 Samuel Rydh, Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ 7.4.11.1 Device alias
: devalias ( "{alias-name}< >{device-specifier}<cr>" -- )
;
: nvalias ( "alias-name< >device-specifier<cr>" -- )
;
: $nvalias ( name-str name-len dev-str dev-len -- )
;
: nvunalias ( "alias-name< >" -- )
;
: $nvunalias ( name-str name-len -- )
;
\ 7.4.11.2 Device tree browsing
: dev ( "<spaces>device-specifier" -- )
bl parse
find-device
;
: cd
dev
;
\ find-device ( dev-str dev-len -- )
\ implemented in pathres.fs
: device-end ( -- )
0 active-package!
;
: ?active-package ( -- phandle )
active-package dup 0= abort" no active device"
;
\ -------------------------------------------------------
\ path handling
\ -------------------------------------------------------
\ used if parent lacks an encode-unit method
: def-encode-unit ( unitaddr ... )
pocket tohexstr
;
: get-encode-unit-xt ( phandle.parent -- xt )
>dn.parent @
" encode-unit" rot find-method
0= if ['] def-encode-unit then
;
: get-nodename ( phandle -- str len )
" name" rot get-package-property if " <noname>" else 1- then
;
\ helper, return the node name in the format 'cpus@addr'
: pnodename ( phandle -- str len )
dup get-nodename rot
dup " reg" rot get-package-property if drop exit then rot
\ set active-package and clear my-self (decode-phys needs this)
my-self >r 0 to my-self
active-package >r
dup active-package!
( name len prop len phandle )
get-encode-unit-xt
( name len prop len xt )
depth >r >r
decode-phys r> execute
r> -rot >r >r depth! 3drop
( name len R: len str )
r> r> " @"
here 20 + \ abuse dictionary for temporary storage
tmpstrcat >r
2swap r> tmpstrcat drop
pocket tmpstrcpy drop
r> active-package!
r> to my-self
;
: inodename ( ihandle -- str len )
my-self over to my-self >r
ihandle>phandle get-nodename
\ nonzero unit number?
false >r
depth >r my-unit r> 1+
begin depth over > while
swap 0<> if r> drop true >r then
repeat
drop
\ if not... check for presence of "reg" property
r> ?dup 0= if
" reg" my-self ihandle>phandle get-package-property
if false else 2drop true then
then
( name len print-unit-flag )
if
my-self ihandle>phandle get-encode-unit-xt
( name len xt )
depth >r >r
my-unit r> execute
r> -rot >r >r depth! drop
r> r>
( name len str len )
here 20 + tmpstrcpy
" @" rot tmpstrcat drop
2swap pocket tmpstrcat drop
then
\ add :arguments
my-args dup if
" :" pocket tmpstrcat drop
2swap pocket tmpstrcat drop
else
2drop
then
r> to my-self
;
\ helper, also used by client interface (package-to-path)
: get-package-path ( phandle -- str len )
?dup 0= if 0 0 then
dup >dn.parent @ 0= if drop " /" exit then
\ dictionary abused for temporary storage
>r 0 0 here 40 +
begin r> dup >dn.parent @ dup >r while
( path len tempbuf phandle R: phandle.parent )
pnodename rot tmpstrcat
" /" rot tmpstrcat
repeat
r> 3drop
pocket tmpstrcpy drop
;
\ used by client interface (instance-to-path)
: get-instance-path ( ihandle -- str len )
?dup 0= if 0 0 then
dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
\ dictionary abused for temporary storage
>r 0 0 here 40 +
begin r> dup >in.my-parent @ dup >r while
( path len tempbuf ihandle R: ihandle.parent )
dup >in.interposed @ 0= if
inodename rot tmpstrcat
" /" rot tmpstrcat
else
drop
then
repeat
r> 3drop
pocket tmpstrcpy drop
;
\ used by client interface (instance-to-interposed-path)
: get-instance-interposed-path ( ihandle -- str len )
?dup 0= if 0 0 then
dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
\ dictionary abused for temporary storage
>r 0 0 here 40 +
begin r> dup >in.my-parent @ dup >r while
( path len tempbuf ihandle R: ihandle.parent )
dup >r inodename rot tmpstrcat
r> >in.interposed @ if " /%" else " /" then
rot tmpstrcat
repeat
r> 3drop
pocket tmpstrcpy drop
;
: pwd ( -- )
?active-package get-package-path type
;
: ls ( -- )
cr
?active-package >dn.child @
begin dup while
dup . dup pnodename type cr
>dn.peer @
repeat
drop
;
\ -------------------------------------------
\ property printing
\ -------------------------------------------
: .p-string? ( data len -- true | data len false )
\ no trailing zero?
2dup + 1- c@ if 0 exit then
swap >r 0
\ count zeros and detect unprintable characters?
over 1- begin 1- dup 0>= while
dup r@ + c@
( len zerocnt n ch )
?dup 0= if
swap 1+ swap
else
dup 1b <= swap 80 >= or
if 2drop r> swap 0 exit then
then
repeat drop r> -rot
( data len zerocnt )
\ simple string
0= if
ascii " emit 1- type ascii " emit true exit
then
\ make sure there are no double zeros (except possibly at the end)
2dup over + swap
( data len end ptr )
begin 2dup <> while
dup c@ 0= if
2dup 1+ <> if 2drop false exit then
then
dup cstrlen 1+ +
repeat
2drop
." {"
0 -rot over + swap
\ multistring ( cnt end ptr )
begin 2dup <> while
rot dup if ." , " then 1+ -rot
dup cstrlen 2dup
ascii " emit type ascii " emit
1+ +
repeat
." }"
3drop true
;
: .p-int? ( data len -- 1 | data len 0 )
dup 4 <> if false exit then
decode-int -rot 2drop true swap
dup 0>= if . exit then
dup -ff < if u. exit then
.
;
: .p-bytes? ( data len -- 1 | data len 0 )
." -- " dup . ." : "
swap >r 0
begin 2dup > while
dup r@ + c@
( len n ch )
pocket tohexstr type ." "
1+
repeat
2drop r> drop 1
;
\ this function tries to heuristically determine the data format
: (.property) ( data len -- )
dup 0= if 2drop ." <empty>" exit then
.p-string? if exit then
.p-int? if exit then
.p-bytes? if exit then
2drop ." <unimplemented type>"
;
: .properties ( -- )
?active-package dup >r if
0 0
begin
r@ next-property
while
cr 2dup dup -rot type
begin ." " 1+ dup d# 26 >= until drop
2dup active-package get-package-property drop (.property)
repeat
then
r> drop
cr
;
\ 7.4.11 Device tree
: print-dev ( phandle -- phandle )
dup .
dup get-package-path type
dup " device_type" rot get-package-property if
cr
else
." (" decode-string type ." )" cr 2drop
then
;
: show-sub-devs ( subtree-phandle -- )
print-dev
>dn.child @
begin dup while
dup recurse
>dn.peer @
repeat
drop
;
: show-all-devs ( -- )
active-package
cr " /" find-device
?active-package show-sub-devs
active-package!
;
: show-devs ( "{device-specifier}<cr>" -- )
active-package
cr " /" find-device
linefeed parse find-device
?active-package show-sub-devs
active-package!
;
\ 7.4.11.3 Device probing
: probe-all ( -- )
;

51
forth/admin/help.fs Normal file
View File

@@ -0,0 +1,51 @@
\ tag: firmware help
\
\ this code implements IEEE 1275-1994 ch. 7.4.1
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
hex
: (help-generic)
." Enter 'help command-name' or 'help category-name' for more help" cr
." (Use ONLY the first word of a category description)" cr
." Examples: help select -or- help line" cr cr
." Categories:" cr
." boot (Load and execute a client program)" cr
." diag (Diagnostic routines)" cr
;
: (help-diag)
." test <device> Run the selftest method for specified device" cr
." test-all Execute test for all devices using selftest method" cr
;
: (help-boot)
." boot [<device-specifier>:<device-arguments>] [boot-arguments]" cr
." Examples:" cr
." boot Default boot (values specified in nvram variables)" cr
." boot disk1:a Boot from disk1 partition a" cr
." boot hd:1,\boot\vmlinuz root=/dev/hda1" cr
;
: help ( "{name}<cr>" -- )
\ Provide information for category or specific command.
linefeed parse cr
dup 0= if
(help-generic)
2drop
else
2dup " diag" rot min comp not if
(help-diag) 2drop exit
then
2dup " boot" rot min comp not if
(help-boot) 2drop exit
then
." No help available for " type cr
then
;

139
forth/admin/iocontrol.fs Normal file
View File

@@ -0,0 +1,139 @@
\ tag: stdin/stdout handling
\
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ 7.4.5 I/O control
variable stdout
variable stdin
: input ( dev-str dev-len -- )
2dup find-dev 0= if
." Input device " type ." not found." cr exit
then
" read" rot find-method 0= if
type ." has no read method." cr exit
then
drop
\ open stdin device
2dup open-dev ?dup 0= if
." Opening " type ." failed." cr exit
then
-rot 2drop
\ call install-abort if present
dup " install-abort" rot ['] $call-method catch if 3drop then
\ close old stdin
stdin @ ?dup if
dup " remove-abort" rot ['] $call-method catch if 3drop then
close-dev
then
stdin !
;
: output ( dev-str dev-len -- )
2dup find-dev 0= if
." Output device " type ." not found." cr exit
then
" write" rot find-method 0= if
type ." has no write method." cr exit
then
drop
\ open stdin device
2dup open-dev ?dup 0= if
." Opening " type ." failed." cr exit
then
-rot 2drop
\ close old stdout
stdout @ ?dup if close-dev then
stdout !
;
: io ( dev-str dev-len -- )
2dup input output
;
\ key?, key and emit implementation
variable io-char
variable io-out-char
: io-key? ( -- available? )
io-char @ -1 <> if true exit then
io-char 1 " read" stdin @ $call-method
1 =
;
: io-key ( -- key )
\ poll for key
begin io-key? until
io-char c@ -1 to io-char
;
: io-emit ( char -- )
io-out-char c!
io-out-char 1 " write" stdout @ $call-method drop
;
variable CONSOLE-IN-list
variable CONSOLE-OUT-list
: CONSOLE-IN-initializer ( xt -- )
CONSOLE-IN-list list-add ,
;
: CONSOLE-OUT-initializer ( xt -- )
CONSOLE-OUT-list list-add ,
;
: install-console ( -- )
\ create screen alias
" /aliases" find-package if
>r
" screen" find-package if drop else
\ bad (or missing) screen alias
0 " display" iterate-device-type ?dup if
( display-ph R: alias-ph )
get-package-path encode-string " screen" r@ (property)
then
then
r> drop
then
output-device output
input-device input
\ let arch determine a useful output device
CONSOLE-OUT-list begin list-get while
stdout @ if drop else @ execute then
repeat
\ let arch determine a useful input device
CONSOLE-IN-list begin list-get while
stdin @ if drop else @ execute then
repeat
\ activate console
stdout @ if
['] io-emit to emit
then
stdin @ if
-1 to io-char
['] io-key? to key?
['] io-key to key
then
;
:noname
" screen" output
; CONSOLE-OUT-initializer

354
forth/admin/nvram.fs Normal file
View File

@@ -0,0 +1,354 @@
\ tag: nvram config handling
\
\ this code implements IEEE 1275-1994
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
struct ( config )
2 cells field >cf.name
2 cells field >cf.default \ 0 -1 if no default
/n field >cf.check-xt
/n field >cf.exec-xt
/n field >cf.next
constant config-info.size
0 value config-root
\ --------------------------------------------------------
\ config handling
\ --------------------------------------------------------
: find-config ( name-str len -- 0|configptr )
config-root
begin ?dup while
-rot
2dup 4 pick >cf.name 2@
strcmp 0= if
2drop exit
then
rot >cf.next @
repeat
2drop 0
;
: is-config-word ( configp -- )
dup >cf.name 2@ $create ,
does> @
dup >cf.name 2@
" /options" find-dev if
get-package-property if 0 -1 then
( configp prop-str prop-len )
\ drop trailing zero
?dup if 1- then
else
2drop 0 -1
then
\ use default value if property is missing
dup 0< if 2drop dup >cf.default 2@ then
\ no default value, use empty string
dup 0< if 2drop 0 0 then
rot >cf.exec-xt @ execute
;
: new-config ( name-str name-len -- configp )
2dup find-config ?dup if
nip nip
0 0 2 pick >cf.default 2!
else
dict-strdup
here config-info.size allot
dup config-info.size 0 fill
config-root over >cf.next !
dup to config-root
dup >r >cf.name 2! r>
dup is-config-word
then
( configp )
;
: config-default ( str len configp -- )
-rot
dup 0> if dict-strdup then
rot >cf.default 2!
;
: no-conf-def ( configp -- )
0 -1
;
\ --------------------------------------------------------
\ config types
\ --------------------------------------------------------
: exec-str-conf ( str len -- str len )
\ trivial
;
: check-str-conf ( str len -- str len valid? )
\ nothing
true
;
: str-config ( def-str len name len -- configp )
new-config >r
['] exec-str-conf r@ >cf.exec-xt !
['] check-str-conf r@ >cf.check-xt !
r> config-default
;
\ ------------------------------------------------------------
: exec-int-conf ( str len -- value )
\ fixme
parse-hex
;
: check-int-conf ( str len -- str len valid? )
true
;
: int-config ( def-str len name len -- configp )
new-config >r
['] exec-int-conf r@ >cf.exec-xt !
['] check-int-conf r@ >cf.check-xt !
r> config-default
;
\ ------------------------------------------------------------
: exec-secmode-conf ( str len -- n )
2dup " command" strcmp 0= if 2drop 1 exit then
2dup " full" strcmp 0= if 2drop 2 exit then
2drop 0
;
: check-secmode-conf ( str len -- str len valid? )
2dup " none" strcmp 0= if true exit then
2dup " command" strcmp 0= if true exit then
2dup " full" strcmp 0= if true exit then
false
;
: secmode-config ( def-str len name len -- configp )
new-config >r
['] exec-secmode-conf r@ >cf.exec-xt !
['] check-secmode-conf r@ >cf.check-xt !
r> config-default
;
\ ------------------------------------------------------------
: exec-bool-conf ( str len -- value )
2dup " true" strcmp 0= if 2drop true exit then
2dup " false" strcmp 0= if 2drop false exit then
2dup " TRUE" strcmp 0= if 2drop false exit then
2dup " FALSE" strcmp 0= if 2drop false exit then
parse-hex 0<>
;
: check-bool-conf ( name len -- str len valid? )
2dup " true" strcmp 0= if true exit then
2dup " false" strcmp 0= if true exit then
2dup " TRUE" strcmp 0= if 2drop " true" true exit then
2dup " FALSE" strcmp 0= if 2drop " false" true exit then
false
;
: bool-config ( configp -- configp )
new-config >r
['] exec-bool-conf r@ >cf.exec-xt !
['] check-bool-conf r@ >cf.check-xt !
r> config-default
;
\ --------------------------------------------------------
\ 7.4.4 Nonvolatile memory
\ --------------------------------------------------------
: $setenv ( data-addr data-len name-str name-len -- )
2dup find-config ?dup if
>r 2swap r>
( name len data len configptr )
>cf.check-xt @ execute
0= abort" Invalid value."
2swap
else
\ create string config type
2dup no-conf-def 2swap str-config
then
2swap encode-string 2swap
" /options" find-package drop
encode-property
;
: setenv ( "nv-param< >new-value<eol>" -- )
parse-word
\ XXX drop blanks
dup if linefeed parse else 0 0 then
dup 0= abort" Invalid value."
2swap $setenv
;
: printenv ( "{param-name}<eol>" -- )
\ XXX temporary implementation
linefeed parse 2drop
active-package
" /options" find-device
.properties
active-package!
;
: (set-default) ( configptr -- )
dup >cf.default 2@ dup 0>= if
rot >cf.name 2@ $setenv
else
\ no default value
3drop
then
;
: set-default ( "param-name<eol>" -- )
linefeed parse
find-config ?dup if
(set-default)
else
." No such parameter." -2 throw
then
;
: set-defaults ( -- )
config-root
begin ?dup while
dup (set-default)
>cf.next @
repeat
;
( maxlen "new-name< >" -- ) ( E: -- addr len )
: nodefault-bytes
;
\ --------------------------------------------------------
\ initialize config from nvram
\ --------------------------------------------------------
\ CHRP format (array of null-terminated strings, "variable=value")
: nvram-load-configs ( data len -- )
\ XXX: no len checking performed...
drop
begin dup c@ while
( data )
dup cstrlen 2dup + 1+ -rot
( next str len )
ascii = left-split ( next val len name str )
['] $setenv catch if
2drop 2drop
then
repeat drop
;
: (nvram-store-one) ( buf len str len -- buf len success? )
swap >r
2dup < if r> 2drop 2drop false exit then
( buf len strlen R: str )
swap over - r> swap >r -rot
( str buf strlen R: res_len )
2dup + >r move r> r> true
;
: (make-configstr) ( configptr ph -- str len )
>r
>cf.name 2@
2dup r> get-package-property if
2drop 0 0 exit
else
dup if 1- then
then
( name len value-str len )
2swap " =" 2swap
pocket tmpstrcat tmpstrcat drop
2dup + 0 swap c!
1+
;
: nvram-store-configs ( data len -- )
2 - \ make room for two trailing zeros
" /options" find-dev 0= if 2drop exit then
>r
config-root
( data len configptr R: phandle )
begin ?dup while
r@ over >r (make-configstr)
( buf len val len R: configptr phandle )
(nvram-store-one) drop
r> >cf.next @
repeat
\ null terminate
2 + 0 fill
r> drop
;
\ --------------------------------------------------------
\ NVRAM variables
\ --------------------------------------------------------
\ fcode-debug? input-device output-device
" true" " auto-boot?" bool-config \ 7.4.3.5
" boot" " boot-command" str-config \ 7.4.3.5
" disk" " boot-device" str-config \ 7.4.3.5
" " " boot-file" str-config \ 7.4.3.5
" false" " diag-switch?" bool-config \ 7.4.3.5
" net" " diag-device" str-config \ 7.4.3.5
" diag" " diag-file" str-config \ 7.4.3.5
" false" " fcode-debug?" bool-config \ 7.7
" " " nvramrc" str-config \ 7.4.4.2
" false" " oem-banner?" bool-config
" " " oem-banner" str-config
" false" " oem-logo?" bool-config
no-conf-def " oem-logo" str-config
" false" " use-nvramrc?" bool-config \ 7.4.4.2
" keyboard" " input-device" str-config \ 7.4.5
" screen" " output-device" str-config \ 7.4.5
" 80" " screen-#columns" int-config \ 7.4.5
" 24" " screen-#rows" int-config \ 7.4.5
" 0" " selftest-#megs" int-config
no-conf-def " security-mode" secmode-config
\ --- devices ---
" -1" " pci-probe-mask" int-config
" false" " default-mac-address" bool-config
" false" " skip-netboot?" bool-config
" true" " scroll-lock" bool-config
[IFDEF] CONFIG_PPC
\ ---- PPC ----
" false" " little-endian?" bool-config
" false" " real-mode?" bool-config
" -1" " real-base" int-config
" -1" " real-size" int-config
" 0x800000" " load-base" int-config
" -1" " virt-base" int-config
" -1" " virt-size" int-config
[THEN]
[IFDEF] CONFIG_X86
\ ---- X86 ----
" true" " little-endian?" bool-config
[THEN]
\ --- ??? ---
" " " boot-screen" str-config
" " " boot-script" str-config
" false" " use-generic?" bool-config
" " " boot-args" str-config \ ???
\ defers
['] fcode-debug? to _fcode-debug?

5
forth/admin/reset.fs Normal file
View File

@@ -0,0 +1,5 @@
\ 7.4.7 Reset
: reset-all ( -- )
;

17
forth/admin/script.fs Normal file
View File

@@ -0,0 +1,17 @@
\ 7.4.4.2 The script
: nvedit ( -- )
;
: nvstore ( -- )
;
: nvquit ( -- )
;
: nvrecover ( -- )
;
: nvrun ( -- )
;

11
forth/admin/security.fs Normal file
View File

@@ -0,0 +1,11 @@
\ 7.4.6 Security
: password ( -- )
;
: security-password ( -- password-str password-len )
;
: security-#badlogins ( -- n )
;

50
forth/admin/selftest.fs Normal file
View File

@@ -0,0 +1,50 @@
\ tag: self-test
\
\ this code implements IEEE 1275-1994 ch. 7.4.8
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ 7.4.8 Self-test
\
: $test ( devname-addr devname-len -- )
2dup ." Testing device " type ." : "
find-dev if
s" self-test" rot find-method if
execute
else
." no self-test method."
then
else
." no such device."
then
cr
;
: test ( "device-specifier<cr>"-- )
linefeed parse cr $test
;
: test-sub-devs
>dn.child @
begin dup while
dup get-package-path $test
dup recurse
>dn.peer @
repeat
drop
;
: test-all ( "{device-specifier}<cr>" -- )
active-package
cr " /" find-device
linefeed parse find-device
?active-package test-sub-devs
active-package!
;

20
forth/admin/userboot.fs Normal file
View File

@@ -0,0 +1,20 @@
\ 7.4.3.5 User commands for booting
: boot ( "{param-text}<cr>" -- )
linefeed parse cr
s" platform-boot" $find if
execute
else
2drop
cr ." Booting " type cr
." ... not supported on this system." cr
then
;
\ : diagnostic-mode? ( -- diag? )
\ ;
\ : diag-switch? ( -- diag? )
\ ;

1500
forth/bootstrap/bootstrap.fs Normal file
View File

File diff suppressed because it is too large Load Diff

16
forth/bootstrap/build.xml Normal file
View File

@@ -0,0 +1,16 @@
<build>
<!--
build description for openbios forth bootstrap
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="bootstrap">
<object source="start.fs" target="forth"/>
</dictionary>
<dictionary name="openbios" init="bootstrap"/>
</build>

30
forth/bootstrap/builtin.fs Normal file
View File

@@ -0,0 +1,30 @@
\ tag: initialize builtin functionality
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
: init-builtin-terminal ( -- )
\ define key, key? and emit
['] (key) ['] key (to)
['] (key?) ['] key? (to)
['] (emit) ['] emit (to)
\ 2 bytes band guard on each side
100 #ib !
#ib @ dup ( -- ibs ibs )
cell+ alloc-mem ( -- ibs addr )
dup -rot ( -- addr ibs addr )
/w + ['] ib (to) \ assign input buffer
0 fill \ erase tib
0 ['] source-id (to) \ builtin terminal has id 0
;

1064
forth/bootstrap/hayes.fs Normal file
View File

File diff suppressed because it is too large Load Diff

174
forth/bootstrap/interpreter.fs Normal file
View File

@@ -0,0 +1,174 @@
\ tag: forth interpreter
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ 7.3.4.6 Display pause
\
0 value interactive?
: exit?
interactive? 0= if
false exit
then
false \ FIXME we should check whether to interrupt output
\ and ask the user how to proceed.
;
\
\ 7.3.9.1 Defining words
\
: forget
s" This word is obsolescent." type cr
['] ' execute
cell - dup
@ dup
last ! latest !
here!
;
\
\ 7.3.9.2.4 Miscellaneous dictionary
\
\ interpreter. This word checks whether the interpreted word
\ is a word in dictionary or a number. It honours compile mode
\ and immediate/compile-only words.
: interpret
0 >in !
begin
parse-word dup 0> \ was there a word at all?
while
$find
if
dup flags? 0<> state @ 0= or if
execute
else
, \ compile mode && !immediate
then
else \ word is not known. maybe it's a number
2dup $number
if
span @ >in ! \ if we encountered an error, don't continue parsing
type 3a emit
-13 throw
else
-rot 2drop 1 handle-lit
then
then
depth 200 >= if -3 throw then
depth 0< if -4 throw then
rdepth 200 >= if -5 throw then
rdepth 0< if -6 throw then
repeat
2drop
;
: refill ( -- )
ib #ib @ expect 0 >in ! ;
: print-status ( exception -- )
space
?dup if
dup sys-debug \ system debug hook
case
-1 of s" Aborted." type endof
-2 of s" Aborted." type endof
-3 of s" Stack Overflow." type 0 depth! endof
-4 of s" Stack Underflow." type 0 depth! endof
-5 of s" Return Stack Overflow." type endof
-6 of s" Return Stack Underflow." type endof
-13 of s" undefined word." type endof
-15 of s" out of memory." type endof
-21 of s" undefined method." type endof
-22 of s" no such device." type endof
dup s" Exception #" type .
endcase
else
state @ 0= if
s" ok"
else
s" compiled"
then
type
then
cr
;
defer status
['] noop ['] status (to)
: print-prompt
status
depth . 3e emit space
;
defer outer-interpreter
:noname
cr
begin
print-prompt
source 0 fill \ clean input buffer
refill
['] interpret catch print-status
again
; ['] outer-interpreter (to)
\
\ 7.3.8.5 Other control flow commands
\
: save-source ( -- )
r> \ fetch our caller
ib >r #ib @ >r \ save current input buffer
source-id >r \ and all variables
span @ >r \ associated with it.
>in @ >r
>r \ move back our caller
;
: restore-source ( -- )
r>
r> >in !
r> span !
r> ['] source-id (to)
r> #ib !
r> ['] ib (to)
>r
;
: (evaluate) ( str len -- ??? )
save-source
-1 ['] source-id (to)
dup
#ib ! span !
['] ib (to)
interpret
restore-source
;
: evaluate ( str len -- ?? )
2dup + -rot
over + over do
i c@ 0a = if
i over -
(evaluate)
i 1+
then
loop
swap over - (evaluate)
;
: eval evaluate ;

218
forth/bootstrap/memory.fs Normal file
View File

@@ -0,0 +1,218 @@
\ tag: forth memory allocation
\
\ Copyright (C) 2002-2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ 7.3.3.2 memory allocation
\ these need to be initialized by the forth kernel by now.
variable start-mem 0 start-mem ! \ start of memory
variable end-mem 0 end-mem ! \ end of memory
variable free-list 0 free-list ! \ free list head
\ initialize necessary variables and write a valid
\ free-list entry containing all of the memory.
\ start-mem: pointer to start of memory.
\ end-mem: pointer to end of memory.
\ free-list: head of linked free list
: init-mem ( start-addr size )
over dup
start-mem ! \ write start-mem
free-list ! \ write first freelist entry
2dup /n - swap ! \ write 'len' entry
over cell+ 0 swap ! \ write 'next' entry
+ end-mem ! \ write end-mem
;
\ --------------------------------------------------------------------
\ return pointer to smallest free block that contains
\ at least nb bytes and the block previous the the
\ actual block. On failure the pointer to the smallest
\ free block is 0.
: smallest-free-block ( nb -- prev ptr | 0 0 )
0 free-list @
fffffff 0 0 >r >r >r
begin
dup
while
( nb prev pp R: best_nb best_pp )
dup @ 3 pick r@ within if
( nb prev pp )
r> r> r> 3drop \ drop old smallest
2dup >r >r dup @ >r \ new smallest
then
nip dup \ prev = pp
cell + @ \ pp = pp->next
repeat
3drop r> drop r> r>
;
\ --------------------------------------------------------------------
\ allocate size bytes of memory
\ return pointer to memory (or throws an exception on failure).
: alloc-mem ( size -- addr )
\ make it legal (and fast) to allocate 0 bytes
dup 0= if exit then
aligned \ keep memory aligned.
dup smallest-free-block \ look up smallest free block.
dup 0= if
\ 2drop
-15 throw \ out of memory
then
( al-size prev addr )
\ If the smallest fitting block found is bigger than
\ the size of the requested block plus 2*cellsize we
\ can split the block in 2 parts. otherwise return a
\ slightly bigger block than requested.
dup @ ( d->len ) 3 pick cell+ cell+ > if
\ splitting the block in 2 pieces.
\ new block = old block + len field + size of requested mem
dup 3 pick cell+ + ( al-size prev addr nd )
\ new block len = old block len - req. mem size - 1 cell
over @ ( al-size prev addr nd addr->len )
4 pick ( ... al-size )
cell+ - ( al-size prev addr nd nd nd->len )
over ! ( al-size prev addr nd )
over cell+ @ ( al-size prev addr nd addr->next )
\ write addr->next to nd->next
over cell+ ! ( al-size prev addr nd )
over 4 pick swap !
else
\ don't split the block, it's too small.
dup cell+ @
then
( al-size prev addr nd )
\ If the free block we got is the first one rewrite free-list
\ pointer instead of the previous entry's next field.
rot dup 0= if drop free-list else cell+ then
( al-size addr nd prev->next|fl )
!
nip cell+ \ remove al-size and skip len field of returned pointer
;
\ --------------------------------------------------------------------
\ free block given by addr. The length of the
\ given block is stored at addr - cellsize.
\
\ merge with blocks to the left and right
\ immediately, if they are free.
: free-mem ( addr len -- )
\ we define that it is legal to free 0-byte areas
0= if drop exit then
( addr )
\ check if the address to free is somewhere within
\ our available memory. This fails badly on discontigmem
\ architectures. If we need more RAM than fits on one
\ contiguous memory area we are too bloated anyways. ;)
dup start-mem @ end-mem @ within 0= if
\ ." free-mem: no such memory: 0x" u. cr
exit
then
/n - \ get real block address
0 free-list @ ( addr prev l )
begin \ now scan the free list
dup 0<> if \ only check len, if block ptr != 0
dup dup @ cell+ + 3 pick <
else
false
then
while
nip dup \ prev=l
cell+ @ \ l=l->next
repeat
( addr prev l )
dup 0<> if \ do we have free memory to merge with?
dup dup @ cell+ + 3 pick = if \ hole hit. adding bytes.
\ freeaddr = end of current block -> merge
( addr prev l )
rot @ cell+ ( prev l f->len+cellsize )
over @ + \ add l->len
over ! ( prev l )
swap over cell+ @ \ f = l; l = l->next;
\ The free list is sorted by addresses. When merging at the
\ start of our block we might also want to merge at the end
\ of it. Therefore we fall through to the next border check
\ instead of returning.
true \ fallthrough value
else
false \ no fallthrough
then
>r \ store fallthrough on ret stack
( addr prev l )
dup 3 pick dup @ cell+ + = if \ hole hit. real merging.
\ current block starts where block to free ends.
\ end of free block addr = current block -> merge and exit
( addr prev l )
2 pick dup @ ( f f->len )
2 pick @ cell+ + ( f newlen )
swap ! ( addr prev l )
3dup drop
0= if
free-list
else
2 pick cell+
then ( value prev->next|free-list )
! ( addr prev l )
cell+ @ rot ( prev l->next addr )
cell+ ! drop
r> drop exit \ clean up return stack
then
r> if 3drop exit then \ fallthrough? -> exit
then
\ loose block - hang it before current.
( addr prev l )
\ hang block to free in front of the current entry.
dup 3 pick cell+ ! \ f->next = l;
free-list @ = if \ is block to free new list head?
over free-list !
then
( addr prev )
dup 0<> if \ if (prev) prev->next=f
cell+ !
else
2drop \ no fixup needed. clean up.
then
;

69
forth/bootstrap/start.fs Normal file
View File

@@ -0,0 +1,69 @@
\ tag: forth bootstrap starter.
\
\ Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
include bootstrap.fs \ all base words
include interpreter.fs \ interpreter
include builtin.fs \ builtin terminal.
: include ( >filename<eol> -- )
linefeed parse $include
;
: encode-file ( >filename< > -- dictptr size )
parse-word $encode-file
;
: bye
s" Farewell!" cr type cr cr
0 rdepth!
;
\ quit starts the outer interpreter of the forth system.
\ zech describes quit as being the outer interpreter, but
\ we split it apart to keep the interpreter elsewhere.
: quit ( -- )
2 rdepth!
outer-interpreter
;
\ initialize is the first forth word run by the kernel.
\ this word is automatically executed by the C core on start
\ and it's never left unless something goes really wrong or
\ the user decides to leave the engine.
variable init-chain
\ :noname <definition> ; initializer
: initializer ( xt -- )
here swap , 0 , \ xt, next
init-chain
begin dup @ while @ na1+ repeat
!
;
: initialize-forth ( startmem endmem -- )
over - init-mem
init-pockets
init-tmp-comp
init-builtin-terminal
init-chain @ \ execute initializers
begin dup while
dup @ execute
na1+ @
repeat
drop
;
\ compiler entrypoint
: initialize ( startmem endmem -- )
initialize-forth
s" OpenBIOS kernel started." type cr
quit
;

14
forth/build.xml Normal file
View File

@@ -0,0 +1,14 @@
<?xml version="1.0" ?>
<build>
<!-- don't change this order -->
<include href="bootstrap/build.xml"/>
<include href="lib/build.xml"/>
<include href="device/build.xml"/>
<include href="debugging/build.xml"/>
<include href="admin/build.xml"/>
<include href="util/build.xml"/>
<include href="packages/build.xml"/>
<include href="system/build.xml"/>
</build>

18
forth/debugging/build.xml Normal file
View File

@@ -0,0 +1,18 @@
<build>
<!--
build description for forth debugging command group
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="client.fs"/>
<object source="fcode.fs"/>
<object source="firmware.fs"/>
<object source="see.fs"/>
</dictionary>
</build>

111
forth/debugging/client.fs Normal file
View File

@@ -0,0 +1,111 @@
\ 7.6 Client Program Debugging command group
\ 7.6.1 Registers display
: ctrace ( -- )
;
: .registers ( -- )
;
: .fregisters ( -- )
;
\ to ( param [old-name< >] -- )
\ 7.6.2 Program download and execute
: load ( "{params}<cr>" -- )
;
: go ( -- )
;
: state-valid ( -- a-addr )
;
: init-program ( -- )
;
\ 7.6.3 Abort and resume
\ already defined !?
\ : go ( -- )
\ ;
\ 7.6.4 Disassembler
: dis ( addr -- )
;
: +dis ( -- )
;
\ 7.6.5 Breakpoints
: .bp ( -- )
;
: +bp ( addr -- )
;
: -bp ( addr -- )
;
: --bp ( -- )
;
: bpoff ( -- )
;
: step ( -- )
;
: steps ( n -- )
;
: hop ( -- )
;
: hops ( n -- )
;
\ already defined
\ : go ( -- )
\ ;
: gos ( n -- )
;
: till ( addr -- )
;
: return ( -- )
;
: .breakpoint ( -- )
;
: .step ( -- )
;
: .instruction ( -- )
;
\ 7.6.6 Symbolic debugging
: .adr ( addr -- )
;
: sym ( "name< >" -- n )
;
: sym>value ( addr len -- addr len false | n true )
;
: value>sym ( n1 -- n1 false | n2 addr len true )
;

31
forth/debugging/fcode.fs Normal file
View File

@@ -0,0 +1,31 @@
\ 7.7 FCode Debugging command group
\ The user interface versions of these FCode functions allow
\ the user to debug FCode programs by providing named commands
\ corresponding to FCode functions.
: headerless ( -- )
;
: headers ( -- )
;
: begin-package ( arg-str arg-len reg-str reg-len dev-str dev-len -- )
open-dev dup 0= abort" failed opening parent."
dup to my-self
ihandle>phandle active-package!
new-device
set-args
;
: end-package ( -- )
my-parent >r
finish-device
0 active-package!
0 to my-self
r> close-dev
;
: apply ( ... "method-name< >device-specifier< >" -- ??? )
;

83
forth/debugging/firmware.fs Normal file
View File

@@ -0,0 +1,83 @@
\ 7.5 Firmware Debugging command group
\ 7.5.1 Automatic stack display
: (.s
depth 0 ?do
depth i - 1- pick .
loop
depth 0<> if ascii < emit space then
;
: showstack ( -- )
['] (.s to status
;
: noshowstack ( -- )
['] noop to status
;
\ 7.5.2 Serial download
: dl ( -- )
;
\ 7.5.3 Dictionary
\ 7.5.3.1 Dictionary search
: .calls ( xt -- )
;
: $sift ( text-addr text-len -- )
;
: sifting ( "text< >" -- )
;
\ : words ( -- )
\ \ Implemented in forth bootstrap.
\ ;
\ 7.5.3.2 Decompiler
\ implemented in see.fs
\ : see ( "old-name< >" -- )
\ ;
\ : (see) ( xt -- )
\ ;
\ 7.5.3.3 Patch
: patch ( "new-name< >old-name< >word-to-patch< >" -- )
;
: (patch) ( new-n1 num1? old-n2 num2? xt -- )
;
\ 7.5.3.4 Forth source-level debugger
: debug ( "old-name< >" -- )
;
: (debug ( xt -- )
;
: stepping ( -- )
;
: tracing ( -- )
;
: debug-off ( -- )
;
: resume ( -- )
;

114
forth/debugging/see.fs Normal file
View File

@@ -0,0 +1,114 @@
\ tag: Forth Decompiler
\
\ this code implements IEEE 1275-1994 ch. 7.5.3.2
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
1 value (see-indent)
: (see-cr)
cr (see-indent) spaces
;
: indent+
(see-indent) 2+ to (see-indent)
;
: indent-
(see-indent) 2- to (see-indent)
;
: (see-colon)
dup ." : " cell - lfa2name type (see-cr)
begin
cell+ dup @ dup ['] (semis) <>
while
space
dup
case
['] do?branch of
." if" (see-cr) indent+
drop cell+
endof
['] dobranch of
." then" indent- (see-cr)
drop cell+
endof
['] (begin) of
." begin" indent+ (see-cr)
drop
endof
['] (again) of
." again" (see-cr)
drop
endof
['] (until) of
." until" (see-cr)
drop
endof
['] (while) of
indent- (see-cr)
." while"
indent+ (see-cr)
drop 2 cells +
endof
['] (repeat) of
indent- (see-cr)
." repeat"
(see-cr)
drop 2 cells +
endof
['] (lit) of
." (lit)"
drop 1 cells +
endof
['] (") of
22 emit space drop dup cell+ @
2dup swap 2 cells + swap type
22 emit
+ aligned cell+
endof
cell - lfa2name type
endcase
repeat
cr ." ;"
2drop
;
: (see) ( xt -- )
cr
dup @ case
1 of
(see-colon)
endof
3 of
." constant " dup cell - lfa2name type ." = " execute .
endof
4 of
." variable " dup cell - lfa2name type ." = " execute @ .
endof
5 of
." defer " dup cell - lfa2name type cr
." is " cell+ @ cell - lfa2name type cr
endof
." primword " swap cell - lfa2name type
endcase
cr
;
: see ' (see) ;

23
forth/device/README.device Normal file
View File

@@ -0,0 +1,23 @@
The code you find here implements the IEEE 1275-1994 Open Firmware
device interface.
Chapter File Comment
<none> structures.fs generic structures used by 5.3
5.3.2 <none> defined in user interface
5.3.3 fcode.fs complete, partly untested
5.3.4 package.fs incomplete
5.3.5 property.fs incomplete
5.3.6 display.fs incomplete
5.3.7 other.fs incomplete
H2 and
5.3.1.1.1 preof.fs pre-IEEE-1275-1994 words
split.fs
pathres.fs path resolution
table.fs fcode evaluator
feval.fs (byte-load)
2003/11/12 Stefan Reinauer <stepan@openbios.org>

31
forth/device/build.xml Normal file
View File

@@ -0,0 +1,31 @@
<build>
<!--
build description for open firmware device interface
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="structures.fs"/>
<object source="fcode.fs"/>
<object source="property.fs"/>
<object source="device.fs"/>
<object source="package.fs"/>
<object source="other.fs"/>
<object source="pathres.fs"/>
<object source="preof.fs"/>
<object source="font.fs"/>
<object source="logo.fs"/>
<object source="display.fs"/>
<object source="terminal.fs"/>
<object source="extra.fs"/>
<object source="feval.fs"/>
<object source="table.fs"/>
<object source="tree.fs"/>
<object source="builtin.fs"/>
</dictionary>
</build>

32
forth/device/builtin.fs Normal file
View File

@@ -0,0 +1,32 @@
\ tag: builtin devices
\
\ this code implements IEEE 1275-1994
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ nodes it's children:
" /" find-device
new-device
" builtin" device-name
external
: open true ;
: close ;
new-device
" console" device-name
external
: open true ;
: close ;
: write dup >r bounds ?do i c@ (emit) loop r> ;
: read dup >r bounds ?do (key) i c! loop r> ;
finish-device
\ clean up afterwards
finish-device
0 active-package!

191
forth/device/device.fs Normal file
View File

@@ -0,0 +1,191 @@
\ tag: Package creation and deletion
\
\ this code implements IEEE 1275-1994
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
variable device-tree
\ make defined words globally visible
\
: external ( -- )
active-package ?dup if
>dn.methods @ set-current
then
;
\ make the private wordlist active (not an OF word)
\
: private ( -- )
active-package ?dup if
>r
forth-wordlist r@ >dn.methods @ r@ >dn.priv-methods @ 3 set-order
r> >dn.priv-methods @ set-current
then
;
\ set activate package and make the world visible package wordlist
\ the current one.
\
: active-package! ( phandle -- )
dup to active-package
\ locally defined words are not available
?dup if
forth-wordlist over >dn.methods @ 2 set-order
>dn.methods @ set-current
else
forth-wordlist dup 1 set-order set-current
then
;
\ new-device ( -- )
\
\ Start new package, as child of active package.
\ Create a new device node as a child of the active package and make the
\ new node the active package. Create a new instance and make it the current
\ instance; the instance that invoked new-device becomes the parent instance
\ of the new instance.
\ Subsequently, newly defined Forth words become the methods of the new node
\ and newly defined data items (such as types variable, value, buffer:, and
\ defer) are allocated and stored within the new instance.
: new-device ( -- )
align-tree dev-node.size alloc-tree >r
active-package
dup r@ >dn.parent !
\ ( parent ) hook up at the end of the peer list
?dup if
>dn.child
begin dup @ while @ >dn.peer repeat
r@ swap !
else
\ we are the root node!
r@ to device-tree
then
\ ( -- ) fill in device node stuff
inst-node.size r@ >dn.isize !
\ create two wordlists
wordlist r@ >dn.methods !
wordlist r@ >dn.priv-methods !
\ initialize template data
r@ >dn.itemplate
r@ over >in.device-node !
my-self over >in.my-parent !
\ make it the active package and current instance
to my-self
r@ active-package!
\ swtich to private wordlist
private
r> drop
;
\ helpers for finish-device (OF does not actually define words
\ for device node deletion)
: (delete-device) \ ( phandle )
>r
r@ >dn.parent @
?dup if
>dn.child \ ( &first-child )
begin dup @ r@ <> while @ >dn.peer repeat
r@ >dn.peer @ swap !
else
\ root node
0 to device-tree
then
\ XXX: free any memory related to this node.
\ we could have a list with free device-node headers...
r> drop
;
: delete-device \ ( phandle )
>r
\ first, get rid of any children
begin r@ >dn.child @ dup while
(delete-device)
repeat
drop
\ then free this node
r> (delete-device)
;
\ finish-device ( -- )
\
\ Finish this package, set active package to parent.
\ Complete a device node that was created by new-device, as follows: If the
\ device node has no "name" property, remove the device node from the device
\ tree. Otherwise, save the current values of the current instance's
\ initialized data items within the active package for later use in
\ initializing the data items of instances created from that node. In any
\ case, destroy the current instance, make its parent instance the current
\ instance, and select the parent node of the device node just completed,
\ making the parent node the active package again.
: finish-device \ ( -- )
my-self
dup >in.device-node @ >r
>in.my-parent @ to my-self
( -- )
r@ >dn.parent @ active-package!
s" name" r@ get-package-property if
\ delete the node (and any children)
r@ delete-device
else
2drop
\ node OK
then
r> drop
;
\ helper function which creates and initializes an instance.
\ open is not called. The current instance is not changed.
\
: create-instance ( phandle -- ihandle|0 )
dup >dn.isize @ ['] alloc-mem catch if 2drop 0 exit then
>r
\ we need to save the size in order to be able to release it properly
dup >dn.isize @ r@ >in.alloced-size !
\ clear memory (we only need to clear the head; all other data is copied)
r@ inst-node.size 0 fill
( phandle R: ihandle )
\ instantiate data
dup >dn.methods @ r@ instance-init
dup >dn.priv-methods @ r@ instance-init
\ instantiate
dup >dn.itemplate r@ inst-node.size move
r@ r@ >in.instance-data !
my-self r@ >in.my-parent !
drop
r>
;
\ helper function which tears down and frees an instance
: destroy-instance ( ihandle )
?dup if
\ free arguments
dup >in.arguments 2@ free-mem
\ and the instance block
dup >in.alloced-size @
free-mem
then
;

367
forth/device/display.fs Normal file
View File

@@ -0,0 +1,367 @@
\ tag: Display device management
\
\ this code implements IEEE 1275-1994 ch. 5.3.6
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
hex
\
\ 5.3.6.1 Terminal emulator routines
\
\ The following values are used and set by the terminal emulator
\ defined and described in 3.8.4.2
0 value line# ( -- line# )
0 value column# ( -- column# )
0 value inverse? ( -- white-on-black? )
0 value inverse-screen? ( -- black? )
0 value #lines ( -- rows )
0 value #columns ( -- columns )
\ The following values are used internally by both the 1-bit and the
\ 8-bit frame-buffer support routines.
0 value frame-buffer-adr ( -- addr )
0 value screen-height ( -- height )
0 value screen-width ( -- width )
0 value window-top ( -- border-height )
0 value window-left ( -- border-width )
0 value char-height ( -- height )
0 value char-width ( -- width )
0 value fontbytes ( -- bytes )
\ these values are used internally and do not represent any
\ official open firmware words
0 value char-min
0 value char-num
0 value font
0 value foreground-color
0 value background-color
\ The following wordset is called the "defer word interface" of the
\ terminal-emulator support package. It gets overloaded by fb1-install
\ or fb8-install (initiated by the framebuffer fcode driver)
defer draw-character ( char -- )
defer reset-screen ( -- )
defer toggle-cursor ( -- )
defer erase-screen ( -- )
defer blink-screen ( -- )
defer invert-screen ( -- )
defer insert-characters ( n -- )
defer delete-characters ( n -- )
defer insert-lines ( n -- )
defer delete-lines ( n -- )
defer draw-logo ( line# addr width height -- )
defer fb-emit ( x -- )
\
\ 5.3.6.2 Frame-buffer support routines
\
: default-font ( -- addr width height advance min-char #glyphs )
(romfont-8x16) 8 10 10 0 100
;
: set-font ( addr width height advance min-char #glyphs -- )
to char-num
to char-min
to fontbytes
to char-height
to char-width
to font
;
: >font ( char -- addr )
char-min -
char-num min
fontbytes *
font +
;
\
\ 5.3.6.3 Display device support
\
\
\ 5.3.6.3.1 Frame-buffer package interface
\
: is-install ( xt -- )
external
\ Create open and other methods for this display device.
\ Methods to be created: open, write, draw-logo, restore
s" open" header
1 , \ colon definition
,
['] (semis) ,
reveal
s" : write dup >r bounds do i c@ fb-emit loop r> ; " evaluate
s" : draw-logo draw-logo ; " evaluate
s" : restore reset-screen ; " evaluate
;
: is-remove ( xt -- )
external
\ Create close method for this display device.
s" close" header
1 , \ colon definition
,
['] (semis) ,
reveal
;
: is-selftest ( xt -- )
external
\ Create selftest method for this display device.
s" selftest" header
1 , \ colon definition
,
['] (semis) ,
reveal
;
\ 5.3.6.3.2 Generic one-bit frame-buffer support (optional)
: fb1-nonimplemented
." Monochrome framebuffer support is not implemented." cr
end0
;
: fb1-draw-character fb1-nonimplemented ; \ historical
: fb1-reset-screen fb1-nonimplemented ;
: fb1-toggle-cursor fb1-nonimplemented ;
: fb1-erase-screen fb1-nonimplemented ;
: fb1-blink-screen fb1-nonimplemented ;
: fb1-invert-screen fb1-nonimplemented ;
: fb1-insert-characters fb1-nonimplemented ;
: fb1-delete-characters fb1-nonimplemented ;
: fb1-insert-lines fb1-nonimplemented ;
: fb1-delete-lines fb1-nonimplemented ;
: fb1-slide-up fb1-nonimplemented ;
: fb1-draw-logo fb1-nonimplemented ;
: fb1-install fb1-nonimplemented ;
\ 5.3.6.3.3 Generic eight-bit frame-buffer support
\ The following two functions are unrolled for speed.
\ blit 8 continuous pixels described by the 8bit
\ value in bitmask8. The most significant bit is
\ painted first.
\ this function should honour fg and bg colors
: fb8-write-mask8 ( bitmask8 faddr -- )
over 1 and 0<> over 7 + c!
over 2 and 0<> over 6 + c!
over 4 and 0<> over 5 + c!
over 8 and 0<> over 4 + c!
over 10 and 0<> over 3 + c!
over 20 and 0<> over 2 + c!
over 40 and 0<> over 1 + c!
over 80 and 0<> over 0 + c!
2drop
;
: fb8-blitmask ( fbaddr mask-addr width height -- )
over >r \ save width ( -- R: width )
* 3 >> \ fbaddr mask-addr width*height/8
bounds \ fbaddr mask-end mask
r> 0 2swap \ fbaddr width 0 mask-end mask
?do \ ( fbaddr width l-cnt )
2 pick over + \ fbaddr-current
i c@ \ bitmask8
swap fb8-write-mask8
( fbaddr width l-cnt )
8 + 2dup = if
drop swap screen-width +
swap 0
then
( fbaddr width l-cnt )
loop
2drop drop
;
: fb8-line2addr ( line -- addr )
window-top +
screen-width *
frame-buffer-adr +
window-left +
;
: fb8-copy-line ( from to -- )
fb8-line2addr swap
fb8-line2addr swap
#columns char-width * move
;
: fb8-clear-line ( line -- )
fb8-line2addr
#columns char-width *
background-color fill
\ 0 fill
;
: fb8-draw-character ( char -- )
\ draw the character:
>font
line# char-height * window-top + screen-width *
column# char-width * window-left + + frame-buffer-adr +
swap char-width char-height
fb8-blitmask
\ now advance the position
column# 1+
dup #columns = if
drop 0 to column#
line# 1+
dup #lines = if
drop
\ FIXME move up screen (and keep position)
else
to #lines
then
else
to column#
then
;
: fb8-reset-screen ( -- )
false to inverse?
false to inverse-screen?
0 to foreground-color
d# 15 to background-color
;
: fb8-toggle-cursor ( -- )
line# char-height * window-top + screen-width *
column# char-width * window-left + + frame-buffer-adr +
char-height 0 ?do
char-width 0 ?do
dup i + dup c@ invert ff and swap c!
loop
screen-width +
loop
drop
;
: fb8-erase-screen ( -- )
frame-buffer-adr
screen-height screen-width *
inverse-screen? if
foreground-color
else
background-color
then
fill
;
: fb8-invert-screen ( -- )
frame-buffer-adr
screen-height screen-width *
bounds ?do
i c@ case
foreground-color of background-color endof
background-color of foreground-color endof
dup
endcase
i c!
loop
;
: fb8-blink-screen ( -- )
fb8-invert-screen fb8-invert-screen
;
: fb8-insert-characters ( n -- )
;
: fb8-delete-characters ( n -- )
;
: fb8-insert-lines ( n -- )
;
: fb8-delete-lines ( n -- )
\ numcopy = ( #lines - ( line# + n )) * char-height
#lines over #line + - char-height *
( numcopy ) 0 ?do
dup line# + char-height * i +
line# char-height * i +
swap fb8-copy-line
loop
#lines over - char-height *
over char-height *
0 ?do
dup i + fb8-clear-line
loop
2drop
;
: fb8-draw-logo ( line# addr width height -- )
2swap swap
char-height * window-top +
screen-width * window-left +
frame-buffer-adr +
swap 2swap
\ in-fb-start-adr logo-adr logo-width logo-height
fb8-blitmask ( fbaddr mask-addr width height -- )
;
: fb8-install ( width height #columns #lines -- )
\ set state variables
to #lines
to #columns
to screen-height
to screen-width
screen-width #columns char-width * - 2/ to window-left
screen-height #lines char-height * - 2/ to window-top
0 to column#
0 to line#
0 to inverse?
0 to inverse-screen?
\ set defer functions to 8bit versions
['] fb8-draw-character to draw-character
['] fb8-toggle-cursor to toggle-cursor
['] fb8-erase-screen to erase-screen
['] fb8-blink-screen to blink-screen
['] fb8-invert-screen to invert-screen
['] fb8-insert-characters to insert-characters
['] fb8-delete-characters to delete-characters
['] fb8-insert-lines to insert-lines
['] fb8-delete-lines to delete-lines
['] fb8-draw-logo to draw-logo
['] fb8-reset-screen to reset-screen
\ recommended practice
s" iso6429-1983-colors" get-my-property if
0 ff
else
2drop d# 15 0
then
to foreground-color to background-color
;

103
forth/device/extra.fs Normal file
View File

@@ -0,0 +1,103 @@
\ tag: Useful device related functions
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
: parent ( phandle -- parent.phandle|0 )
>dn.parent @
;
\ -------------------------------------------------------------------
\ property helpers
\ -------------------------------------------------------------------
: int-property ( value name-str name-len -- )
rot encode-int 2swap property
;
\ -------------------------------------------------------------------------
\ property utils
\ -------------------------------------------------------------------------
\ like property (except it takes a phandle as an argument)
: encode-property ( buf len propname propname-len phandle -- )
dup 0= abort" null phandle"
my-self >r 0 to my-self
active-package >r active-package!
property
r> active-package!
r> to my-self
;
\ -------------------------------------------------------------------
\ device tree iteration
\ -------------------------------------------------------------------
: iterate-tree ( phandle -- phandle|0 )
?dup 0= if device-tree @ exit then
\ children first
dup child if
child exit
then
\ then peers
dup peer if
peer exit
then
\ then peer of a parent
begin >dn.parent @ dup while
dup peer if peer exit then
repeat
;
: iterate-tree-begin ( -- first_node )
device-tree @
;
\ -------------------------------------------------------------------
\ device tree iteration
\ -------------------------------------------------------------------
: iterate-device-type ( lastph|0 type-str type-len -- 0|nextph )
rot
begin iterate-tree ?dup while
>r
2dup " device_type" r@ get-package-property if 0 0 then
dup 0> if 1- then
strcmp 0= if 2drop r> exit then
r>
repeat
2drop 0
;
\ -------------------------------------------------------------------
\ device tree "cut and paste"
\ -------------------------------------------------------------------
\ add a subtree to the current device node
: link-nodes ( phandle -- )
\ reparent phandle and peers
dup begin ?dup while
dup >dn.parent active-package !
>dn.peer @
repeat
\ add to list of children
active-package >dn.child
begin dup @ while @ >dn.peer repeat dup . !
;
: link-node ( phandle -- )
0 over >dn.peer !
link-nodes
;

521
forth/device/fcode.fs Normal file
View File

@@ -0,0 +1,521 @@
\ tag: FCode implementation functions
\
\ this code implements IEEE 1275-1994 ch. 5.3.3
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
hex
0 value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
1 value fcode-spread \ fcode spread (1, 2 or 4)
0 value fcode-table \ pointer to fcode table
false value ?fcode-verbose \ do verbose fcode execution?
defer _fcode-debug? \ If true, save names for FCodes with headers
true value fcode-headers? \ If true, possibly save names for FCodes.
0 value fcode-stream-start \ start address of fcode stream
0 value fcode-stream \ current fcode stream address
variable fcode-end \ state variable, if true, fcode program terminates.
defer fcode-c@ \ get byte
: fcode-push-state ( -- <state information> )
?fcode-offset16
fcode-spread
fcode-table
fcode-headers?
fcode-stream-start
fcode-stream
fcode-end @
['] fcode-c@ behavior
;
: fcode-pop-state ( <state information> -- )
to fcode-c@
fcode-end !
to fcode-stream
to fcode-stream-start
to fcode-headers?
to fcode-table
to fcode-spread
to ?fcode-offset16
;
\
\ fcode access helper functions
\
\ fcode-ptr
\ convert FCode number to pointer to xt in FCode table.
: fcode-ptr ( u16 -- *xt )
cells
fcode-table ?dup if + exit then
\ we are not parsing fcode at the moment
dup 800 cells u>= abort" User FCODE# referenced."
fcode-sys-table +
;
\ fcode>xt
\ get xt according to an FCode#
: fcode>xt ( u16 -- xt )
fcode-ptr @
;
\ fcode-num8
\ get 8bit from FCode stream, taking spread into regard.
: fcode-num8 ( -- c ) ( F: c -- )
fcode-stream
dup fcode-spread + to fcode-stream
fcode-c@
;
\ fcode-num16
\ get 16bit from FCode stream
: fcode-num16 ( -- num16 )
fcode-num8 fcode-num8 swap bwjoin
;
\ fcode-num32
\ get 32bit from FCode stream
: fcode-num32 ( -- num32 )
fcode-num8 fcode-num8
fcode-num8 fcode-num8
swap 2swap swap bljoin
;
\ fcode#
\ Get an FCode# from FCode stream
: fcode# ( -- fcode# )
fcode-num8
dup 1 f between if
fcode-num8 swap bwjoin
then
;
\ fcode-offset
\ get offset from FCode stream.
: fcode-offset ( -- offset )
?fcode-offset16 if
fcode-num16
else
fcode-num8
then
;
\ fcode-string
\ get a string from FCode stream, store in pocket.
: fcode-string ( -- addr len )
pocket dup
fcode-num8
dup rot c!
2dup bounds ?do
fcode-num8 i c!
loop
;
\ fcode-header
\ retrieve FCode header from FCode stream
: fcode-header
fcode-num8
fcode-num16
fcode-num32
?fcode-verbose if
." Found FCode header:" cr rot
." Format : " u. cr swap
." Checksum : " u. cr
." Length : " u. cr
else
3drop
then
\ TODO checksum
;
\ writes currently created word as fcode# read from stream
\
: fcode! ( F:FCode# -- )
here fcode# fcode-ptr !
;
\
\ 5.3.3.1 Defining new FCode functions.
\
\ instance ( -- )
\ Mark next defining word as instance specific.
\ (defined in bootstrap.fs)
\ instance-init ( wid buffer -- )
\ Copy template from specified wordlist to instance
\
: instance-init
swap
begin @ dup 0<> while
dup /n + @ instance-cfa? if \ buffer dict
2dup 2 /n* + @ + \ buffer dict dest
over 3 /n* + @ \ buffer dict dest size
2 pick 4 /n* + \ buffer dict dest size src
-rot
move
then
repeat
2drop
;
\ new-token ( F:/FCode#/ -- )
\ Create a new unnamed FCode function
: new-token
0 0 header
fcode!
;
\ named-token (F:FCode-string FCode#/ -- )
\ Create a new possibly named FCode function.
: named-token
fcode-string
_fcode-debug? not if
2drop 0 0
then
header
fcode!
;
\ external-token (F:/FCode-string FCode#/ -- )
\ Create a new named FCode function
: external-token
fcode-string header
fcode!
;
\ b(;) ( -- )
\ End an FCode colon definition.
: b(;)
['] ; execute
; immediate
\ b(:) ( -- ) ( E: ... -- ??? )
\ Defines type of new FCode function as colon definition.
: b(:)
1 , ]
;
\ b(buffer:) ( size -- ) ( E: -- a-addr )
\ Defines type of new FCode function as buffer:.
: b(buffer:)
4 , allot
reveal
;
\ b(constant) ( nl -- ) ( E: -- nl )
\ Defines type of new FCode function as constant.
: b(constant)
3 , ,
reveal
;
\ b(create) ( -- ) ( E: -- a-addr )
\ Defines type of new FCode function as create word.
: b(create)
6 ,
['] noop ,
reveal
;
\ b(defer) ( -- ) ( E: ... -- ??? )
\ Defines type of new FCode function as defer word.
: b(defer)
5 ,
['] (undefined-defer) ,
['] (semis) ,
reveal
;
\ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
\ Defines type of new FCode function as field.
: b(field)
$create
over ,
+
does>
@ +
;
\ b(value) ( x -- ) (E: -- x )
\ Defines type of new FCode function as value.
: b(value)
3 , , reveal
;
\ b(variable) ( -- ) ( E: -- a-addr )
\ Defines type of new FCode function as variable.
: b(variable)
4 , 0 ,
reveal
;
\ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
\ Create a new named user interface command.
: (is-user-word)
;
\ get-token ( fcode# -- xt immediate? )
\ Convert FCode number to function execution token.
: get-token
fcode>xt dup immediate?
;
\ set-token ( xt immediate? fcode# -- )
\ Assign FCode number to existing function.
: set-token
nip \ TODO we use the xt's immediate state for now.
fcode-ptr !
;
\
\ 5.3.3.2 Literals
\
\ b(lit) ( -- n1 )
\ Numeric literal FCode. Followed by FCode-num32.
: b(lit)
fcode-num32
state @ if
['] (lit) , ,
then
; immediate
\ b(') ( -- xt )
\ Function literal FCode. Followed by FCode#
: b(')
fcode# fcode>xt
state @ if
['] (lit) , ,
then
; immediate
\ b(") ( -- str len )
\ String literal FCode. Followed by FCode-string.
: b(")
fcode-string
state @ if
\ only run handle-text in compile-mode,
\ otherwise we would waste a pocket.
handle-text
then
; immediate
\
\ 5.3.3.3 Controlling values and defers
\
\ behavior ( defer-xt -- contents-xt )
\ defined in bootstrap.fs
\ b(to) ( new-value -- )
\ FCode for setting values and defers. Followed by FCode#.
: b(to)
fcode# fcode>xt
1 handle-lit
['] (to)
state @ if
,
else
execute
then
; immediate
\
\ 5.3.3.4 Control flow
\
\ offset16 ( -- )
\ Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.
: offset16
true to ?fcode-offset16
;
\ bbranch ( -- )
\ Unconditional branch FCode. Followed by FCode-offset.
: bbranch
['] dobranch ,
fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
resolve-dest
else
here
0 ,
then
; immediate
\ b?branch ( continue? -- )
\ Conditional branch FCode. Followed by FCode-offset.
: b?branch
['] do?branch ,
fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
resolve-dest
else
here
0 ,
then
; immediate
\ b(<mark) ( -- )
\ Target of backward branches.
: b(<mark)
here
; immediate
\ b(>resolve) ( -- )
\ Target of forward branches.
: b(>resolve)
resolve-orig
; immediate
\ b(loop) ( -- )
\ End FCode do..loop. Followed by FCode-offset.
: b(loop)
fcode-offset drop
postpone loop
; immediate
\ b(+loop) ( delta -- )
\ End FCode do..+loop. Followed by FCode-offset.
: b(+loop)
fcode-offset drop
postpone +loop
; immediate
\ b(do) ( limit start -- )
\ Begin FCode do..loop. Followed by FCode-offset.
: b(do)
fcode-offset drop
postpone do
; immediate
\ b(?do) ( limit start -- )
\ Begin FCode ?do..loop. Followed by FCode-offset.
: b(?do)
fcode-offset drop
postpone ?do
; immediate
\ b(leave) ( -- )
\ Exit from a do..loop.
: b(leave)
postpone leave
; immediate
\ b(case) ( sel -- sel )
\ Begin a case (multiple selection) statement.
: b(case)
postpone case
; immediate
\ b(endcase) ( sel | <nothing> -- )
\ End a case (multiple selection) statement.
: b(endcase)
postpone endcase
; immediate
\ b(of) ( sel of-val -- sel | <nothing> )
\ FCode for of in case statement. Followed by FCode-offset.
: b(of)
fcode-offset drop
postpone of
; immediate
\ b(endof) ( -- )
\ FCode for endof in case statement. Followed by FCode-offset.
: b(endof)
fcode-offset drop
postpone endof
; immediate

82
forth/device/feval.fs Normal file
View File

@@ -0,0 +1,82 @@
\ tag: FCode evaluator
\
\ this code implements an fcode evaluator
\ as described in IEEE 1275-1994
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
defer init-fcode-table
: alloc-fcode-table
4096 cells alloc-mem to fcode-table
?fcode-verbose if
." fcode-table at 0x" fcode-table . cr
then
init-fcode-table
;
: free-fcode-table
fcode-table 4096 cells free-mem
0 to fcode-table
;
: (debug-feval) ( fcode# -- fcode# )
dup fcode>xt cell - lfa2name type
dup ." [ 0x" . ." ]" cr
;
: (feval) ( -- ?? )
begin
fcode#
?fcode-verbose if
(debug-feval)
then
fcode>xt
dup flags? 0<> state @ 0= or if
execute
else
,
then
fcode-end @ until
;
: byte-load ( addr xt -- )
?fcode-verbose if
cr ." byte-load: evaluating fcode at 0x" over . cr
then
\ save state
>r >r fcode-push-state r> r>
\ set fcode-c@ defer
dup 1 = if drop ['] c@ then \ FIXME: uses c@ rather than rb@ for now...
to fcode-c@
dup to fcode-stream-start
to fcode-stream
1 to fcode-spread
false to ?fcode-offset16
alloc-fcode-table
false fcode-end !
\ protect against stack overflow/underflow
0 0 0 0 0 0 depth >r
['] (feval) catch if
cr ." byte-load: exception caught!" cr
then
depth r@ <> if
cr ." byte-load: stack overflow, diff " depth r@ - . cr
then
r> depth! 3drop 3drop
free-fcode-table
\ restore state
fcode-pop-state
;

13
forth/device/font.fs Normal file
View File

@@ -0,0 +1,13 @@
\ tag: 8x16 bitmap font
\
\ Terminus font
\
\ The Terminus Font is developed by and is a property
\ of Dimitar Toshkov Zhekov <jimmy@is-vn.bg>
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
encode-file romfont.bin
drop value (romfont-8x16)

99
forth/device/logo.fs Normal file
View File

@@ -0,0 +1,99 @@
\ tag: monochrome logo
\
\ simple monochrome logo
\ as described in IEEE 1275-1994
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ FIXME : This is currently just a test file, it contains
\ a Pi symbol of size 64x64, not really nicely streched.
\ To use an XBM (X Bitmap), the bits in the bitmap array
\ have to be reversed, i.e. like this:
\
\ int main(void)
\ {
\ int i,j; unsigned char bit, bitnew;
\ for (i=0; i<512; i++) {
\ bit=openbios_bits[i]; bitnew=0;
\ for (j=0; j<8; j++)
\ if (bit & (1<<j)) bitnew |= (1<<(7-j));
\ printf("%02x c, ", bitnew); if(i%8 == 7) printf("\n");
\ }
\ return 0;
\ }
here
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
07 c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
7f c, ff c, ff c, ff c, ff c, ff c, ff c, e0 c,
7f c, df c, ff c, ff c, 7f c, ff c, ff c, 90 c,
78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
78 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
70 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 00 c, 00 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 01 c, 80 c,
00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c,
00 c, 03 c, fe c, 00 c, 07 c, f8 c, 01 c, e0 c,
00 c, 03 c, fe c, 00 c, 07 c, fc c, 03 c, e0 c,
00 c, 07 c, fe c, 00 c, 07 c, fc c, 07 c, e0 c,
00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
00 c, 3f c, fe c, 00 c, 07 c, ff c, ff c, e0 c,
00 c, 3f c, fc c, 00 c, 07 c, ff c, ff c, c0 c,
00 c, 3f c, f8 c, 00 c, 07 c, ff c, ff c, 80 c,
00 c, 7f c, e0 c, 00 c, 0f c, ff c, fe c, 00 c,
00 c, 3f c, e0 c, 00 c, 07 c, ff c, fe c, 00 c,
00 c, 3f c, c0 c, 00 c, 07 c, ff c, fc c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
value (romlogo-64x64)

39
forth/device/missing Normal file
View File

@@ -0,0 +1,39 @@
5.3.3.1
* (is-user-word)
5.3.4 Package access
5.3.6 Display
* default-font
* set-font
* >font
* is-install
* is-remove
* is-selftest
5.3.7 Other
* cpeek
* wpeek
* lpeek
* cpoke
* wpoke
* lpoke
* rb@
* rw@
* rl@
* rb!
* rw!
* rl!
* get-msecs
* ms
* alarm
* user-abort
* mac-address
* display-status
* memory-test-suite
* mask
* diagnostic-mode?
* suspend-fcode
* set-args

179
forth/device/other.fs Normal file
View File

@@ -0,0 +1,179 @@
\ tag: Other FCode functions
\
\ this code implements IEEE 1275-1994 ch. 5.3.7
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ 5.3.7 Other FCode functions
\
hex
\ 5.3.7.1 Peek/poke
: cpeek ( addr -- false | byte true )
;
: wpeek ( waddr -- false | w true )
;
: lpeek ( qaddr -- false | quad true )
;
: cpoke ( byte addr -- okay? )
;
: wpoke ( w waddr -- okay? )
;
: lpoke ( quad qaddr -- okay? )
;
\ 5.3.7.2 Device-register access
: rb@ ( addr -- byte )
;
: rw@ ( waddr -- w )
;
: rl@ ( qaddr -- quad )
;
: rb! ( byte addr -- )
;
: rw! ( w waddr -- )
;
: rl! ( quad qaddr -- )
;
\ 5.3.7.3 Time
: get-msecs ( -- n )
;
: ms ( n -- )
;
: alarm ( xt n -- )
;
: user-abort ( ... -- ) ( R: ... -- )
;
\ 5.3.7.4 System information
0003.0000 value fcode-revision ( -- n )
: mac-address ( -- mac-str mac-len )
;
\ 5.3.7.5 FCode self-test
: display-status ( n -- )
;
: memory-test-suite ( addr len -- fail? )
;
: mask ( -- a-addr )
;
: diagnostic-mode? ( -- diag? )
;
\ 5.3.7.6 Start and end.
\ Begin program with spread 0 followed by FCode-header.
: start0 ( -- )
0 fcode-spread !
offset16
fcode-header
;
\ Begin program with spread 1 followed by FCode-header.
: start1 ( -- )
1 to fcode-spread
offset16
fcode-header
;
\ Begin program with spread 2 followed by FCode-header.
: start2 ( -- )
2 to fcode-spread
offset16
fcode-header
;
\ Begin program with spread 4 followed by FCode-header.
: start4 ( -- )
4 to fcode-spread
offset16
fcode-header
;
\ Begin program with spread 1 followed by FCode-header.
: version1 ( -- )
1 to fcode-spread
fcode-header
;
\ Cease evaluating this FCode program.
: end0 ( -- )
true fcode-end !
;
\ Cease evaluating this FCode program.
: end1 ( -- )
end0
;
\ Standard FCode number for undefined FCode functions.
: ferror ( -- )
." undefined fcode# encountered." cr
true fcode-end !
;
\ Pause FCode evaluation if desired; can resume later.
: suspend-fcode ( -- )
\ NOT YET IMPLEMENTED.
;
\ Evaluate FCode beginning at location addr.
\ : byte-load ( addr xt -- )
\ \ this word is implemented in feval.fs
\ ;
\ Set address and arguments of new device node.
: set-args ( arg-str arg-len unit-str unit-len -- )
?my-self drop
depth 1- >r
" decode-unit" ['] $call-parent catch if
2drop 2drop
then
my-self ihandle>phandle >dn.probe-addr \ offset
begin depth r@ > while
dup na1+ >r ! r>
repeat
r> 2drop
my-self >in.arguments 2@ free-mem
strdup my-self >in.arguments 2!
;
: dma-alloc
s" dma-alloc" $call-parent
;

256
forth/device/package.fs Normal file
View File

@@ -0,0 +1,256 @@
\ tag: Package access.
\
\ this code implements IEEE 1275-1994 ch. 5.3.4
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ variable last-package 0 last-package !
\ 0 value active-package
\
\ 5.3.4.1 Open/Close packages (part 1)
\
\ 0 value my-self ( -- ihandle )
: ?my-self
my-self dup 0= abort" no current instance."
;
: my-parent ( -- ihandle )
?my-self >in.my-parent @
;
: ihandle>phandle ( ihandle -- phandle )
>in.device-node @
;
\ next-property
\ defined in property.c
: peer ( phandle -- phandle.sibling )
?dup if
>dn.peer @
else
device-tree @
then
;
: child ( phandle.parent -- phandle.child )
>dn.child @
;
\
\ 5.3.4.2 Call methods from other packages
\
: find-method ( method-str method-len phandle -- false | xt true )
\ should we search the private wordlist too? I don't think so...
>dn.methods @ find-wordlist if
true
else
2drop false
then
;
: call-package ( ... xt ihandle -- ??? )
my-self >r
to my-self
execute
r> to my-self
;
: $call-method ( ... method-str method-len ihandle -- ??? )
dup >r >in.device-node @ find-method if
r> call-package
else
-21 throw
then
;
: $call-parent ( ... method-str method-len -- ??? )
my-parent $call-method
;
\
\ 5.3.4.1 Open/Close packages (part 2)
\
\ find-dev ( dev-str dev-len -- false | phandle true )
\ find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
\
\ These function works just like find-device but without
\ any side effects (or exceptions).
\
defer find-dev
: find-rel-dev ( dev-str dev-len phandle -- false | phandle true )
active-package >r active-package!
find-dev
r> active-package!
;
: find-package ( name-str name-len -- false | phandle true )
\ Locate the support package named by name string.
\ If the package can be located, return its phandle and true; otherwise,
\ return false.
\ Interpret the name in name string relative to the "packages" device node.
\ If there are multiple packages with the same name (within the "packages"
\ node), return the phandle for the most recently created one.
\ This does the full path resolution stuff (including
\ alias expansion. If we don't want that, then we should just
\ iterade the children of /packages.
" /packages" find-dev 0= if 2drop false exit then
find-rel-dev 0= if false exit then
\ Find the most recent node that match. One could make life
\ simple and add nodes at the head but I prefer it this way.
>r
" name" r@ get-package-property if " " then
r@ begin >dn.peer @ dup while
3dup
" name" rot get-package-property if " " then
strcmp
0= if r> drop dup >r then
repeat 3drop
r> true
;
: open-package ( arg-str arg-len phandle -- ihandle | 0 )
\ Open the package indicated by phandle.
\ Create an instance of the package identified by phandle, save in that
\ instance the instance-argument specified by arg-string and invoke the
\ package's open method.
\ Return the instance handle ihandle of the new instance, or 0 if the package
\ could not be opened. This could occur either because that package has no
\ open method, or because its open method returned false, indicating an error.
\ The parent instance of the new instance is the instance that invoked
\ open-package. The current instance is not changed.
create-instance dup 0= if
3drop 0 exit
then
>r
\ clone arg-str
strdup r@ >in.arguments 2!
\ open the package
" open" r@ ['] $call-method catch if 3drop false then
if
r>
else
r> destroy-instance false
then
;
: $open-package ( arg-str arg-len name-str name-len -- ihandle | 0 )
\ Open the support package named by name string.
find-package if
open-package
else
2drop false
then
;
: close-package ( ihandle -- )
\ Close the instance identified by ihandle by calling the package's close
\ method and then destroying the instance.
dup " close" rot ['] $call-method catch if 3drop then
destroy-instance
;
\
\ 5.3.4.3 Get local arguments
\
: my-address ( -- phys.lo ... )
?my-self >in.device-node @
>dn.probe-addr
my-#acells tuck cells + swap 1- 0
?do
cell - dup @ swap
loop
drop
;
: my-space ( -- phys.hi )
?my-self >in.device-node @
>dn.probe-addr @
;
: my-unit ( -- phys.lo ... phys.hi )
?my-self >in.my-unit
my-#acells tuck cells + swap 0 ?do
cell - dup @ swap
loop
drop
;
: my-args ( -- arg-str arg-len )
?my-self >in.arguments 2@
;
\ char is not included. If char is not found, then R-len is zero
: left-parse-string ( str len char -- R-str R-len L-str L-len )
left-split
;
\ parse ints "hi,...,lo" separated by comma
: parse-ints ( str len num -- val.lo .. val.hi )
-rot 2 pick -rot
begin
rot 1- -rot 2 pick 0>=
while
( num n str len )
2dup ascii , strchr ?dup if
( num n str len p )
1+ -rot
2 pick 2 pick - ( num n p str len len1+1 )
dup -rot - ( num n p str len1+1 len2 )
-rot 1- ( num n p len2 str len1 )
else
0 0 2swap
then
$number if 0 then >r
repeat
3drop
( num )
begin 1- dup 0>= while r> swap repeat
drop
;
: parse-2int ( str len -- val.lo val.hi )
2 parse-ints
;
\
\ 5.3.4.4 Mapping tools
\
: map-low ( phys.lo ... size -- virt )
my-space swap s" map-in" $call-parent
;
: free-virtual ( virt size -- )
over s" address" get-my-property 0= if
decode-int -rot 2drop = if
s" address" delete-property
then
else
drop
then
s" map-out" $call-parent
;

517
forth/device/pathres.fs Normal file
View File

@@ -0,0 +1,517 @@
\ tag: Path resolution
\
\ this code implements IEEE 1275-1994 path resolution
\
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
0 value interpose-ph
0 0 create interpose-args , ,
: expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? )
2dup
" /aliases" find-dev 0= if 2drop false exit then
get-package-property if
false
else
2swap 2drop
\ drop trailing 0 from string
dup if 1- then
true
then
;
\
\ 4.3.1 Resolve aliases
\
\ the returned string is allocated with alloc-mem
: pathres-resolve-aliases ( path-addr path-len -- path-addr path-len )
over c@ 2f <> if
200 here + >r \ abuse dictionary for temporary storage
\ If the pathname does not begin with "/", and its first node name
\ component is an alias, replace the alias with its expansion.
ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD)
ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME)
expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? )
if
2 pick 0<> if \ If ALIAS_ARGS is not empty
ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/)
2swap ( TAIL AL_HEAD/ AL_TAIL )
ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL)
2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL )
2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD )
r> tmpstrcat tmpstrcat >r
else
2swap 2drop \ drop ALIAS_ARGS
then
r> tmpstrcat drop
else
\ put thing back together again
r> tmpstrcat tmpstrcat drop
then
then
strdup
( path-addr path-len )
;
\
\ search struct
\
struct ( search information )
2 cells field >si.path
2 cells field >si.arguments
2 cells field >si.unit_addr
2 cells field >si.node_name
2 cells field >si.free_me
4 cells field >si.unit_phys
/n field >si.unit_phys_len
/n field >si.save-ihandle
/n field >si.save-phandle
/n field >si.top-ihandle
/n field >si.top-opened \ set after successful open
/n field >si.child \ node to match
constant sinfo.size
\
\ 4.3.6 node name match criteria
\
: match-nodename ( childname len sinfo -- match? )
>r
2dup r@ >si.node_name 2@
( [childname] [childname] [nodename] )
strcmp 0= if r> 3drop true exit then
\ does NODE_NAME contain a comma?
r@ >si.node_name 2@ ascii , strchr
if r> 3drop false exit then
( [childname] )
ascii , left-split 2drop r@ >si.node_name 2@
r> drop
strcmp if false else true then
;
\
\ 4.3.4 exact match child node
\
\ If NODE_NAME is not empty, make sure it matches the name property
: common-match ( sinfo -- )
>r
\ a) NODE_NAME nonempty
r@ >si.node_name 2@ nip if
" name" r@ >si.child @ get-package-property if -1 throw then
\ name is supposed to be null-terminated
dup 0> if 1- then
\ exit if NODE_NAME does not match
r@ match-nodename 0= if -2 throw then
then
r> drop
;
: (exact-match) ( sinfo -- )
>r
\ a) If NODE_NAME is not empty, make sure it matches the name property
r@ common-match
\ b) UNIT_PHYS nonempty?
r@ >si.unit_phys_len @ cells ?dup if
\ check if unit_phys matches
" reg" r@ >si.child @ get-package-property if -3 throw then
( unitbytes propaddr proplen )
rot r@ >si.unit_phys -rot
( propaddr unit_phys proplen unitbytes )
swap over < if -4 throw then
comp if -5 throw then
else
\ c) both NODE_NAME and UNIT_PHYS empty?
r@ >si.node_name 2@ nip 0= if -6 throw then
then
r> drop
;
: exact-match ( sinfo -- match? )
['] (exact-match) catch if drop false exit then
true
;
\
\ 4.3.5 wildcard match child node
\
: (wildcard-match) ( sinfo -- match? )
>r
\ a) If NODE_NAME is not empty, make sure it matches the name property
r@ common-match
\ b) Fail if "reg" property exist
" reg" r@ >si.child @ get-package-property 0= if -7 throw then
\ c) Fail if both NODE_NAME and UNIT_ADDR are both empty
r@ >si.unit_phys_len @
r@ >si.node_name 2@ nip
or 0= if -1 throw then
\ SUCCESS
r> drop
;
: wildcard-match ( sinfo -- match? )
['] (wildcard-match) catch if drop false exit then
true
;
\
\ 4.3.3 match child node
\
: find-child ( sinfo -- phandle )
>r
\ decode unit address string
r@ >si.unit_addr 2@ dup if
( str len )
" decode-unit" active-package find-method
if
depth 3 - >r execute depth r@ - r> swap
( ... a_lo ... a_hi olddepth n )
4 min 0 max
dup r@ >si.unit_phys_len !
( ... a_lo ... a_hi olddepth n )
r@ >si.unit_phys >r
begin 1- dup 0>= while
rot r> dup na1+ >r !
repeat
r> 2drop
depth!
else
\ no decode-unit method... failure
-99 throw
then
else
2drop
\ clear unit_phys
0 r@ >si.unit_phys_len !
\ r@ >si.unit_phys 4 cells 0 fill
then
( R: sinfo )
['] exact-match
begin dup while
active-package >dn.child @
begin ?dup while
dup r@ >si.child !
( xt phandle R: sinfo )
r@ 2 pick execute if 2drop r> >si.child @ exit then
>dn.peer @
repeat
['] exact-match = if ['] wildcard-match else 0 then
repeat
-99 throw
;
\
\ 4.3.2 Create new linked instance procedure
\
: link-one ( sinfo -- )
>r
active-package create-instance
dup 0= if -99 throw then
\ change instance parent
r@ >si.top-ihandle @ over >in.my-parent !
dup r@ >si.top-ihandle !
to my-self
\ b) set my-args field
r@ >si.arguments 2@ strdup my-self >in.arguments 2!
\ e) set my-unit field
r@ >si.unit_addr 2@ nip if
\ copy UNIT_PHYS to the my-unit field
r@ >si.unit_phys my-self >in.my-unit 4 cells move
else
\ set unit-addr from reg property
" reg" active-package get-package-property 0= if
\ ( ihandle prop proplen )
\ copy address to my-unit
4 cells min my-self >in.my-unit swap move
else
\ clear my-unit
my-self >in.my-unit 4 cells 0 fill
then
then
\ top instance has not been opened (yet)
false r> >si.top-opened !
;
: invoke-open ( sinfo -- )
" open" my-self ['] $call-method
catch if 3drop false then
0= if -99 throw then
true swap >si.top-opened !
;
\
\ 4.3.7 Handle interposers procedure (supplement)
\
: handle-interposers ( sinfo -- )
>r
begin
interpose-ph ?dup
while
0 to interpose-ph
active-package swap active-package!
\ clear unit address and set arguments
0 0 r@ >si.unit_addr 2!
interpose-args 2@ r@ >si.arguments 2!
r@ link-one
true my-self >in.interposed !
interpose-args 2@ free-mem
r@ invoke-open
active-package!
repeat
r> drop
;
\
\ 4.3.1 Path resolution procedure
\
\ close-dev ( ihandle -- )
\
: close-dev
begin
dup
while
dup >in.my-parent @
swap close-package
repeat
drop
;
: path-res-cleanup ( sinfo close? )
\ tear down all instances if close? is set
if
dup >si.top-opened @ if
dup >si.top-ihandle @
?dup if close-dev then
else
dup >si.top-ihandle @ dup
( sinfo ihandle ihandle )
dup if >in.my-parent @ swap then
( sinfo parent ihandle )
?dup if destroy-instance then
?dup if close-dev then
then
then
\ restore active-package and my-self
dup >si.save-ihandle @ to my-self
dup >si.save-phandle @ active-package!
\ free any allocated memory
dup >si.free_me 2@ free-mem
sinfo.size free-mem
;
: (path-resolution) ( context sinfo -- )
>r r@ >si.path 2@
( context pathstr pathlen )
\ this allocates a copy of the string
pathres-resolve-aliases
2dup r@ >si.free_me 2!
\ If the pathname, after possible alias expansion, begins with "/",
\ begin the search at the root node. Otherwise, begin at the active
\ package.
dup if \ make sure string is not empty
over c@ 2f = if
swap char+ swap /c - \ Remove the "/" from PATH_NAME.
\ Set the active package to the root node.
device-tree @ active-package!
then
then
r@ >si.path 2!
0 0 r@ >si.unit_addr 2!
0 0 r@ >si.arguments 2!
0 r@ >si.top-ihandle !
\ If there is no active package, exit this procedure, returning false.
( context )
active-package 0= if -99 throw then
\ Begin the creation of an instance chain.
\ NOTE--If, at this step, the active package is not the root node and
\ we are in open-dev or execute-device-method contexts, the instance
\ chain that results from the path resolution process may be incomplete.
active-package swap
( virt-active-node context )
begin
r@ >si.path 2@ nip \ nonzero path?
while
\ ( active-node context )
\ is this open-dev or execute-device-method context?
dup if
r@ link-one
over active-package <> my-self >in.interposed !
r@ invoke-open
r@ handle-interposers
then
over active-package!
r@ >si.path 2@ ( PATH )
ascii / left-split ( PATH COMPONENT )
ascii : left-split ( PATH ARGS NODE_ADDR )
ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME )
r@ >si.node_name 2!
r@ >si.unit_addr 2!
r@ >si.arguments 2!
r@ >si.path 2!
( virt-active-node context )
\ 4.3.1 i) pathname has a leading %?
r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if
1- swap 1+ swap r@ >si.node_name 2!
" /packages" find-dev drop active-package!
r@ find-child
else
2drop
nip r@ find-child swap over
( new-node context new-node )
then
\ (optional: open any nodes between parent and child )
active-package!
repeat
( virt-active-node type )
dup if r@ link-one then
1 = if
dup active-package <> my-self >in.interposed !
r@ invoke-open
r@ handle-interposers
then
active-package!
r> drop
;
: path-resolution ( context path-addr path-len -- sinfo true | false )
\ allocate and clear the search block
sinfo.size alloc-mem >r
r@ sinfo.size 0 fill
\ store path
r@ >si.path 2!
\ save ihandle and phandle
my-self r@ >si.save-ihandle !
active-package r@ >si.save-phandle !
\ save context (if we take an exception)
dup
r@ ['] (path-resolution)
catch ?dup if
( context xxx xxx error )
r> true path-res-cleanup
\ rethrow everything except our "cleanup throw"
dup -99 <> if throw then
3drop
\ ( context ) throw an exception if this is find-device context
if false else -22 throw then
exit
then
\ ( context )
drop r> true
( sinfo true )
;
: open-dev ( dev-str dev-len -- ihandle | 0 )
1 -rot path-resolution 0= if false exit then
( sinfo )
my-self swap
false path-res-cleanup
( ihandle )
;
: execute-device-method
( ... dev-str dev-len met-str met-len -- ... false | ?? true )
2swap
2 -rot path-resolution 0= if 2drop false exit then
( method-str method-len sinfo )
>r
my-self ['] $call-method catch
if 3drop false else true then
r> true path-res-cleanup
;
: find-device ( dev-str dev-len -- )
2dup " .." strcmp 0= if
2drop
active-package dup if >dn.parent @ then
\ ".." in root note?
dup 0= if -22 throw then
active-package!
exit
then
0 -rot path-resolution 0= if false exit then
( sinfo )
active-package swap
true path-res-cleanup
active-package!
;
\ find-device, but without side effects
: (find-dev) ( dev-str dev-len -- phandle true | false )
active-package -rot
['] find-device catch if 3drop false exit then
active-package swap active-package! true
;
\ Tuck on a node at the end of the chain being created.
\ This implementation follows the interpose recommended practice
\ (v0.2 draft).
: interpose ( arg-str arg-len phandle -- )
to interpose-ph
strdup interpose-args 2!
;
['] (find-dev) to find-dev

50
forth/device/preof.fs Normal file
View File

@@ -0,0 +1,50 @@
\ tag: historical and pre open firmware fcode functions
\
\ this code implements IEEE 1275-1994 ch. H.2.2 and 5.3.1.1.1
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ H.2.2 Non-implemented FCodes
\ Pre-Open Firmware systems assigned the following FCode numbers,
\ but the functions were not supported. These FCode numbers stay
\ reserved to avoid confusion.
: non-implemented
." Non-implemented historical or pre-Open Firmware FCode occured." cr
end0
;
: adr-mask non-implemented ;
: b(code) non-implemented ;
: 4-byte-id non-implemented ;
: convert non-implemented ;
: frame-buffer-busy? non-implemented ;
: poll-packet non-implemented ;
: return-buffer non-implemented ;
: set-token-table non-implemented ;
: set-table non-implemented ;
: xmit-packet non-implemented ;
\ historical fcode words defined by 5.3.1.1.1
30000 constant fcode-version \ this opcode is considered obsolete
30000 constant firmware-version \ this opcode is considered obsolete
\ historical - Returns the type of processor.
\ 0x5 indicates SPARC, other values are not used.
\ ?? this could be set by the kernel during bootstrap.
deadbeef constant processor-type ( -- processor-type )
: memmap non-implemented ;
: >physical non-implemented ;
: my-params non-implemented ;
: intr non-implemented ;
: driver non-implemented ;
: group-code non-implemented ;
: probe non-implemented ;
: probe-virtual non-implemented ;

324
forth/device/property.fs Normal file
View File

@@ -0,0 +1,324 @@
\ tag: Property management
\
\ this code implements IEEE 1275-1994 ch. 5.3.5
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ small helpers.. these should go elsewhere.
: bigendian?
10 here ! here c@ 10 <>
;
: l!-be ( val addr )
3 bounds swap do
dup ff and i c!
8 rshift
-1 +loop
drop
;
: l@-be ( addr )
0 swap 4 bounds do
i c@ swap 8 << or
loop
;
\ allocate n bytes for device tree information
\ until I know where to put this, I put it in the
\ dictionary.
: alloc-tree ( n -- addr )
dup >r \ save len
here swap allot
dup r> 0 fill \ clear memory
;
: align-tree ( -- )
null-align
;
: no-active true abort" no active package." ;
\
\ 5.3.5 Property management
\
\ Helper function
: find-property ( name len phandle -- &&prop|0 )
>dn.properties
begin
dup @
while
dup @ >prop.name @ ( name len prop propname )
2over comp0 ( name len prop equal? )
0= if nip nip exit then
>prop.next @
repeat
( name len false )
3drop false
;
\ From package (5.3.4.1)
: next-property
( previous-str previous-len phandle -- false | name-str name-len true )
>r
2dup 0= swap 0= or if
2drop r> >dn.properties @
else
r> find-property dup if @ then
?dup if >prop.next @ then
then
?dup if
>prop.name @ dup cstrlen true
( phandle name-str name-len true )
else
false
then
;
\
\ 5.3.5.4 Property value access
\
\ Return value for name string property in package phandle.
: get-package-property
( name-str name-len phandle -- true | prop-addr prop-len false )
find-property ?dup if
@ dup >prop.addr @
swap >prop.len @
false
else
true
then
;
\ Return value for given property in the current instance or its parents.
: get-inherited-property
( name-str name-len -- true | prop-addr prop-len false )
my-self
begin
?dup
while
dup >in.device-node @ ( str len ihandle phandle )
2over rot find-property ?dup if
@
( str len ihandle prop )
nip nip nip ( prop )
dup >prop.addr @ swap >prop.len @
false
exit
then
( str len ihandle )
>in.my-parent @
repeat
2drop
true
;
\ Return value for given property in this package.
: get-my-property ( name-str name-len -- true | prop-addr prop-len false )
my-self >in.device-node @ ( -- phandle )
get-package-property
;
\
\ 5.3.5.2 Property array decoding
\
: decode-int ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 n )
dup 0> if
dup 4 min >r ( addr1 len1 R:minlen )
over r@ + swap ( addr1 addr2 len1 R:minlen )
r> - ( addr1 addr2 len2 )
rot l@-be
else
0
then
;
\ HELPER: get #address-cell value (from parent)
\ Legal values are 1..4 (we may optionally support longer addresses)
: my-#acells ( -- #address-cells )
my-self ?dup if >in.device-node @ else active-package then
?dup if >dn.parent @ then
?dup if
" #address-cells" rot get-package-property if 2 exit then
\ we don't have to support more than 4 (and 0 is illegal)
decode-int nip nip 4 min 1 max
else
2
then
;
: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len )
dup 0> if
2dup bounds \ check property for 0 bytes
0 -rot \ initial string len is 0
do
i c@ 0= if
leave
then
1+
loop ( prop-addr1 prop-len1 len )
1+ rot >r ( prop-len1 len R: prop-addr1 )
over min 2dup - ( prop-len1 nlen prop-len2 R: prop-addr1 )
r@ 2 pick + ( prop-len1 nlen prop-len2 prop-addr2 )
>r >r >r ( R: prop-addr1 prop-addr2 prop-len2 nlen )
drop
r> r> r> ( nlen prop-len2 prop-addr2 )
-rot swap ( prop-addr2 prop-len2 nlen )
r> swap ( prop-addr2 prop-len2 str len )
else
0 0
then
;
: decode-bytes ( addr1 len1 #bytes -- addr len2 addr1 #bytes )
tuck - ( addr1 #bytes len2 )
r> 2dup + ( addr1 #bytes addr2 ) ( R: len2 )
r> 2swap
;
: decode-phys
( prop-addr1 prop-len1 -- prop-addr2 prop-len2 phys.lo ... phys.hi )
my-#acells 0 ?do
decode-int r> r> rot >r >r >r
loop
my-#acells 0 ?do
r> r> r> -rot >r >r
loop
;
\
\ 5.3.5.1 Property array encoding
\
: encode-int ( n -- prop-addr prop-len )
/l alloc-tree tuck l!-be /l
;
: encode-string ( str len -- prop-addr prop-len )
\ we trust len here. should probably check string?
tuck char+ alloc-tree ( len str prop-addr )
tuck 3 pick move ( len prop-addr )
swap 1+
;
: encode-bytes ( data-addr data-len -- prop-addr prop-len )
tuck alloc-tree ( len str prop-addr )
tuck 3 pick move
swap
;
: encode+ ( prop-addr1 prop-len1 prop-addr2 prop-len2 -- prop-addr3 prop-len3 )
nip +
;
: encode-phys ( phys.lo ... phys.hi -- prop-addr prop-len )
encode-int my-#acells 1- 0 ?do
rot encode-int encode+
loop
;
defer sbus-intr>cpu ( sbus-intr# -- cpu-intr# )
: (sbus-intr>cpu) ." No SBUS present on this machine." cr ;
['] (sbus-intr>cpu) to sbus-intr>cpu
\
\ 5.3.5.3 Property declaration
\
: (property) ( prop-addr prop-len name-str name-len dnode -- )
>r 2dup r@
align-tree
find-property ?dup if
\ If a property with that property name already exists in the
\ package in which the property would be created, replace its
\ value with the new value.
@ r> drop \ don't need the device node anymore.
-rot 2drop tuck \ drop property name
>prop.len ! \ overwrite old values
>prop.addr !
exit
then
( prop-addr prop-len name-str name-len R: dn )
prop-node.size alloc-tree
dup >prop.next off
dup r> >dn.properties
begin dup @ while @ >prop.next repeat !
>r
( prop-addr prop-len name-str name-len R: prop )
\ create copy of property name
dup char+ alloc-tree
dup >r swap move r>
( prop-addr prop-len new-name R: prop )
r@ >prop.name !
r@ >prop.len !
r> >prop.addr !
align-tree
;
: property ( prop-addr prop-len name-str name-len -- )
my-self ?dup if
>in.device-node @
else
active-package
then
dup if
(property)
else
no-active
then
;
: (delete-property) ( name len dnode -- )
find-property ?dup if
dup @ >prop.next @ swap !
\ maybe we should try to reclaim the space?
then
;
: delete-property ( name-str name-len -- )
active-package ?dup if
(delete-property)
else
2drop
then
;
\ Create the "name" property; value is indicated string.
: device-name ( str len -- )
encode-string " name" property
;
\ Create "device_type" property, value is indicated string.
: device-type ( str len -- )
encode-string " device_type" property
;
\ Create the "reg" property with the given values.
: reg ( phys.lo ... phys.hi size -- )
>r ( phys.lo ... phys.hi ) encode-phys ( addr len )
r> ( addr1 len1 size ) encode-int ( addr1 len1 addr2 len2 )
encode+ ( addr len )
" reg" property
;
\ Create the "model" property; value is indicated string.
: model ( str len -- )
encode-string " model" property
;

BIN
forth/device/romfont.bin Normal file
View File

Binary file not shown.

54
forth/device/structures.fs Normal file
View File

@@ -0,0 +1,54 @@
\ tag: device interface structures
\
\ this code implements data structures used by the
\ IEEE 1275-1994 Open Firmware Device Interface.
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ this file contains the struct definitions for the following
\ device tree structures:
\ device-node
\ active-package
\ property
\ instance
struct ( instance )
/n field >in.instance-data \ must go first
/n field >in.alloced-size \ alloced size
/n field >in.device-node
/n field >in.my-parent
/n field >in.interposed
4 cells field >in.my-unit
2 cells field >in.arguments
\ instance-data should be null during packet initialization
\ this diverts access to instance variables to the dictionary
constant inst-node.size
struct ( device node )
/n field >dn.isize \ instance size (must go first)
/n field >dn.parent
/n field >dn.child
/n field >dn.peer
/n field >dn.properties
/n field >dn.methods
/n field >dn.priv-methods
/n field >dn.#acells
/n field >dn.probe-addr
inst-node.size field >dn.itemplate
constant dev-node.size
struct ( property )
/n field >prop.next
/n field >prop.name
/n field >prop.addr
/n field >prop.len
constant prop-node.size
struct ( active package )
/n field >ap.device-str
constant active-package.size

428
forth/device/table.fs Normal file
View File

@@ -0,0 +1,428 @@
\ tag: FCode table setup
\
\ this code implements an fcode evaluator
\ as described in IEEE 1275-1994
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
hex
: undefined-fcode ." undefined fcode word." cr ;
: reserved-fcode ." reserved fcode word." cr ;
: ['], ( <word> -- )
' ,
;
: n['], ( n <word> -- )
' swap 0 do
dup ,
loop
drop
;
\ the table used
create fcode-master-table
['], end0
f n['], reserved-fcode
['], b(lit)
['], b(')
['], b(")
['], bbranch
['], b?branch
['], b(loop)
['], b(+loop)
['], b(do)
['], b(?do)
['], i
['], j
['], b(leave)
['], b(of)
['], execute
['], +
['], -
['], *
['], /
['], mod
['], and
['], or
['], xor
['], invert
['], lshift
['], rshift
['], >>a
['], /mod
['], u/mod
['], negate
['], abs
['], min
['], max
['], >r
['], r>
['], r@
['], exit
['], 0=
['], 0<>
['], 0<
['], 0<=
['], 0>
['], 0>=
['], <
['], >
['], =
['], <>
['], u>
['], u<=
['], u<
['], u>=
['], >=
['], <=
['], between
['], within
['], drop
['], dup
['], over
['], swap
['], rot
['], -rot
['], tuck
['], nip
['], pick
['], roll
['], ?dup
['], depth
['], 2drop
['], 2dup
['], 2over
['], 2swap
['], 2rot
['], 2/
['], u2/
['], 2*
['], /c
['], /w
['], /l
['], /n
['], ca+
['], wa+
['], la+
['], na+
['], char+
['], wa1+
['], la1+
['], cell+
['], chars
['], /w*
['], /l*
['], cells
['], on
['], off
['], +!
['], @
['], l@
['], w@
['], <w@
['], c@
['], !
['], l!
['], w!
['], c!
['], 2@
['], 2!
['], move
['], fill
['], comp
['], noop
['], lwsplit
['], wljoin
['], lbsplit
['], bljoin
['], wbflip
['], upc
['], lcc
['], pack
['], count
['], body>
['], >body
['], fcode-revision
['], span
['], unloop
['], expect
['], alloc-mem
['], free-mem
['], key?
['], key
['], emit
['], type
['], (cr
['], cr
['], #out
['], #line
['], hold
['], <#
['], u#>
['], sign
['], u#
['], u#s
['], u.
['], u.r
['], .
['], .r
['], .s
['], base
['], convert \ reserved (compatibility)
['], $number
['], digit
['], -1
['], 0
['], 1
['], 2
['], 3
['], bl
['], bs
['], bell
['], bounds
['], here
['], aligned
['], wbsplit
['], bwjoin
['], b(<mark)
['], b(>resolve)
['], set-token-table
['], set-table
['], new-token
['], named-token
['], b(:)
['], b(value)
['], b(variable)
['], b(constant)
['], b(create)
['], b(defer)
['], b(buffer:)
['], b(field)
['], b(code)
['], instance
['], reserved-fcode
['], b(;)
['], b(to)
['], b(case)
['], b(endcase)
['], b(endof)
['], #
['], #s
['], #>
['], external-token
['], $find
['], offset16
['], evaluate
['], reserved-fcode
['], reserved-fcode
['], c,
['], w,
['], l,
['], ,
['], um*
['], um/mod
['], reserved-fcode
['], reserved-fcode
['], d+
['], d-
['], get-token
['], set-token
['], state
['], compile,
['], behavior
11 n['], reserved-fcode
['], start0
['], start1
['], start2
['], start4
8 n['], reserved-fcode
['], ferror
['], version1
['], 4-byte-id
['], end1
['], reserved-fcode
['], dma-alloc
['], my-address
['], my-space
['], memmap
['], free-virtual
['], >physical
8 n['], reserved-fcode
['], my-params
['], property
['], encode-int
['], encode+
['], encode-phys
['], encode-string
['], encode-bytes
['], reg
['], intr
['], driver
['], model
['], device-type
['], parse-2int
['], is-install
['], is-remove
['], is-selftest
['], new-device
['], diagnostic-mode?
['], display-status
['], memory-test-suite
['], group-code
['], mask
['], get-msecs
['], ms
['], finish-device
['], decode-phys \ 128
2 n['], reserved-fcode
['], interpose \ extension (recommended practice)
4 n['], reserved-fcode
['], map-low
['], sbus-intr>cpu
1e n['], reserved-fcode
['], #lines
['], #columns
['], line#
['], column#
['], inverse?
['], inverse-screen?
['], frame-buffer-busy?
['], draw-character
['], reset-screen
['], toggle-cursor
['], erase-screen
['], blink-screen
['], invert-screen
['], insert-characters
['], delete-characters
['], insert-lines
['], delete-lines
['], draw-logo
['], frame-buffer-adr
['], screen-height
['], screen-width
['], window-top
['], window-left
3 n['], reserved-fcode
['], default-font
['], set-font
['], char-height
['], char-width
['], >font
['], fontbytes
10 n['], reserved-fcode \ fb1 words
['], fb8-draw-character
['], fb8-reset-screen
['], fb8-toggle-cursor
['], fb8-erase-screen
['], fb8-blink-screen
['], fb8-invert-screen
['], fb8-insert-characters
['], fb8-delete-characters
['], fb8-insert-lines
['], fb8-delete-lines
['], fb8-draw-logo
['], fb8-install
4 n['], reserved-fcode \ reserved
7 n['], reserved-fcode \ VME-bus support
9 n['], reserved-fcode \ reserved
['], return-buffer
['], xmit-packet
['], poll-packet
['], reserved-fcode
['], mac-address
5c n['], reserved-fcode \ 1a5-200 reserved
['], device-name
['], my-args
['], my-self
['], find-package
['], open-package
['], close-package
['], find-method
['], call-package
['], $call-parent
['], my-parent
['], ihandle>phandle
['], reserved-fcode
['], my-unit
['], $call-method
['], $open-package
['], processor-type
['], firmware-version
['], fcode-version
['], alarm
['], (is-user-word)
['], suspend-fcode
['], abort
['], catch
['], throw
['], user-abort
['], get-my-property
['], decode-int
['], decode-string
['], get-inherited-property
['], delete-property
['], get-package-property
['], cpeek
['], wpeek
['], lpeek
['], cpoke
['], wpoke
['], lpoke
['], lwflip
['], lbflip
['], lbflips
['], adr-mask
6 n['], reserved-fcode \ 22a-22f
['], rb@
['], rb!
['], rw@
['], rw!
['], rl@
['], rl!
['], wbflips
['], lwflips
['], probe
['], probe-virtual
['], reserved-fcode
['], child
['], peer
['], next-property
['], byte-load
['], set-args
['], left-parse-string \ 240
here fcode-master-table - constant fcode-master-table-size
: nreserved ( fcode-table-ptr first last xt -- )
-rot 1+ swap do
2dup swap i cells + !
loop
2drop
;
:noname
800 cells alloc-mem to fcode-sys-table
fcode-sys-table
dup 0 5ff ['] reserved-fcode nreserved \ built-in fcodes
dup 600 7ff ['] undefined-fcode nreserved \ vendor fcodes
\ copy built-in fcodes
fcode-master-table swap fcode-master-table-size move
; initializer
: (init-fcode-table) ( -- )
fcode-sys-table fcode-table 800 cells move
\ clear local fcodes
fcode-table 800 fff ['] undefined-fcode nreserved
;
['] (init-fcode-table) to init-fcode-table

256
forth/device/terminal.fs Normal file
View File

@@ -0,0 +1,256 @@
\ tag: terminal emulation
\
\ this code implements IEEE 1275-1994 ANNEX B
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
0 value (escseq)
10 buffer: (sequence)
: (match-number) ( x y [1|2] [1|2] -- x [z] )
2dup = if \ 1 1 | 2 2
drop exit
then
2dup > if
2drop drop 1 exit
then
2drop 0
;
: (esc-number) ( maxchar -- ?? ?? num )
>r depth >r ( R: depth maxchar )
0 (sequence) 2+ (escseq) 2- ( 0 seq+2 seqlen-2 )
\ if numerical, scan until non-numerical
0 ?do
( 0 seq+2 )
dup i + c@ a
digit if
( 0 ptr n )
rot a * + ( ptr val )
swap
else
( 0 ptr asc )
ascii ; = if
0 swap
else
drop leave
then
then
loop
depth r> - r>
0 to (escseq)
(match-number)
;
: (match-seq)
(escseq) 1- (sequence) + c@ \ get last character in sequence
\ dup draw-character
case
ascii A of \ CUU - cursor up
1 (esc-number)
0> if
1 max
else
1
then
negate line# +
0 max to line#
endof
ascii B of \ CUD - cursor down
1 (esc-number)
0> if
1 max
line# +
#lines 1- min to line#
then
endof
ascii C of \ CUF - cursor forward
1 (esc-number)
0> if
1 max
column# +
#columns 1- min to column#
then
endof
ascii D of \ CUB - cursor backward
1 (esc-number)
0> if
1 max
negate column# +
0 max to column#
then
endof
ascii E of \ Cursor next line (CNL)
\ FIXME - check agains ANSI3.64
1 (esc-number)
0> if
1 max
line# +
#lines 1- min to line#
then
0 to column#
endof
ascii f of
2 (esc-number)
2 = if
#columns 1- min to column#
#lines 1- min to line#
then
endof
ascii H of
2 (esc-number)
2 = if
#columns 1- min to column#
#lines 1- min to line#
then
endof
ascii J of
0 to (escseq)
#columns column# - delete-characters
#lines line# - delete-lines
endof
ascii K of
0 to (escseq)
#columns column# - delete-characters
endof
ascii L of
1 (esc-number)
0> if
1 max
insert-lines
then
endof
ascii M of
1 (esc-number)
1 = if
1 max
delete-lines
then
endof
ascii @ of
1 (esc-number)
1 = if
1 max
insert-characters
then
endof
ascii P of
1 (esc-number)
1 = if
1 max
delete-characters
then
endof
ascii m of
1 (esc-number)
1 = if
7 = if
true to inverse?
else
false to inverse?
then
then
endof
ascii p of \ normal text colors
0 to (escseq)
inverse-screen? if
false to inverse-screen?
inverse? 0= to inverse?
invert-screen
then
endof
ascii q of \ inverse text colors
0 to (escseq)
inverse-screen? not if
true to inverse-screen?
inverse? 0= to inverse?
invert-screen
then
endof
ascii s of
\ Resets the display device associated with the terminal emulator.
0 to (escseq)
reset-screen
endof
endcase
;
: (term-emit) ( char -- )
toggle-cursor
(escseq) 0> if
(escseq) 10 = if
0 to (escseq)
." overflow in esc" cr
drop
then
(escseq) 1 = if
dup ascii [ = if \ not a [
(sequence) 1+ c!
2 to (escseq)
else
0 to (escseq) \ break out of ESC sequence
." out of ESC" cr
drop \ don't print breakout character
then
toggle-cursor exit
else
(sequence) (escseq) + c!
(escseq) 1+ to (escseq)
(match-seq)
toggle-cursor exit
then
then
case
7 of \ BEL
blink-screen
s" /screen" s" ring-bell"
execute-device-method
endof
8 of \ BS
column# 0<> if
column# 1- dup
to column#
20 draw-character
to column#
then
endof
9 of \ TAB
column# dup #columns = if
drop
else
8 + -8 and ff and to column#
then
endof
a of \ LF
line# 1+ to line# 0 to column#
endof
b of \ VT
line# 0<> if
line# 1- to line#
then
endof
c of \ FF
0 to column# 0 to line#
erase-screen
endof
d of \ CR
0 to column#
endof
1b of \ ESC
1b (sequence) c!
1 to (escseq)
endof
dup draw-character
endcase
toggle-cursor
;
['] (term-emit) to fb-emit

72
forth/device/tree.fs Normal file
View File

@@ -0,0 +1,72 @@
\ tag: Device Tree
\
\ this code implements IEEE 1275-1994 ch. 3.5
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ root node
new-device
" OpenBiosTeam,OpenBIOS" device-name
1 encode-int " #address-cells" property
external
: open true ;
: close ;
: decode-unit parse-hex ;
: encode-unit ( addr -- str len )
pocket tohexstr
;
new-device
" aliases" device-name
external
: open true ;
: close ;
finish-device
new-device
" openprom" device-name
" BootROM" device-type
" OpenFirmware 3" model
0 0 " relative-addressing" property
0 0 " supports-bootinfo" property
1 encode-int " boot-syntax" property
external
: selftest
." OpenBIOS selftest... succeded" cr
true
;
: open true ;
: close ;
new-device
" client-services" device-name
: open true ;
: close ;
finish-device
finish-device
new-device
" options" device-name
finish-device
new-device
" chosen" device-name
0 encode-int " stdin" property
0 encode-int " stdout" property
\ " hda1:/boot/vmunix" encode-string " bootpath" property
\ " -as" encode-string " bootargs" property
0 encode-int " memory" property
0 encode-int " mmu" property
external
finish-device
\ END
finish-device

20
forth/lib/build.xml Normal file
View File

@@ -0,0 +1,20 @@
<build>
<!--
build description for openbios forth library functions
Copyright (C) 2003-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="vocabulary.fs"/>
<object source="string.fs"/>
<object source="preprocessor.fs"/>
<object source="preinclude.fs" /> <!-- FIXME dependencies -->
<object source="creation.fs"/>
<object source="split.fs"/>
<object source="lists.fs"/>
</dictionary>
</build>

52
forth/lib/creation.fs Normal file
View File

@@ -0,0 +1,52 @@
\ tag: misc useful functions
\
\ C bindings
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ return xt of the word just defined
: last-xt ( -- xt )
latest @ na1+
;
\ -------------------------------------------------------------------------
\ word creation
\ -------------------------------------------------------------------------
: $is-ibuf ( size name name-len -- xt )
instance $buffer: drop
last-xt
;
: is-ibuf ( size -- xt )
0 0 $is-ibuf
;
: is-ivariable ( size name len -- xt )
4 -rot instance $buffer: drop
last-xt
;
: is-xt-func ( xt|0 wordstr len )
header 1 ,
?dup if , then
['] (semis) , reveal
;
: is-2xt-func ( xt1 xt2 wordstr len )
header 1 ,
swap , ,
['] (semis) , reveal
;
: is-func-begin ( wordstr len )
header 1 ,
;
: is-func-end ( wordstr len )
['] (semis) , reveal
;

26
forth/lib/lists.fs Normal file
View File

@@ -0,0 +1,26 @@
\ tag: misc useful functions
\
\ Misc useful functions
\
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ -------------------------------------------------------------------------
\ statically allocated lists
\ -------------------------------------------------------------------------
\ list-head should be a variable
: list-add ( listhead -- )
here 0 , swap \ next, [data...]
( here listhead )
begin dup @ while @ repeat !
;
: list-get ( listptr -- nextlistptr dictptr true | false )
@ dup if
dup na1+ true
then
;

11
forth/lib/preinclude.fs Normal file
View File

@@ -0,0 +1,11 @@
\
\ config and build date includes
\
\ Copyright (C) 2005 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
include config.fs
include version.fs

75
forth/lib/preprocessor.fs Normal file
View File

@@ -0,0 +1,75 @@
\ tag: Forth preprocessor
\
\ Forth preprocessor
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
0 value prep-wid
0 value prep-dict
0 value prep-here
: ([IF])
begin
begin parse-word dup 0= while
2drop refill
repeat
2dup " [IF]" strcmp 0= if 1 throw then
2dup " [ELSE]" strcmp 0= if 2 throw then
2dup " [THEN]" strcmp 0= if 3 throw then
" \\" strcmp 0= if linefeed parse 2drop then
again
;
: [IF] ( flag -- )
if exit then
1 begin
['] ([IF]) catch case
\ EOF (FIXME: this does not work)
\ -1 of ." Missing [THEN]" abort exit endof
\ [IF]
1 of 1+ endof
\ [ELSE]
2 of dup 1 = if 1- then endof
\ [THEN]
3 of 1- endof
endcase
dup 0 <=
until drop
; immediate
: [ELSE] 0 [ ['] [IF] , ] ; immediate
: [THEN] ; immediate
:noname
0 to prep-wid
0 to prep-dict
; initializer
: [IFDEF] ( <word> -- )
prep-wid if
parse-word prep-wid search-wordlist dup if nip then
else 0 then
[ ['] [IF] , ]
; immediate
: [DEFINE] ( <word> -- )
parse-word here get-current >r >r
prep-dict 0= if
2000 alloc-mem here!
here to prep-dict
wordlist to prep-wid
here to prep-here
then
prep-wid set-current prep-here here!
$create
here to prep-here
r> r> set-current here!
; immediate
: [0] 0 ; immediate
: [1] 1 ; immediate

49
forth/lib/split.fs Normal file
View File

@@ -0,0 +1,49 @@
\ implements split-before, split-after and left-split
\ as described in 4.3 (Path resolution)
\ delimeter returned in R-string
: split-before ( addr len delim -- addr-R len-R addr-L len-L )
0 rot dup >r 0 ?do
( str char cnt R: len <sys> )
2 pick over + c@ 2 pick = if leave then
1+
loop
nip
2dup + r> 2 pick -
2swap
;
\ delimeter returned in L-string
: split-after ( addr len delim -- addr-R len-R addr-L len-L )
over 1- rot dup >r 0 ?do
( str char cnt R: len <sys> )
2 pick over + c@ 2 pick = if leave then
1-
loop
nip
dup 0 >= if 1+ else drop r@ then
2dup + r> 2 pick -
2swap
;
\ delimiter not returned
: left-split ( addr len delim -- addr-R len-R addr-L len-L )
0 rot dup >r 0 ?do
( str char cnt R: len <sys> )
2 pick i + c@ 2 pick = if leave then
1+
loop
nip
2dup + 1+ r> 2 pick -
dup if 1- then
2swap
;
\ delimiter not returned [THIS FUNCTION IS NOT NEEDED]
: right-split ( addr len delim -- addr-R len-R addr-L len-L )
dup >r
split-after
dup if 2dup + 1-
c@ r@ = if 1- then then
r> drop
;

127
forth/lib/string.fs Normal file
View File

@@ -0,0 +1,127 @@
\ tag: misc useful functions
\
\ Misc useful functions
\
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ compare c-string with (str len) pair
: comp0 ( cstr str len -- 0|-1|1 )
3dup
comp ?dup if >r 3drop r> exit then
nip + c@ 0<> if 1 else 0 then
;
\ returns 0 if the strings match
: strcmp ( str1 len1 str2 len2 -- 0|1 )
rot over <> if 3drop 1 exit then
comp if 1 else 0 then
;
: strchr ( str len char -- where|0 )
>r
begin
1- dup 0>=
while
( str len )
over c@ r@ = if r> 2drop exit then
swap 1+ swap
repeat
r> 3drop 0
;
: cstrlen ( cstr -- len )
dup
begin dup c@ while 1+ repeat
swap -
;
: strdup ( str len -- newstr len )
dup if
dup >r
dup alloc-mem dup >r swap move
r> r>
else
2drop 0 0
then
;
: dict-strdup ( str len -- dict-addr len )
dup here swap allot null-align
swap 2dup >r >r move r> r>
;
\ -----------------------------------------------------
\ string copy and cat variants
\ -----------------------------------------------------
: tmpstrcat ( addr2 len2 addr1 len1 tmpbuf -- buf len1+len2 tmpbuf+l1+l2 )
\ save return arguments
dup 2 pick + 4 pick + >r ( R: buf+l1+l2 )
over 4 pick + >r
dup >r
\ copy...
2dup + >r
swap move r> swap move
r> r> r>
;
: tmpstrcpy ( addr1 len1 tmpbuf -- tmpbuf len1 tmpbuf+len1 )
swap 2dup >r >r move
r> r> 2dup +
;
\ -----------------------------------------------------
\ number to string conversion
\ -----------------------------------------------------
: numtostr ( num buf -- buf len )
swap rdepth -rot
( rdepth buf num )
begin
base @ u/mod swap
\ dup 0< if base @ + then
dup a < if ascii 0 else ascii a a - then + >r
?dup 0=
until
rdepth rot - 0
( buf len cnt )
begin
r> over 4 pick + c!
1+ 2dup <=
until
drop
;
: tohexstr ( num buf -- buf len )
base @ hex -rot numtostr rot base !
;
: toudecstr ( num buf -- buf len )
base @ decimal -rot numtostr rot base !
;
: todecstr ( num buf -- buf len )
over 0< if
swap negate over ascii - over c! 1+
( buf num buf+1 )
toudecstr 1+ nip
else
toudecstr
then
;
\ -----------------------------------------------------
\ string to number conversion
\ -----------------------------------------------------
: parse-hex ( str len -- value )
base @ hex -rot $number if 0 then swap base !
;

155
forth/lib/vocabulary.fs Normal file
View File

@@ -0,0 +1,155 @@
\ tag: vocabulary implementation for openbios
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\
\ this is an implementation of DPANS94 wordlists (SEARCH EXT)
\
16 constant #vocs
create vocabularies #vocs cells allot \ word lists
['] vocabularies to context
: search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 )
\ Find the definition identified by the string c-addr u in the word
\ list identified by wid. If the definition is not found, return zero.
\ If the definition is found, return its execution token xt and
\ one (1) if the definition is immediate, minus-one (-1) otherwise.
find-wordlist
if
true over immediate? if
negate
then
else
2drop false
then
;
: wordlist ( -- wid )
\ Creates a new empty word list, returning its word list identifier
\ wid. The new word list may be returned from a pool of preallocated
\ word lists or may be dynamically allocated in data space. A system
\ shall allow the creation of at least 8 new word lists in addition
\ to any provided as part of the system.
here 0 ,
;
: get-order ( -- wid1 .. widn n )
#order @ 0 ?do
#order @ i - 1- cells context + @
loop
#order @
;
: set-order ( wid1 .. widn n -- )
dup -1 = if
drop forth-last 1 \ push system default word list and number of lists
then
dup #order !
0 ?do
i cells context + !
loop
;
: order ( -- )
\ display word lists in the search order in their search order sequence
\ from the first searched to last searched. Also display word list into
\ which new definitions will be placed.
cr
get-order 0 ?do
." wordlist " i (.) type 2e emit space . cr
loop
cr ." definitions: " current @ . cr
;
: previous ( -- )
\ Transform the search order consisting of widn, ... wid2, wid1 (where
\ wid1 is searched first) into widn, ... wid2. An ambiguous condition
\ exists if the search order was empty before PREVIOUS was executed.
get-order nip 1- set-order
;
: do-vocabulary ( -- ) \ implementation factor
does>
@ >r ( ) ( R: widnew )
get-order swap drop ( wid1 ... widn-1 n )
r> swap set-order
;
: discard ( x1 .. xu u - ) \ implementation factor
0 ?do
drop
loop
;
: vocabulary ( >name -- )
wordlist create , do-vocabulary
;
: also ( -- )
get-order over swap 1+ set-order
;
: only ( -- )
-1 set-order also
;
only
\ create forth forth-wordlist , do-vocabulary
create forth get-order over , discard do-vocabulary
: findw ( c-addr -- c-addr 0 | w 1 | w -1 )
0 ( c-addr 0 )
#order @ 0 ?do
over count ( c-addr 0 c-addr' u )
i cells context + @ ( c-addr 0 c-addr' u wid )
search-wordlist ( c-addr 0; 0 | w 1 | w -1 )
?dup if ( c-addr 0; w 1 | w -1 )
2swap 2drop leave ( w 1 | w -1 )
then ( c-addr 0 )
loop ( c-addr 0 | w 1 | w -1 )
;
: get-current ( -- wid )
current @
;
: set-current ( wid -- )
current !
;
: definitions ( -- )
\ Make the compilation word list the same as the first word list in
\ the search order. Specifies that the names of subsequent definitions
\ will be placed in the compilation word list.
\ Subsequent changes in the search order will not affect the
\ compilation word list.
context @ set-current
;
: forth-wordlist ( -- wid )
forth-last
;
: #words ( -- )
0 last
begin
@ ?dup
while
swap 1+ swap
repeat
cr
;
true to vocabularies?

17
forth/packages/Kconfig Normal file
View File

@@ -0,0 +1,17 @@
config PKG_DEBLOCKER
bool "Deblocker"
default y
config PKG_DISKLABEL
bool "Disk Label"
default y
config PKG_OBP_TFTP
bool "OBP-TFTP"
default y
config PKG_TERMINAL_EMULATOR
bool "Terminal Emulator"
default y

12
forth/packages/README Normal file
View File

@@ -0,0 +1,12 @@
IEEE 1275-1994 support packages
-------------------------------
These files create the sub nodes of the /packages node. The nodes
do normally not need an open or close method since their methods are
called statically.
Currently there are the following support packages:
* deblocker
* obp-tftp
*

20
forth/packages/build.xml Normal file
View File

@@ -0,0 +1,20 @@
<build>
<!--
build description for Open Firmware support packages
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="packages.fs"/>
<object source="deblocker.fs" condition="PKG_DEBLOCKER"/>
<object source="disklabel.fs" condition="PKG_DISKLABEL"/>
<object source="terminal-emulator.fs" condition="PKG_TERM_EMUL"/>
<object source="obp-tftp.fs" condition="OBP_TFTP"/>
</dictionary>
</build>

64
forth/packages/deblocker.fs Normal file
View File

@@ -0,0 +1,64 @@
\ tag: deblocker support package
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
" /packages" find-device
\ The deblocker package makes it easy to implement byte-oriented device
\ methods, using the block-oriented or record-oriented methods defined by
\ devices such as disks or tapes. It provides a layer of buffering between
\ the high-level byte-oriented interface and the low-level block-oriented
\ interface. deblocker uses the max-transfer, block-size, read-blocks and
\ write-blocks methods of its parent.
new-device
" deblocker" device-name
external
\ open ( -- flag )
\ Prepares the package for subsequent use, allocating the buffers used
\ by the deblocking process based upon the values returned by the parent
\ instance's max-transfer and block-size methods. Returns -1 if the
\ operation succeeds, 0 otherwise.
: open ( -- flag )
;
\ close ( -- )
\ Frees all resources that were allocated by open.
: close ( -- )
;
\ read ( adr len -- actual )
\ Reads at most len bytes from the device into the memory buffer
\ beginning at adr. Returns actual, the number of bytes actually
\ read, or 0 if the read operation failed. Uses the parent's read-
\ blocks method as necessary to satisfy the request, buffering any
\ unused bytes for the next request.
: read ( adr len -- actual )
;
\ Writes at most len bytes from the device into the memory buffer
\ beginning at adr. Returns actual, the number of bytes actually
\ read, or 0 if the write operation failed. Uses the parent's write-
\ blocks method as necessary to satisfy the request, buffering any
\ unused bytes for the next request.
: write ( adr len -- actual )
;
\ Sets the device position at which the next read or write will take
\ place. The position is specified by the 64-bit number x.position.
\ Returns 0 if the operation succeeds or -1 if it fails.
: seek ( x.position -- flag )
;
finish-device
\ clean up afterwards
device-end

23
forth/packages/disklabel.fs Normal file
View File

@@ -0,0 +1,23 @@
\ tag: disklabel support package
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
" /packages" find-device
\
\ IEEE 1275 disklabel package
\
new-device
" disklabel" device-name
external
\ now the methods...
finish-device
\ clean up afterwards
device-end

23
forth/packages/obp-tftp.fs Normal file
View File

@@ -0,0 +1,23 @@
\ tag: tftp support package
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
" /packages" find-device
\
\ IEEE 1275 obp-tftp package
\
new-device
" obp-tftp" device-name
external
\ now the methods...
finish-device
\ clean up afterwards
device-end

18
forth/packages/packages.fs Normal file
View File

@@ -0,0 +1,18 @@
\ tag: /packages sub device tree
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
" /" find-device
new-device
" packages" device-name
external
: open true ;
: close ;
finish-device
device-end

25
forth/packages/terminal-emulator.fs Normal file
View File

@@ -0,0 +1,25 @@
\ tag: terminal emulator support package
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
" /packages" find-device
\
\ IEEE 1275 terminal-emulator package
\
new-device
" terminal-emulator" device-name
external
\ now the methods...
finish-device
\ clean up afterwards
device-end

16
forth/system/build.xml Normal file
View File

@@ -0,0 +1,16 @@
<build>
<!--
build description for openbios system bindings
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="main.fs"/>
<object source="ciface.fs"/>
</dictionary>
</build>

318
forth/system/ciface.fs Normal file
View File

@@ -0,0 +1,318 @@
0 value ciface-ph
dev /packages/
new-device
" client-iface" device-name
active-package to ciface-ph
\ -------------------------------------------------------------
\ private stuff
\ -------------------------------------------------------------
: ?phandle ( phandle -- phandle )
dup 0= if ." NULL phandle" -1 throw then
;
: ?ihandle ( ihandle -- ihandle )
dup 0= if ." NULL ihandle" -2 throw then
;
\ copy and null terminate return string
: ci-strcpy ( buf buflen str len -- len )
>r -rot dup
( str buf buflen buflen R: len )
r@ min swap
( str buf n buflen R: len )
over > if
( str buf n )
2dup + 0 swap c!
then
move r>
;
0 value memory-ih
0 value mmu-ih
:noname ( -- )
" /chosen" find-device
" mmu" active-package get-package-property 0= if
decode-int nip nip to mmu-ih
then
" memory" active-package get-package-property 0= if
decode-int nip nip to memory-ih
then
device-end
; SYSTEM-initializer
: safetype
." <" dup cstrlen dup 20 < if type else 2drop ." BAD" then ." >"
;
\ -------------------------------------------------------------
\ public interface
\ -------------------------------------------------------------
external
\ -------------------------------------------------------------
\ 6.3.2.1 Client interface
\ -------------------------------------------------------------
\ returns -1 if missing
: test ( name -- 0|-1 )
dup cstrlen ciface-ph find-method
if drop 0 else -1 then
;
\ -------------------------------------------------------------
\ 6.3.2.2 Device tree
\ -------------------------------------------------------------
: peer peer ;
: child child ;
: parent parent ;
: getproplen ( phandle name -- len|-1 )
\ ." PH " over . dup cstrlen ." GETPROPLEN " 2dup type cr
dup cstrlen
rot ?phandle get-package-property
if -1 else nip then
;
: getprop ( phandle name buf buflen -- size|-1 )
\ ." PH " 3 pick . ." GETPROP " 2 pick dup cstrlen type cr
>r >r dup cstrlen
rot
\ detect phandle == -1
dup -1 = if
r> r> 2drop 3drop -1 exit
then
\ return -1 if phandle is 0 (MacOS actually does this)
?dup 0= if r> r> 2drop 2drop -1 exit then
?phandle get-package-property if r> r> 2drop -1 exit then
r> r>
( prop proplen dest destlen )
rot dup >r min move r>
;
\ 1 OK, 0 no more prop, -1 prev invalid
: nextprop ( phandle prev buf -- 1|0|-1 )
rot >r
swap ( buf prev )
dup 0= if 0 else dup cstrlen then
( buf prev prev_len )
0 3 pick c!
\ verify that prev exists (overkill...)
dup if
2dup r@ get-package-property if
r> 2drop 2drop -1 exit
else
2drop
then
then
( buf prev prev_len )
r> next-property if
( buf name name_len )
dup 1+ -rot ci-strcpy drop 1
else
( buf )
drop 0
then
;
: setprop ( phandle name buf len -- size )
dup >r encode-bytes rot dup cstrlen
( phandle buf len name name_len R: size )
4 pick (property)
drop r>
;
: finddevice ( dev_spec -- phandle|-1 )
dup cstrlen
\ ." FIND-DEVICE " 2dup type
find-dev 0= if -1 then
\ ." -- " dup . cr
;
: instance-to-package ( ihandle -- phandle )
?ihandle ihandle>phandle
;
: package-to-path ( phandle buf buflen -- length )
rot
\ XXX improve error checking
dup 0= if 3drop -1 exit then
get-package-path
( buf buflen str len )
ci-strcpy
;
: canon ( dev_specifier buf buflen -- len )
rot dup cstrlen find-dev if
( buf buflen phandle )
-rot
package-to-path
else
2drop -1
then
;
: instance-to-path ( ihandle buf buflen -- length )
rot
\ XXX improve error checking
dup 0= if 3drop -1 exit then
get-instance-path
\ ." INSTANCE: " 2dup type cr dup .
( buf buflen str len )
ci-strcpy
;
: instance-to-interposed-path ( ihandle buf buflen -- length )
rot
\ XXX improve error checking
dup 0= if 3drop -1 exit then
get-instance-interposed-path
( buf buflen str len )
ci-strcpy
;
: call-method ( ihandle method -- xxxx catch-result )
dup 0= if ." call of null method" -1 exit then
dup >r
dup cstrlen
\ ." call-method " 2dup type cr
rot ?ihandle ['] $call-method catch dup if
\ not necessary an error but very useful for debugging...
." call-method " r@ dup cstrlen type ." : exception " dup . cr
then
r> drop
;
\ -------------------------------------------------------------
\ 6.3.2.3 Device I/O
\ -------------------------------------------------------------
: open ( dev_spec -- ihandle|0 )
dup cstrlen open-dev
;
: close ( ihandle -- )
close-dev
;
: read ( ihandle addr len -- actual )
rot dup ihandle>phandle " read" rot find-method
if swap call-package else 3drop -1 then
;
: write ( ihandle addr len -- actual )
rot dup ihandle>phandle " write" rot find-method
if swap call-package else 3drop -1 then
;
: seek ( ihandle pos_hi pos_lo -- status )
\ package methods uses ( pos_lo pos_hi -- status )
swap
rot dup ihandle>phandle " seek" rot find-method
if swap call-package else 3drop -1 then
;
\ -------------------------------------------------------------
\ 6.3.2.4 Memory
\ -------------------------------------------------------------
\ : claim ( virt size align -- baseaddr|-1 ) ;
\ : release ( virt size -- ) ;
\ -------------------------------------------------------------
\ 6.3.2.5 Control transfer
\ -------------------------------------------------------------
: boot ( bootspec -- )
." BOOT"
;
: enter ( -- )
." ENTER"
;
\ exit ( -- ) is defined later (clashes with builtin exit)
: chain ( virt size entry args len -- )
." CHAIN"
;
\ -------------------------------------------------------------
\ 6.3.2.6 User interface
\ -------------------------------------------------------------
: interpret ( xxx cmdstring -- ??? catch-reult )
dup cstrlen
\ ." INTERPRETE: --- " 2dup type
['] evaluate catch dup if
\ this is not necessary an error...
." interpret: exception " dup . ." caught" cr
then
\ ." --- " cr
;
\ : set-callback ( newfunc -- oldfunc ) ;
\ : set-symbol-lookup ( sym-to-value -- value-to-sym ) ;
\ -------------------------------------------------------------
\ 6.3.2.7 Time
\ -------------------------------------------------------------
\ : milliseconds ( -- ms ) ;
\ -------------------------------------------------------------
\ arch?
\ -------------------------------------------------------------
: start-cpu ( xxx xxx xxx --- )
." Start CPU unimplemented" cr
3drop
;
\ -------------------------------------------------------------
\ special
\ -------------------------------------------------------------
: exit ( -- )
." EXIT"
outer-interpreter
;
finish-device
device-end
\ -------------------------------------------------------------
\ entry point
\ -------------------------------------------------------------
: client-iface ( [args] name len -- [args] -1 | [rets] 0 )
ciface-ph find-method 0= if -1 exit then
catch ?dup if
cr ." Unexpected client interface exception: " . -2 cr exit
then
0
;
: client-call-iface ( [args] name len -- [args] -1 | [rets] 0 )
ciface-ph find-method 0= if -1 exit then
execute
;

60
forth/system/main.fs Normal file
View File

@@ -0,0 +1,60 @@
\ tag: misc useful functions
\
\ Open Firmware Startup
\
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
variable PREPOST-list
variable POST-list
variable SYSTEM-list
variable DIAG-list
: PREPOST-initializer ( xt -- )
PREPOST-list list-add ,
;
: POST-initializer ( xt -- )
POST-list list-add ,
;
: SYSTEM-initializer ( xt -- )
SYSTEM-list list-add ,
;
: DIAG-initializer ( xt -- )
DIAG-list list-add ,
;
\ OpenFirmware entrypoint
: initialize-of ( startmem endmem -- )
initialize-forth
PREPOST-list begin list-get while @ execute repeat
POST-list begin list-get while @ execute repeat
SYSTEM-list begin list-get while @ execute repeat
\ evaluate nvramrc script
use-nvramrc? if
nvramrc evaluate
then
\ probe-all etc.
suppress-banner? 0= if
probe-all
install-console
banner
then
DIAG-list begin list-get while @ execute repeat
auto-boot? if
boot-command evaluate
then
outer-interpreter
;

8
forth/testsuite/README Normal file
View File

@@ -0,0 +1,8 @@
TESTSUITES
----------
This directory contains additional testsuites for some open
firmware components. They are not built per default.
tag: testsuites readme

16
forth/testsuite/build.xml Normal file
View File

@@ -0,0 +1,16 @@
<build>
<!--
build description for OpenBIOS test suite
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="testsuite" target="forth">
<object source="memory-testsuite.fs"/>
<object source="splitfunc-testsuite.fs"/>
</dictionary>
</build>

36
forth/testsuite/fract.fs Normal file
View File

@@ -0,0 +1,36 @@
\ tag: forth fractal example
\
\ Copyright (C) 2002, 2003 Volker Poplawski <volker@poplawski.de>
\ Stefan Reinauer
\ This example even fits in a signature ;-)
\ hex 4666 dup negate do i 4000 dup 2* negate do 2a 0 dup 2dup 1e 0 do
\ 2swap * d >>a 4 pick + -rot - j + dup dup * e >>a rot dup dup * e >>a
\ rot swap 2dup + 10000 > if 3drop 2drop 20 0 dup 2dup leave then loop
\ 2drop 2drop type 268 +loop cr drop 5de +loop
: fract
4666 dup negate
do
i 4000 dup 2* negate
do
2a 0 dup 2dup 1e 0
do
2swap * d >>a 4 pick +
-rot - j +
dup dup * e >>a rot
dup dup * e >>a rot
swap
2dup + 10000 > if
3drop 2drop 20 0 dup 2dup leave
then
loop
2drop 2drop
emit
268 +loop
cr drop
5de +loop
;

13
forth/testsuite/framebuffer-test.fs Normal file
View File

@@ -0,0 +1,13 @@
: test-screen
10 10 pci-l@
f0 0 do
dup d# 1280 i * +
500 i fill
loop
;
test-screen

106
forth/testsuite/memory-testsuite.fs Normal file
View File

@@ -0,0 +1,106 @@
\ this is the memory management testsuite.
\
\ run it with paflof < memory-testsuite.fs 2>/dev/null
s" memory.fs" included
\ dumps all free-list entries
\ useful for debugging.
: dump-freelist ( -- )
." Dumping freelist:" cr
free-list @
\ If the free list is empty we notify the user.
dup 0= if ." empty." drop cr exit then
begin dup 0<> while
dup ." entry 0x" . \ print pointer to entry
dup cell+ @ ." , next=0x" u. \ pointer to next entry
dup @ ." , size=0x" u. cr \ len of current entry
cell+ @
repeat
cr drop
;
\ simple testsuite. run testsuite-init to initialize
\ with some dummy memory in the dictionary.
\ run testsuite-test[1..3] for different tests.
: testsuite-init ( -- )
here 40000 cell+ dup allot ( -- ptr len )
init-mem
." start-mem = 0x" start-mem @ . cr
." end-mem = 0x" end-mem @ . cr
." free-list = 0x" free-list @ . cr
." Memory management initialized." cr
dump-freelist
;
: testsuite-test1 ( -- )
." Test No. 1: Allocating all available memory (256k)" cr
40000 alloc-mem
dup 0<> if
." worked, ptr=0x" dup .
else
." did not work."
then
cr
dump-freelist
." Freeing memory." cr
." stack=" .s cr
free-mem
dump-freelist
;
: testsuite-test2 ( -- )
." Test No. 2: Allocating 5 blocks" cr
4000 alloc-mem
4000 alloc-mem
4000 alloc-mem
4000 alloc-mem
4000 alloc-mem
." Allocated 5 blocks. Stack:" cr .s cr
dump-freelist
." Freeing Block 2" cr
3 pick free-mem dump-freelist
." Freeing Block 4" cr
over free-mem dump-freelist
." Freeing Block 3" cr
2 pick free-mem dump-freelist
." Cleaning up blocks 1 and 5" cr
free-mem \ Freeing block 5
dump-freelist
3drop \ blocks 4, 3, 2
free-mem
dump-freelist
;
: testsuite-test3 ( -- )
." Test No. 3: freeing illegal address 0xdeadbeef." cr
deadbeef free-mem
dump-freelist
;
: testsuite ( -- )
testsuite-init
testsuite-test1
testsuite-test2
testsuite-test3
;
testsuite
bye

38
forth/testsuite/splitfunc-testsuite.fs Normal file
View File

@@ -0,0 +1,38 @@
\ this is the splitfunc testsuite.
\
\ run it with paflof < splitfunc-testsuite.fs 2>/dev/null
\ implements split-before, split-after and left-split
\ as described in 4.3 (Path resolution)
s" splitfunc.fs" included
: test-split
s" var/log/messages" 2dup
cr ." split-before test:" cr
2dup ." String: " type cr
2f split-before
2swap
." initial: " type cr ." remainder:" type cr
cr
." split-after test:" cr
2f split-after cr
2swap
." initial: " type cr ." remainder:" type cr
." foobar test" cr
s" foobar" 2dup
2f split-after cr
2swap
." initial: " type cr ." remainder:" type cr
2f split-after cr
2swap
." initial: " type cr ." remainder:" type cr
;

62
forth/util/apic.fs Normal file
View File

@@ -0,0 +1,62 @@
\
\ ioapic and local apic tester
\
\ Copyright (C) 2003 Stefan Reinauer
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
hex
fee00000 constant lapic_base
fec00000 constant ioapic_base
: read_lapic ( regoffset -- value )
lapic_base + l@
;
: write_lapic ( value regoffset -- )
lapic_base + l!
;
: read_ioapic ( regoffset -- low_value high_value )
2* 10 + dup
ioapic_base l! ioapic_base 4 cells + l@
swap 1+
ioapic_base l! ioapic_base 4 cells + l@
;
: write_ioapic ( low high regoffset -- )
2* 10 + dup ( low high offs offs )
ioapic_base l! rot ioapic_base 4 cells + l! ( high offs )
1+
ioapic_base l! ioapic_base 4 cells + l! ( high offs )
;
: test-lapic
s" Dumping local apic:" type cr
3f0 0 do
i dup ( lapic_base + ) s" 0x" type . s" = 0x" type read_lapic space .
i 30 and 0= if cr then
10 +loop
cr
;
: test-ioapic
s" Dumping io apic:" type cr
17 0 do
i dup s" irq=" type . read_ioapic s" = 0x" type . s" ." type .
i 1 and 0<> if
cr
then
loop
cr
;
: dump-apics
test-lapic
test-ioapic
;
\ tag: apic test utility

19
forth/util/build.xml Normal file
View File

@@ -0,0 +1,19 @@
<build>
<!--
build description for OpenBIOS utility functions
Copyright (C) 2004-2005 by Stefan Reinauer
See the file "COPYING" for further information about
the copyright and warranty status of this work.
-->
<dictionary name="openbios" target="forth">
<object source="util.fs"/>
<object source="pci.fs"/>
<!-- We don't want/need these at the moment
<object source="apic.fs"/>
-->
</dictionary>
</build>

127
forth/util/pci.fs Normal file
View File

@@ -0,0 +1,127 @@
\ tag: PCI helper functions
\
\ Copyright (C) 2003-2004 Stefan Reinauer
\ Copyright (C) 2003 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ simple set of words for pci access, these are not
\ compliant to the PCI bus binding of OpenFirmware.
\ only forth
\ vocabulary pci
\ also pci definitions
hex
: busdevfn ( bus dev fn -- busdevfn )
7 and swap
1f and 3 << or ( dev fn -- devfn )
swap 8 << or ( bus devfn -- busdevfn )
;
: config-command ( busdevfn reg -- reg addr )
dup -rot
3 invert and
swap 8 << or
80000000 or
;
: pci-c@ ( busdevfn reg -- x )
config-command
cf8 iol!
3 and cfc +
ioc@
;
: pci-w@ ( busdevfn reg -- x )
config-command
cf8 iol!
2 and cfc + iow@
;
: pci-l@ ( busdevfn reg -- x )
config-command
cf8 iol!
drop
cfc iol@
;
: pci-c! ( busdevfn reg val -- )
-rot config-command
cf8 iol!
3 and cfc + ioc!
;
: pci-w! ( busdevfn reg val -- )
-rot config-command
cf8 iol!
2 and cfc + iow!
;
: pci-l! ( busdevfn reg val -- )
-rot config-command
cf8 iol!
drop
cfc iol!
;
: dump-pci-device ( bus dev fn -- )
2 pick (.) type 3a emit over
(.) type 2e emit dup (.) type 20 emit 5b emit \ 0:18.0 [
busdevfn >r
r@ 0 pci-w@ u. 2f emit r@ 2 pci-w@ u. 5d emit \ 1022/1100]
r>
\ now we iterate
10 0 do
cr i todigit emit 30 emit 3a emit 20 emit
10 0 do
dup i j 4 << or pci-c@
dup 4 >> todigit emit f and todigit emit
20 emit
loop
loop
drop
cr cr
;
\ : test-pci
\ 0 2 0 dump-pci-device
\ ;
\ only forth
\ -------------------------------------------------------------------------
\ PCI encode/decode unit
\ -------------------------------------------------------------------------
\ we only implement DD and DD,F
: encode-unit-pci ( phys.lo phy.mid phys.hi -- str len )
nip nip ff00 and 8 >> dup 3 >>
swap 7 and
( ddddd fff )
?dup if
pocket tohexstr
" ," pocket tmpstrcat
else
0 0 pocket tmpstrcpy
then
>r
rot pocket tohexstr r> tmpstrcat drop
;
: decode-unit-pci-bus ( str len bus -- phys.lo phys.mid phys.hi )
-rot ascii , left-split
( addr-R len-R addr-L len-L )
parse-hex b << f800 and
-rot parse-hex 8 << 700 and
or
( bus phys.hi )
swap ff and 10 << or
0 0 rot
;

95
forth/util/util.fs Normal file
View File

@@ -0,0 +1,95 @@
\ tag: Utility functions
\
\ Utility functions
\
\ Copyright (C) 2003, 2004 Samuel Rydh
\
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\
\ -------------------------------------------------------------------------
\ package utils
\ -------------------------------------------------------------------------
( method-str method-len package-str package-len -- xt|0 )
: $find-package-method
find-package 0= if 2drop false exit then
find-method 0= if 0 then
;
\ like $call-parent but takes an xt
: call-parent ( ... xt -- ??? )
my-parent call-package
;
: [active-package],
['] (lit) , active-package ,
; immediate
\ -------------------------------------------------------------------------
\ word creation
\ -------------------------------------------------------------------------
: ?mmissing ( name len -- 1 name len | 0 )
2dup active-package find-method
if 3drop false else true then
;
\ install trivial open and close functions
: is-open ( -- )
" open" ?mmissing if ['] true -rot is-xt-func then
" close" ?mmissing if 0 -rot is-xt-func then
;
\ is-relay installs a relay function (a function that calls
\ a function with the same name but belonging to a different node).
\ The execution behaviour of xt should be ( -- ptr-to-ihandle ).
\
: is-relay ( xt ph name-str name-len -- )
rot >r 2dup r> find-method 0= if
\ function missing (not necessarily an error)
3drop exit
then
-rot is-func-begin
( xt method-xt )
['] (lit) , , \ ['] method
, ['] @ , \ xt @
['] call-package , \ call-package
is-func-end
;
\ -------------------------------------------------------------------------
\ install deblocker bindings
\ -------------------------------------------------------------------------
: (open-deblocker) ( varaddr -- )
" deblocker" find-package if
0 0 rot open-package
else 0 then
swap !
;
: is-deblocker ( -- )
" deblocker" find-package 0= if exit then >r
" deblocker" is-ivariable
\ create open-deblocker
" open-deblocker" is-func-begin
dup , ['] (open-deblocker) ,
is-func-end
\ create close-deblocker
" close-deblocker" is-func-begin
dup , ['] @ , ['] close-package ,
is-func-end
( save-ph deblk-xt R: deblocker-ph )
r>
2dup " read" is-relay
2dup " seek" is-relay
2dup " write" is-relay
2dup " tell" is-relay
2drop
;