Return to instance.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs

Annotation of qemu/roms/SLOF/slof/fs/instance.fs, revision 1.1

1.1     ! root        1: \ *****************************************************************************
        !             2: \ * Copyright (c) 2004, 2008 IBM Corporation
        !             3: \ * All rights reserved.
        !             4: \ * This program and the accompanying materials
        !             5: \ * are made available under the terms of the BSD License
        !             6: \ * which accompanies this distribution, and is available at
        !             7: \ * http://www.opensource.org/licenses/bsd-license.php
        !             8: \ *
        !             9: \ * Contributors:
        !            10: \ *     IBM Corporation - initial implementation
        !            11: \ ****************************************************************************/
        !            12: 
        !            13: 
        !            14: \ Support for device node instances.
        !            15: 
        !            16: 0 VALUE my-self
        !            17: 
        !            18: : >instance
        !            19:    my-self 0= ABORT" No instance!"
        !            20:    my-self +
        !            21: ;
        !            22: 
        !            23: : (create-instance-var) ( initial-value -- )
        !            24:    get-node ?dup 0= ABORT" Instance word outside device context!"
        !            25:    dup node>instance @      ( iv phandle tmp-ihandle )
        !            26:    swap node>instance-size dup @     ( iv tmp-ih *instance-size instance-size )
        !            27:    dup ,                             \ compile current instance ptr
        !            28:    swap 1 cells swap +!              ( iv tmp-ih instance-size )
        !            29:    + !
        !            30: ;
        !            31: 
        !            32: : create-instance-var ( "name" initial-value -- )
        !            33:   CREATE (create-instance-var) PREVIOUS ;
        !            34: 
        !            35: VOCABULARY instance-words  ALSO instance-words DEFINITIONS
        !            36: 
        !            37: : VARIABLE  0 create-instance-var DOES> @ >instance ;
        !            38: : VALUE       create-instance-var DOES> @ >instance @ ;
        !            39: : DEFER     0 create-instance-var DOES> @ >instance @ execute ;
        !            40: \ No support for BUFFER: yet.
        !            41: 
        !            42: PREVIOUS DEFINITIONS
        !            43: 
        !            44: \ check whether a value or a defer word is an
        !            45: \ instance word: It must be a CREATE word and
        !            46: \ the DOES> part must do >instance as first thing
        !            47: 
        !            48: : (instance?) ( xt -- xt true|false )
        !            49:    dup @ <create> = IF
        !            50:       dup cell+ @ cell+ @ ['] >instance =
        !            51:    ELSE
        !            52:       false
        !            53:    THEN
        !            54: ;
        !            55: 
        !            56: \ This word does instance values in compile mode.
        !            57: \ It corresponds to DOTO from engine.in
        !            58: : (doito) ( value R:*CFA -- )
        !            59:    r> cell+ dup >r
        !            60:    @ cell+ cell+ @ >instance !
        !            61: ;
        !            62: 
        !            63: : to ( value wordname<> -- )
        !            64:    ' (instance?)
        !            65:    state @ IF
        !            66:       \ compile mode handling normal or instance value
        !            67:       IF ['] (doito) ELSE ['] DOTO THEN
        !            68:       , , EXIT
        !            69:    THEN
        !            70:    IF
        !            71:       cell+ cell+ @ >instance ! \ interp mode instance value
        !            72:    ELSE
        !            73:       cell+ !                   \ interp mode normal value
        !            74:    THEN
        !            75: ; IMMEDIATE
        !            76: 
        !            77: : INSTANCE  ALSO instance-words ;
        !            78: 
        !            79: 
        !            80: STRUCT
        !            81: /n FIELD instance>node
        !            82: /n FIELD instance>parent
        !            83: /n FIELD instance>args
        !            84: /n FIELD instance>args-len
        !            85: CONSTANT /instance-header
        !            86: 
        !            87: : my-parent  my-self instance>parent @ ;
        !            88: : my-args    my-self instance>args 2@ ;
        !            89: 
        !            90: \ copy args from original instance to new created
        !            91: : set-my-args   ( old-addr len -- )
        !            92:    dup IF                             \ IF len > 0                    ( old-addr len )
        !            93:       dup alloc-mem                   \ | allocate space for new args ( old-addr len new-addr )
        !            94:       swap 2dup                       \ | write the new address       ( old-addr new-addr len new-addr len )
        !            95:       my-self instance>args 2!        \ | into the instance table     ( old-addr new-addr len )
        !            96:       move                            \ | and copy the args           ( -- )
        !            97:    ELSE                               \ ELSE                          ( old-addr len )
        !            98:       my-self instance>args 2!        \ | set new args to zero, too   ( )
        !            99:    THEN                               \ FI
        !           100: ;
        !           101: 
        !           102: \ Current node has already been set, when this is called.
        !           103: : create-instance-data ( -- instance )
        !           104:    get-node dup node>instance @ swap node>instance-size @  ( instance instance-size )
        !           105:    dup alloc-mem dup >r swap move r>
        !           106: ;
        !           107: : create-instance ( -- )
        !           108:    my-self create-instance-data
        !           109:    dup to my-self instance>parent !
        !           110:    get-node my-self instance>node !
        !           111: ;
        !           112: 
        !           113: : destroy-instance ( instance -- )
        !           114:    dup @ node>instance-size @ free-mem
        !           115: ;
        !           116: 
        !           117: : ihandle>phandle ( ihandle -- phandle )
        !           118:    dup 0= ABORT" no current instance" instance>node @
        !           119: ;
        !           120: 
        !           121: : push-my-self ( ihandle -- )  r> my-self >r >r to my-self ;
        !           122: : pop-my-self ( -- )  r> r> to my-self >r ;
        !           123: : call-package  push-my-self execute pop-my-self ;
        !           124: : $call-static ( ... str len node -- ??? )
        !           125: \  cr ." call for " 3dup -rot type ."  on node " .
        !           126:    find-method IF execute ELSE -1 throw THEN
        !           127: ;
        !           128: : $call-my-method  ( str len -- ) my-self ihandle>phandle $call-static ;
        !           129: : $call-method  push-my-self $call-my-method pop-my-self ;
        !           130: : $call-parent  my-parent $call-method ;

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.