diff options
| author | fishsoupisgood <github@madingley.org> | 2019-04-29 01:17:54 +0100 |
|---|---|---|
| committer | fishsoupisgood <github@madingley.org> | 2019-05-27 03:43:43 +0100 |
| commit | 3f2546b2ef55b661fd8dd69682b38992225e86f6 (patch) | |
| tree | 65ca85f13617aee1dce474596800950f266a456c /roms/openbios/forth/device | |
| download | qemu-master.tar.gz qemu-master.tar.bz2 qemu-master.zip | |
Diffstat (limited to 'roms/openbios/forth/device')
21 files changed, 3938 insertions, 0 deletions
diff --git a/roms/openbios/forth/device/README.device b/roms/openbios/forth/device/README.device new file mode 100644 index 00000000..0d4d6e58 --- /dev/null +++ b/roms/openbios/forth/device/README.device @@ -0,0 +1,22 @@ +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> diff --git a/roms/openbios/forth/device/build.xml b/roms/openbios/forth/device/build.xml new file mode 100644 index 00000000..11544964 --- /dev/null +++ b/roms/openbios/forth/device/build.xml @@ -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> diff --git a/roms/openbios/forth/device/builtin.fs b/roms/openbios/forth/device/builtin.fs new file mode 100644 index 00000000..aaefba87 --- /dev/null +++ b/roms/openbios/forth/device/builtin.fs @@ -0,0 +1,30 @@ +\ 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 + : open true ; + : close ; + +new-device + " console" device-name + : 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! diff --git a/roms/openbios/forth/device/device.fs b/roms/openbios/forth/device/device.fs new file mode 100644 index 00000000..562c9196 --- /dev/null +++ b/roms/openbios/forth/device/device.fs @@ -0,0 +1,202 @@ +\ 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 public wordlist + external + 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) +; + +\ fini /**CFile****************************************************************
FileName [aigUtil.c]
SystemName [ABC: Logic synthesis and verification system.]
PackageName [AIG package.]
Synopsis [Various procedures.]
Author [Alan Mishchenko]
Affiliation [UC Berkeley]
Date [Ver. 1.0. Started - April 28, 2007.]
Revision [$Id: aigUtil.c,v 1.00 2007/04/28 00:00:00 alanmi Exp $]
***********************************************************************/
#include "aig.h"
////////////////////////////////////////////////////////////////////////
/// DECLARATIONS ///
////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////
/// FUNCTION DEFINITIONS ///
////////////////////////////////////////////////////////////////////////
/**Function********************************************************************
Synopsis [Returns the next prime >= p.]
Description [Copied from CUDD, for stand-aloneness.]
SideEffects [None]
SeeAlso []
******************************************************************************/
unsigned int Aig_PrimeCudd( unsigned int p )
{
int i,pn;
p--;
do {
p++;
if (p&1) {
pn = 1;
i = 3;
while ((unsigned) (i * i) <= p) {
if (p % i == 0) {
pn = 0;
break;
}
i += 2;
}
} else {
pn = 0;
}
} while (!pn);
return(p);
} /* end of Cudd_Prime */
/**Function*************************************************************
Synopsis [Increments the current traversal ID of the network.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ManIncrementTravId( Aig_Man_t * p )
{
if ( p->nTravIds >= (1<<30)-1 )
Aig_ManCleanData( p );
p->nTravIds++;
}
/**Function*************************************************************
Synopsis [Collect the latches.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
int Aig_ManLevels( Aig_Man_t * p )
{
Aig_Obj_t * pObj;
int i, LevelMax = 0;
Aig_ManForEachPo( p, pObj, i )
LevelMax = AIG_MAX( LevelMax, (int)Aig_ObjFanin0(pObj)->Level );
return LevelMax;
}
/**Function*************************************************************
Synopsis [Cleans the data pointers for the nodes.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ManCleanData( Aig_Man_t * p )
{
Aig_Obj_t * pObj;
int i;
Aig_ManForEachObj( p, pObj, i )
pObj->pData = NULL;
}
/**Function*************************************************************
Synopsis [Recursively cleans the data pointers in the cone of the node.]
Description [Applicable to small AIGs only because no caching is performed.]
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ObjCleanData_rec( Aig_Obj_t * pObj )
{
assert( !Aig_IsComplement(pObj) );
assert( !Aig_ObjIsPo(pObj) );
if ( Aig_ObjIsAnd(pObj) )
{
Aig_ObjCleanData_rec( Aig_ObjFanin0(pObj) );
Aig_ObjCleanData_rec( Aig_ObjFanin1(pObj) );
}
pObj->pData = NULL;
}
/**Function*************************************************************
Synopsis [Detects multi-input gate rooted at this node.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ObjCollectMulti_rec( Aig_Obj_t * pRoot, Aig_Obj_t * pObj, Vec_Ptr_t * vSuper )
{
if ( pRoot != pObj && (Aig_IsComplement(pObj) || Aig_ObjIsPi(pObj) || Aig_ObjType(pRoot) != Aig_ObjType(pObj)) )
{
Vec_PtrPushUnique(vSuper, pObj);
return;
}
Aig_ObjCollectMulti_rec( pRoot, Aig_ObjChild0(pObj), vSuper );
Aig_ObjCollectMulti_rec( pRoot, Aig_ObjChild1(pObj), vSuper );
}
/**Function*************************************************************
Synopsis [Detects multi-input gate rooted at this node.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ObjCollectMulti( Aig_Obj_t * pRoot, Vec_Ptr_t * vSuper )
{
assert( !Aig_IsComplement(pRoot) );
Vec_PtrClear( vSuper );
Aig_ObjCollectMulti_rec( pRoot, pRoot, vSuper );
}
/**Function*************************************************************
Synopsis [Returns 1 if the node is the root of MUX or EXOR/NEXOR.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
int Aig_ObjIsMuxType( Aig_Obj_t * pNode )
{
Aig_Obj_t * pNode0, * pNode1;
// check that the node is regular
assert( !Aig_IsComplement(pNode) );
// if the node is not AND, this is not MUX
if ( !Aig_ObjIsAnd(pNode) )
return 0;
// if the children are not complemented, this is not MUX
if ( !Aig_ObjFaninC0(pNode) || !Aig_ObjFaninC1(pNode) )
return 0;
// get children
pNode0 = Aig_ObjFanin0(pNode);
pNode1 = Aig_ObjFanin1(pNode);
// if the children are not ANDs, this is not MUX
if ( !Aig_ObjIsAnd(pNode0) || !Aig_ObjIsAnd(pNode1) )
return 0;
// otherwise the node is MUX iff it has a pair of equal grandchildren
return (Aig_ObjFanin0(pNode0) == Aig_ObjFanin0(pNode1) && (Aig_ObjFaninC0(pNode0) ^ Aig_ObjFaninC0(pNode1))) ||
(Aig_ObjFanin0(pNode0) == Aig_ObjFanin1(pNode1) && (Aig_ObjFaninC0(pNode0) ^ Aig_ObjFaninC1(pNode1))) ||
(Aig_ObjFanin1(pNode0) == Aig_ObjFanin0(pNode1) && (Aig_ObjFaninC1(pNode0) ^ Aig_ObjFaninC0(pNode1))) ||
(Aig_ObjFanin1(pNode0) == Aig_ObjFanin1(pNode1) && (Aig_ObjFaninC1(pNode0) ^ Aig_ObjFaninC1(pNode1)));
}
/**Function*************************************************************
Synopsis [Recognizes what nodes are inputs of the EXOR.]
Description []
SideEffects []
SeeAlso []
***********************************************************************/
int Aig_ObjRecognizeExor( Aig_Obj_t * pObj, Aig_Obj_t ** ppFan0, Aig_Obj_t ** ppFan1 )
{
Aig_Obj_t * p0, * p1;
assert( !Aig_IsComplement(pObj) );
if ( !Aig_ObjIsNode(pObj) )
return 0;
if ( Aig_ObjIsExor(pObj) )
{
*ppFan0 = Aig_ObjChild0(pObj);
*ppFan1 = Aig_ObjChild1(pObj);
return 1;
}
assert( Aig_ObjIsAnd(pObj) );
p0 = Aig_ObjChild0(pObj);
p1 = Aig_ObjChild1(pObj);
if ( !Aig_IsComplement(p0) || !Aig_IsComplement(p1) )
return 0;
p0 = Aig_Regular(p0);
p1 = Aig_Regular(p1);
if ( !Aig_ObjIsAnd(p0) || !Aig_ObjIsAnd(p1) )
return 0;
if ( Aig_ObjFanin0(p0) != Aig_ObjFanin0(p1) || Aig_ObjFanin1(p0) != Aig_ObjFanin1(p1) )
return 0;
if ( Aig_ObjFaninC0(p0) == Aig_ObjFaninC0(p1) || Aig_ObjFaninC1(p0) == Aig_ObjFaninC1(p1) )
return 0;
*ppFan0 = Aig_ObjChild0(p0);
*ppFan1 = Aig_ObjChild1(p0);
return 1;
}
/**Function*************************************************************
Synopsis [Recognizes what nodes are control and data inputs of a MUX.]
Description [If the node is a MUX, returns the control variable C.
Assigns nodes T and E to be the then and else variables of the MUX.
Node C is never complemented. Nodes T and E can be complemented.
This function also recognizes EXOR/NEXOR gates as MUXes.]
SideEffects []
SeeAlso []
***********************************************************************/
Aig_Obj_t * Aig_ObjRecognizeMux( Aig_Obj_t * pNode, Aig_Obj_t ** ppNodeT, Aig_Obj_t ** ppNodeE )
{
Aig_Obj_t * pNode0, * pNode1;
assert( !Aig_IsComplement(pNode) );
assert( Aig_ObjIsMuxType(pNode) );
// get children
pNode0 = Aig_ObjFanin0(pNode);
pNode1 = Aig_ObjFanin1(pNode);
// find the control variable
if ( Aig_ObjFanin1(pNode0) == Aig_ObjFanin1(pNode1) && (Aig_ObjFaninC1(pNode0) ^ Aig_ObjFaninC1(pNode1)) )
{
// if ( Fraig_IsComplement(pNode1->p2) )
if ( Aig_ObjFaninC1(pNode0) )
{ // pNode2->p2 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild0(pNode1));//pNode2->p1);
*ppNodeE = Aig_Not(Aig_ObjChild0(pNode0));//pNode1->p1);
return Aig_ObjChild1(pNode1);//pNode2->p2;
}
else
{ // pNode1->p2 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild0(pNode0));//pNode1->p1);
*ppNodeE = Aig_Not(Aig_ObjChild0(pNode1));//pNode2->p1);
return Aig_ObjChild1(pNode0);//pNode1->p2;
}
}
else if ( Aig_ObjFanin0(pNode0) == Aig_ObjFanin0(pNode1) && (Aig_ObjFaninC0(pNode0) ^ Aig_ObjFaninC0(pNode1)) )
{
// if ( Fraig_IsComplement(pNode1->p1) )
if ( Aig_ObjFaninC0(pNode0) )
{ // pNode2->p1 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild1(pNode1));//pNode2->p2);
*ppNodeE = Aig_Not(Aig_ObjChild1(pNode0));//pNode1->p2);
return Aig_ObjChild0(pNode1);//pNode2->p1;
}
else
{ // pNode1->p1 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild1(pNode0));//pNode1->p2);
*ppNodeE = Aig_Not(Aig_ObjChild1(pNode1));//pNode2->p2);
return Aig_ObjChild0(pNode0);//pNode1->p1;
}
}
else if ( Aig_ObjFanin0(pNode0) == Aig_ObjFanin1(pNode1) && (Aig_ObjFaninC0(pNode0) ^ Aig_ObjFaninC1(pNode1)) )
{
// if ( Fraig_IsComplement(pNode1->p1) )
if ( Aig_ObjFaninC0(pNode0) )
{ // pNode2->p2 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild0(pNode1));//pNode2->p1);
*ppNodeE = Aig_Not(Aig_ObjChild1(pNode0));//pNode1->p2);
return Aig_ObjChild1(pNode1);//pNode2->p2;
}
else
{ // pNode1->p1 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild1(pNode0));//pNode1->p2);
*ppNodeE = Aig_Not(Aig_ObjChild0(pNode1));//pNode2->p1);
return Aig_ObjChild0(pNode0);//pNode1->p1;
}
}
else if ( Aig_ObjFanin1(pNode0) == Aig_ObjFanin0(pNode1) && (Aig_ObjFaninC1(pNode0) ^ Aig_ObjFaninC0(pNode1)) )
{
// if ( Fraig_IsComplement(pNode1->p2) )
if ( Aig_ObjFaninC1(pNode0) )
{ // pNode2->p1 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild1(pNode1));//pNode2->p2);
*ppNodeE = Aig_Not(Aig_ObjChild0(pNode0));//pNode1->p1);
return Aig_ObjChild0(pNode1);//pNode2->p1;
}
else
{ // pNode1->p2 is positive phase of C
*ppNodeT = Aig_Not(Aig_ObjChild0(pNode0));//pNode1->p1);
*ppNodeE = Aig_Not(Aig_ObjChild1(pNode1));//pNode2->p2);
return Aig_ObjChild1(pNode0);//pNode1->p2;
}
}
assert( 0 ); // this is not MUX
return NULL;
}
/**Function*************************************************************
Synopsis []
Description []
SideEffects []
SeeAlso []
***********************************************************************/
Aig_Obj_t * Aig_ObjReal_rec( Aig_Obj_t * pObj )
{
Aig_Obj_t * pObjNew, * pObjR = Aig_Regular(pObj);
if ( !Aig_ObjIsBuf(pObjR) )
return pObj;
pObjNew = Aig_ObjReal_rec( Aig_ObjChild0(pObjR) );
return Aig_NotCond( pObjNew, Aig_IsComplement(pObj) );
}
/**Function*************************************************************
Synopsis [Prints Eqn formula for the AIG rooted at this node.]
Description [The formula is in terms of PIs, which should have
their names assigned in pObj->pData fields.]
SideEffects []
SeeAlso []
***********************************************************************/
void Aig_ObjPrintEqn( FILE * pFile, Aig_Obj_t * pObj, Vec_Vec_t * vLevels, int Level )
{
Vec_Ptr_t * vSuper;
Aig_Obj_t * pFanin;
int fCompl, i;
// store the complemented attribute
fCompl = Aig_IsComplement(pObj);
pObj = Aig_Regular(pObj);
// constant case
if ( Aig_ObjIsConst1(pObj) )
{
fprintf( pFile, "%d", !fCompl );
return;
}
// PI case
if ( Aig_ObjIsPi(pObj) )
iv class='add'>+ ; 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 diff --git a/roms/openbios/forth/device/feval.fs b/roms/openbios/forth/device/feval.fs new file mode 100644 index 00000000..9e2773db --- /dev/null +++ b/roms/openbios/forth/device/feval.fs @@ -0,0 +1,100 @@ +\ 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# ) + \ Address + fcode-stream 1 - . ." : " + + \ Indicate if word is compiled + state @ 0<> if + ." (compile) " + then + 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 + + \ If we've executed incorrect FCode we may have reached the end of the FCode + \ program but still be in compile mode. Make sure that if this has happened + \ then we switch back to immediate mode to prevent internal OpenBIOS errors. + tmp-comp-depth @ -1 <> if + -1 tmp-comp-depth ! + tmp-comp-buf @ @ here! + 0 state ! + then +; + +: 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 + + s" fcode-debug?" evaluate if + depth r@ <> if + cr ." byte-load: warning stack overflow, diff " depth r@ - . cr + then + then + + r> depth! 3drop 3drop + + free-fcode-table + + \ restore state + fcode-pop-state +; diff --git a/roms/openbios/forth/device/font.fs b/roms/openbios/forth/device/font.fs new file mode 100644 index 00000000..7b742fac --- /dev/null +++ b/roms/openbios/forth/device/font.fs @@ -0,0 +1,17 @@ +\ 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. +\ + +0 value (romfont) +0 value (romfont-width) +0 value (romfont-height) + +\ encode-file romfont.bin +\ drop value (romfont-8x16) diff --git a/roms/openbios/forth/device/logo.fs b/roms/openbios/forth/device/logo.fs new file mode 100644 index 00000000..4db31ef5 --- /dev/null +++ b/roms/openbios/forth/device/logo.fs @@ -0,0 +1,98 @@ +\ 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) diff --git a/roms/openbios/forth/device/missing b/roms/openbios/forth/device/missing new file mode 100644 index 00000000..8ea954ed --- /dev/null +++ b/roms/openbios/forth/device/missing @@ -0,0 +1,38 @@ +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 diff --git a/roms/openbios/forth/device/other.fs b/roms/openbios/forth/device/other.fs new file mode 100644 index 00000000..b3900730 --- /dev/null +++ b/roms/openbios/forth/device/other.fs @@ -0,0 +1,233 @@ +\ 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. +\ + +\ The current diagnostic setting +defer _diag-switch? + + +\ +\ 5.3.7 Other FCode functions +\ + +hex + +\ 5.3.7.1 Peek/poke + +defer (peek) +:noname + execute true +; to (peek) + +: cpeek ( addr -- false | byte true ) + ['] c@ (peek) + ; + +: wpeek ( waddr -- false | w true ) + ['] w@ (peek) + ; + +: lpeek ( qaddr -- false | quad true ) + ['] l@ (peek) + ; + +defer (poke) +:noname + execute true +; to (poke) + +: cpoke ( byte addr -- okay? ) + ['] c! (poke) + ; + +: wpoke ( w waddr -- okay? ) + ['] w! (poke) + ; + +: lpoke ( quad qaddr -- okay? ) + ['] l! (poke) + ; + + +\ 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 -- ) + ; + +: rx@ ( oaddr - o ) + state @ if + h# 22e get-token if , else execute then + else + h# 22e get-token drop execute + then + ; immediate + +: rx! ( o oaddr -- ) + state @ if + h# 22f get-token if , else execute then + else + h# 22f get-token drop execute + then + ; immediate + +\ 5.3.7.3 Time + +\ Pointer to OBP tick value updated by timer interrupt +variable obp-ticks + +\ Dummy implementation for platforms without a timer interrupt +0 value dummy-msecs + +: get-msecs ( -- n ) + \ If obp-ticks pointer is set, use it. Otherwise fall back to + \ dummy implementation + obp-ticks @ 0<> if + obp-ticks @ + else + dummy-msecs dup 1+ to dummy-msecs + then + ; + +: ms ( n -- ) + get-msecs + + begin dup get-msecs < until + drop + ; + +: alarm ( xt n -- ) + 2drop + ; + +: 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? ) + \ Return the NVRAM diag-switch? setting + _diag-switch? + ; + +\ 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 ! + ; immediate + +\ 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 + ; diff --git a/roms/openbios/forth/device/package.fs b/roms/openbios/forth/device/package.fs new file mode 100644 index 00000000..d5b52c3e --- /dev/null +++ b/roms/openbios/forth/device/package.fs @@ -0,0 +1,287 @@ +\ 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 +: current-device 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>non-interposed-phandle ( ihandle -- phandle ) + begin dup >in.interposed @ while + >in.my-parent @ + repeat + >in.device-node @ +; + +: 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 ) + \ Assume phandle == 0 indicates root node (not documented but similar + \ behaviour to "peer"). Used by some versions of Solaris (e.g. 9). + ?dup if else device-tree @ then + + >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 + + 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 /l* + swap 1- 0 + ?do + /l - dup l@ 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 /l* + swap 0 ?do + /l - dup l@ 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 + ; + + +\ Deprecated functions (required for compatibility with older loaders) + +variable package-stack-pos 0 package-stack-pos ! +create package-stack 8 cells allot + +: push-package ( phandle -- ) + \ Throw an error if we attempt to push a full stack + package-stack-pos @ 8 >= if + ." cannot push-package onto full stack" cr + -99 throw + then + active-package + package-stack-pos @ /n * package-stack + ! + package-stack-pos @ 1 + package-stack-pos ! + active-package! + ; + +: pop-package ( -- ) + \ Throw an error if we attempt to pop an empty stack + package-stack-pos @ 0 = if + ." cannot pop-package from empty stack" cr + -99 throw + then + package-stack-pos @ 1 - package-stack-pos ! + package-stack-pos @ /n * package-stack + @ + active-package! + ; diff --git a/roms/openbios/forth/device/pathres.fs b/roms/openbios/forth/device/pathres.fs new file mode 100644 index 00000000..a185b95a --- /dev/null +++ b/roms/openbios/forth/device/pathres.fs @@ -0,0 +1,522 @@ +\ 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 @ /l* ?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 +\ + +\ used if package lacks a decode-unit method +: def-decode-unit ( str len -- unitaddr ... ) + parse-hex +; + +: get-decode-unit-xt ( phandle -- xt ) + " decode-unit" rot find-method + 0= if ['] def-decode-unit then +; + +: find-child ( sinfo -- phandle ) + >r + \ decode unit address string + r@ >si.unit_addr 2@ dup if + ( str len ) + active-package get-decode-unit-xt + 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 la1+ >r l!-be + repeat + r> 2drop + depth! + 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 diff --git a/roms/openbios/forth/device/preof.fs b/roms/openbios/forth/device/preof.fs new file mode 100644 index 00000000..131beacd --- /dev/null +++ b/roms/openbios/forth/device/preof.fs @@ -0,0 +1,49 @@ +\ 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 ; diff --git a/roms/openbios/forth/device/property.fs b/roms/openbios/forth/device/property.fs new file mode 100644 index 00000000..1d54e3ec --- /dev/null +++ b/roms/openbios/forth/device/property.fs @@ -0,0 +1,335 @@ +\ 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 +; + +\ HELPER: get #size-cells value (from parent) +: my-#scells ( -- #size-cells ) + my-self ?dup if >in.device-node @ else active-package then + ?dup if >dn.parent @ then + ?dup if + " #size-cells" rot get-package-property if 1 exit then + decode-int nip nip + else + 1 + 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 1- ( 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 + ; diff --git a/roms/openbios/forth/device/romfont.bin b/roms/openbios/forth/device/romfont.bin Binary files differnew file mode 100644 index 00000000..0b60b6fb --- /dev/null +++ b/roms/openbios/forth/device/romfont.bin diff --git a/roms/openbios/forth/device/structures.fs b/roms/openbios/forth/device/structures.fs new file mode 100644 index 00000000..14dd881e --- /dev/null +++ b/roms/openbios/forth/device/structures.fs @@ -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 diff --git a/roms/openbios/forth/device/table.fs b/roms/openbios/forth/device/table.fs new file mode 100644 index 00000000..5c58f2d9 --- /dev/null +++ b/roms/openbios/forth/device/table.fs @@ -0,0 +1,462 @@ +\ 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 + ['], push-package + ['], pop-package + ['], 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 + 4 n['], reserved-fcode \ 22a-22d +64bit? [IF] + ['], (rx@) + ['], (rx!) +[ELSE] + 2 n['], reserved-fcode \ 22e-22f +[THEN] + ['], 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 +64bit? [IF] + ['], bxjoin + ['], <l@ + ['], lxjoin + ['], wxjoin + ['], x, + ['], x@ + ['], x! + ['], /x + ['], /x* +\ ['], /xa+ +\ ['], /xa1+ + ['], xbflip + ['], xbflips + ['], xbsplit + ['], xlflip + ['], xlflips + ['], xlsplit + ['], xwflip + ['], xwflips + ['], xwsplit +[ELSE] + 7 n['], reserved-fcode \ 241-247 (Part of IEEE1275 64-bit draft standard) + ['], /x + c n['], reserved-fcode \ 249-254 (Part of IEEE1275 64-bit draft standard) +[THEN] + + +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 diff --git a/roms/openbios/forth/device/terminal.fs b/roms/openbios/forth/device/terminal.fs new file mode 100644 index 00000000..24b2d10c --- /dev/null +++ b/roms/openbios/forth/device/terminal.fs @@ -0,0 +1,302 @@ +\ 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) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + endof + ascii H of + 2 (esc-number) + case + 2 of + 1- #columns 1- min to column# + 1- #lines 1- min to line# + endof + 1 of + 0 to column# + 1- #lines 1- min to line# + endof + 0 of + 0 to column# + 0 to line# + drop + endof + endcase + 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 + 0 of \ NULL + toggle-cursor exit + endof + 7 of \ BEL + blink-screen + s" /screen" s" ring-bell" + execute-device-method + endof + 8 of \ BS + column# 0<> if + column# 1- to column# + toggle-cursor exit + then + endof + 9 of \ TAB + column# dup #columns = if + drop + else + 8 + -8 and ff and to column# + then + toggle-cursor exit + endof + a of \ LF + line# 1+ to line# + 0 to column# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + toggle-cursor exit + then + endof + b of \ VT + line# 0<> if + line# 1- to line# + then + toggle-cursor exit + endof + c of \ FF + 0 to column# 0 to line# + erase-screen + endof + d of \ CR + 0 to column# + toggle-cursor exit + endof + 1b of \ ESC + 1b (sequence) c! + 1 to (escseq) + endof + + \ draw character and advance position + column# #columns >= if + 0 to column# + line# 1+ to line# + line# #lines >= if + 0 to line# + 1 delete-lines + #lines 1- to line# + then + then + + dup draw-character + column# 1+ to column# + + endcase + toggle-cursor + ; + +['] (term-emit) to fb-emit diff --git a/roms/openbios/forth/device/tree.fs b/roms/openbios/forth/device/tree.fs new file mode 100644 index 00000000..04f85b5c --- /dev/null +++ b/roms/openbios/forth/device/tree.fs @@ -0,0 +1,59 @@ +\ 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 + : open true ; + : close ; + : decode-unit parse-hex ; + : encode-unit ( addr -- str len ) + pocket tohexstr + ; + +new-device + " aliases" device-name + : 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 + + : selftest + ." OpenBIOS selftest... succeded" cr + true + ; + : open true ; + : close ; + +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 +finish-device + +\ END +finish-device |
