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.2

1.1       root        1: \ *****************************************************************************
1.1.1.2 ! root        2: \ * Copyright (c) 2004, 2011 IBM Corporation
1.1       root        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!"
1.1.1.2 ! root       25:    dup node>extending? @ 0=
        !            26:    my-self 0<> AND ABORT" INSTANCE word can not be used while node is opened!"
1.1       root       27:    dup node>instance @      ( iv phandle tmp-ihandle )
                     28:    swap node>instance-size dup @     ( iv tmp-ih *instance-size instance-size )
                     29:    dup ,                             \ compile current instance ptr
                     30:    swap 1 cells swap +!              ( iv tmp-ih instance-size )
                     31:    + !
                     32: ;
                     33: 
                     34: : create-instance-var ( "name" initial-value -- )
                     35:   CREATE (create-instance-var) PREVIOUS ;
                     36: 
                     37: VOCABULARY instance-words  ALSO instance-words DEFINITIONS
                     38: 
1.1.1.2 ! root       39: : VARIABLE  0 create-instance-var DOES> [ here ] @ >instance ;
        !            40: : VALUE       create-instance-var DOES> [ here ] @ >instance @ ;
        !            41: : DEFER     0 create-instance-var DOES> [ here ] @ >instance @ execute ;
1.1       root       42: \ No support for BUFFER: yet.
                     43: 
                     44: PREVIOUS DEFINITIONS
                     45: 
1.1.1.2 ! root       46: \ Save XTs of the above instance-words (put on the stack with "[ here ]")
        !            47: CONSTANT <instancedefer>
        !            48: CONSTANT <instancevalue>
        !            49: CONSTANT <instancevariable>
        !            50: 
1.1       root       51: \ check whether a value or a defer word is an
                     52: \ instance word: It must be a CREATE word and
                     53: \ the DOES> part must do >instance as first thing
                     54: 
                     55: : (instance?) ( xt -- xt true|false )
                     56:    dup @ <create> = IF
                     57:       dup cell+ @ cell+ @ ['] >instance =
                     58:    ELSE
                     59:       false
                     60:    THEN
                     61: ;
                     62: 
                     63: \ This word does instance values in compile mode.
                     64: \ It corresponds to DOTO from engine.in
                     65: : (doito) ( value R:*CFA -- )
                     66:    r> cell+ dup >r
                     67:    @ cell+ cell+ @ >instance !
                     68: ;
                     69: 
                     70: : to ( value wordname<> -- )
                     71:    ' (instance?)
                     72:    state @ IF
                     73:       \ compile mode handling normal or instance value
                     74:       IF ['] (doito) ELSE ['] DOTO THEN
                     75:       , , EXIT
                     76:    THEN
                     77:    IF
                     78:       cell+ cell+ @ >instance ! \ interp mode instance value
                     79:    ELSE
                     80:       cell+ !                   \ interp mode normal value
                     81:    THEN
                     82: ; IMMEDIATE
                     83: 
                     84: : INSTANCE  ALSO instance-words ;
                     85: 
                     86: 
                     87: STRUCT
                     88: /n FIELD instance>node
                     89: /n FIELD instance>parent
                     90: /n FIELD instance>args
                     91: /n FIELD instance>args-len
                     92: CONSTANT /instance-header
                     93: 
                     94: : my-parent  my-self instance>parent @ ;
                     95: : my-args    my-self instance>args 2@ ;
                     96: 
                     97: \ copy args from original instance to new created
                     98: : set-my-args   ( old-addr len -- )
                     99:    dup IF                             \ IF len > 0                    ( old-addr len )
                    100:       dup alloc-mem                   \ | allocate space for new args ( old-addr len new-addr )
                    101:       swap 2dup                       \ | write the new address       ( old-addr new-addr len new-addr len )
                    102:       my-self instance>args 2!        \ | into the instance table     ( old-addr new-addr len )
                    103:       move                            \ | and copy the args           ( -- )
                    104:    ELSE                               \ ELSE                          ( old-addr len )
                    105:       my-self instance>args 2!        \ | set new args to zero, too   ( )
                    106:    THEN                               \ FI
                    107: ;
                    108: 
                    109: \ Current node has already been set, when this is called.
                    110: : create-instance-data ( -- instance )
                    111:    get-node dup node>instance @ swap node>instance-size @  ( instance instance-size )
                    112:    dup alloc-mem dup >r swap move r>
                    113: ;
                    114: : create-instance ( -- )
                    115:    my-self create-instance-data
                    116:    dup to my-self instance>parent !
                    117:    get-node my-self instance>node !
                    118: ;
                    119: 
                    120: : destroy-instance ( instance -- )
                    121:    dup @ node>instance-size @ free-mem
                    122: ;
                    123: 
                    124: : ihandle>phandle ( ihandle -- phandle )
                    125:    dup 0= ABORT" no current instance" instance>node @
                    126: ;
                    127: 
                    128: : push-my-self ( ihandle -- )  r> my-self >r >r to my-self ;
                    129: : pop-my-self ( -- )  r> r> to my-self >r ;
                    130: : call-package  push-my-self execute pop-my-self ;
                    131: : $call-static ( ... str len node -- ??? )
                    132: \  cr ." call for " 3dup -rot type ."  on node " .
                    133:    find-method IF execute ELSE -1 throw THEN
                    134: ;
                    135: : $call-my-method  ( str len -- ) my-self ihandle>phandle $call-static ;
                    136: : $call-method  push-my-self $call-my-method pop-my-self ;
                    137: : $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.