aboutsummaryrefslogtreecommitdiffstats
path: root/roms/openbios/forth/device
diff options
context:
space:
mode:
authorfishsoupisgood <github@madingley.org>2019-04-29 01:17:54 +0100
committerfishsoupisgood <github@madingley.org>2019-05-27 03:43:43 +0100
commit3f2546b2ef55b661fd8dd69682b38992225e86f6 (patch)
tree65ca85f13617aee1dce474596800950f266a456c /roms/openbios/forth/device
downloadqemu-master.tar.gz
qemu-master.tar.bz2
qemu-master.zip
Initial import of qemu-2.4.1HEADmaster
Diffstat (limited to 'roms/openbios/forth/device')
-rw-r--r--roms/openbios/forth/device/README.device22
-rw-r--r--roms/openbios/forth/device/build.xml31
-rw-r--r--roms/openbios/forth/device/builtin.fs30
-rw-r--r--roms/openbios/forth/device/device.fs202
-rw-r--r--roms/openbios/forth/device/display.fs421
-rw-r--r--roms/openbios/forth/device/extra.fs103
-rw-r--r--roms/openbios/forth/device/fcode.fs573
-rw-r--r--roms/openbios/forth/device/feval.fs100
-rw-r--r--roms/openbios/forth/device/font.fs17
-rw-r--r--roms/openbios/forth/device/logo.fs98
-rw-r--r--roms/openbios/forth/device/missing38
-rw-r--r--roms/openbios/forth/device/other.fs233
-rw-r--r--roms/openbios/forth/device/package.fs287
-rw-r--r--roms/openbios/forth/device/pathres.fs522
-rw-r--r--roms/openbios/forth/device/preof.fs49
-rw-r--r--roms/openbios/forth/device/property.fs335
-rw-r--r--roms/openbios/forth/device/romfont.binbin0 -> 4096 bytes
-rw-r--r--roms/openbios/forth/device/structures.fs54
-rw-r--r--roms/openbios/forth/device/table.fs462
-rw-r--r--roms/openbios/forth/device/terminal.fs302
-rw-r--r--roms/openbios/forth/device/tree.fs59
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
new file mode 100644
index 00000000..0b60b6fb
--- /dev/null
+++ b/roms/openbios/forth/device/romfont.bin
Binary files differ
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