"

 COPYRIGHT (c) 1989-93 by Claus Gittinger

              All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

Object subclass:#Block

       instanceVariableNames:'code flags byteCode home nargs

                              sourcePos initialPC literals

                              selfValue'

       classVariableNames:'InvalidNewSignal'

       poolDictionaries:''

       category:'Kernel-Methods'

!

Block comment:'

COPYRIGHT (c) 1989-93 by Claus Gittinger

              All Rights Reserved

written spring 89 by claus

'!

!Block class methodsFor:'documentation'!

documentation

"

Blocks are pieces of executable code which can be evaluated by sending

them a value-message (''value'', ''value:'', ''value:value:'' etc).

Blocks with arguments need a message of type ''value:arg1 ... value:argn''

for evaluation; the number of arguments passed when evaluating must match

the number of arguments the block was declared with otherwise an error is

raised. Blocks without args need a ''value'' message for evaluation.

Blocks keep a reference to the method context where the block was declared -

this allows blocks to access the methods arguments and/or variables.

This is also true when the method has already returned - since the

block keeps this reference, the methods context will NOT die in this case.

A return (via ^-statement) out of a block will force a return from the

blocks method context (if it is still living) - this make the implementation

of long-jumps and control structures possible.

(If the method is not alive (i.e. has already returned), a return out of the block 

is ignored and a simple return from the block is performed).

Long-jump is done by defining a catchBlock as ''[^ self]''

somewhere up in the calling-tree. Then, to do the long-jump from out of some 

deeply nested method, simply do: ''catchBlock value''.

Instance variables:

code        <not_an_object>   the function pointer if its a compiled block

flags       <SmallInteger>    special flag bits coded in a number

byteCode    <ByteArray>       bytecode of home method if its an interpreted block

home        <Context>         the context where this block lives

nargs       <SmallInteger>    the number of arguments the block expects

sourcePos   <SmallInteger>    the character poistion of its source, in chars

                              relative to methods source beginning

initialPC   <SmallInteger>    the start position within the byteCode

literals    <Array>           the blocks literal array

selfValue   <Object>          value to use for self if its a copying block

NOTICE: layout known by runtime system and compiler - do not change

"

! !

!Block class methodsFor:'initialization' !

initialize

    "setup the signals"

    InvalidNewSignal := (Signal new).

    InvalidNewSignal mayProceed:false.

    InvalidNewSignal notifierString:'blocks are only created by the system'.

! !

!Block class methodsFor:'instance creation'!

code:codeAddress byteCode:bCode nargs:numArgs sourcePosition:sourcePos initialPC:initialPC literals:literals

    "create a new cheap (homeless) block.

     Not for public use - special hook for the compiler."

    |newBlock|

    newBlock := super basicNew.

    newBlock code:codeAddress.

    newBlock byteCode:bCode.

    newBlock nargs:numArgs.

    newBlock sourcePosition:sourcePos. 

    newBlock initialPC:initialPC. 

    newBlock literals:literals.

    ^ newBlock

!

basicNew

    "catch creation of blocks - only the system creates blocks"

    InvalidNewSignal raise.

    ^ nil

!

basicNew:size

    "catch creation of blocks - only the system creates blocks"

    InvalidNewSignal raise.

    ^ nil

! !

!Block methodsFor:'testing'!

isBlock

    ^ true

! !

!Block methodsFor:'accessing'!

instVarAt:index

    "have to catch instVar access to code - since its no object"

    (index == 1) ifTrue:[^ self code].

    ^ super instVarAt:index

!

instVarAt:index put:value

    "have to catch instVar access to code - since its no object"

    (index == 1) ifTrue:[^ self code:value].

    ^ super instVarAt:index put:value

!

code

    "return the code field. This is not an object but the address of the machine instructions. 

     Therefore an integer representing the code-address is returned"

%{  /* NOCONTEXT */

    if (_INST(code) != nil) {

        RETURN ( _MKSMALLINT((int)(_INST(code))) )

    }

%}

.

    ^ nil

!

byteCode

    "return the bytecode (a ByteArray) of the block"

    ^ byteCode

!

nargs

    "return the number of arguments I expect for evaluation"

    ^ nargs

!

selfValue

    "return the copied self"

    ^ selfValue

! !

!Block methodsFor:'private accessing'!

code:anAddress

    "set the code field - danger alert. 

     This is not an object but the address of the blocks machine instructions.

     Therefore the argument must be an integer representing for this address.

     You can crash Smalltalk very badly when playing around here ..."

%{  /* NOCONTEXT */

    if (_isSmallInteger(anAddress))

        _INST(code) = (OBJ)(_intVal(anAddress));

%}

!

byteCode:aByteArray

    "set the bytecode field - danger alert"

    byteCode := aByteArray

!

nargs:numArgs

    "set the number of arguments I expect for evaluation - danger alert"

    nargs := numArgs

!

sourcePosition:position 

    "set the position of the source within my method"

    sourcePos := position

!

initialPC:initial 

    "set the initial pc for evaluation - danger alert"

    initialPC := initial

!

literals:aLiteralArray 

    "set the literal array for evaluation - danger alert"

    literals := aLiteralArray

! !

!Block methodsFor:'error handling'!

argumentCountError:numberGiven

    "report that the number of arguments given does not match the number expected"

    self error:('Block got ' , numberGiven printString ,

                ' args while ' , nargs printString , ' where expected')

!

invalidMethod

    "this is sent by the bytecode interpreter when the blocks definition is bad.

     Can only happen when playing around with the blocks instvars

     or the Compiler/runtime system is buggy"

    self error:'invalid block - not executable'

!

invalidByteCode

    "this is sent by the bytecode interpreter when trying to execute

     an invalid bytecode.

     Can only happen when playing around with the blocks instvars

      or the Compiler/runtime system is buggy"

    self error:'invalid byteCode in block - not executable'

!

receiverNotBoolean

    "this error is triggered when the bytecode-interpreter tries to

     execute ifTrue:/ifFalse or whileTrue: type of expressions where the

     receiver is neither true nor false."

    self error:'if/while on non-boolean receiver'

! !

!Block methodsFor:'evaluation'!

value

    "evaluate the receiver with no block args. The receiver must be a block without arguments."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(0)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

            /* compiled machine code */

            RETURN ( (*thecode)(home COMMA_SND) );

        }

        /* interpreted code */

        RETURN ( interpret(self, 0, nil, home COMMA_SND, nil) );

    }

%}

.

    ^ self argumentCountError:0

!

value:arg

    "evaluate the receiver with one argument. The receiver must be a 1-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(1)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg) );

#endif

        }

        /* interpreted code */

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 1, nil, home COMMA_SND, nil, &arg) );

#else

        RETURN ( interpret(self, 1, nil, home COMMA_SND, nil, arg) );

#endif

    }

%}

.

    ^ self argumentCountError:1

!

value:arg1 value:arg2

    "evaluate the receiver with two arguments. The receiver must be a 2-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(2)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg1) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg1, arg2) );

#endif

        }

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 2, nil, home COMMA_SND, nil, &arg1) );

#else

        RETURN ( interpret(self, 2, nil, home COMMA_SND, nil, arg1, arg2) );

#endif

    }

%}

.

    ^ self argumentCountError:2

!

value:arg1 value:arg2 value:arg3

    "evaluate the receiver with three arguments. The receiver must be a 3-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(3)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg1) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg1, arg2, arg3) );

#endif

        }

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 3, nil, home COMMA_SND, nil, &arg1) );

#else

        RETURN ( interpret(self, 3, nil, home COMMA_SND, nil, arg1, arg2, arg3) );

#endif

    }

%}

.

    ^ self argumentCountError:3

!

value:arg1 value:arg2 value:arg3 value:arg4

    "evaluate the receiver with four arguments. The receiver must be a 4-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(4)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg1) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg1, arg2, arg3, arg4) );

#endif

        }

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 4, nil, home COMMA_SND, nil, &arg1) );

#else

        RETURN ( interpret(self, 4, nil, home COMMA_SND, nil, arg1, arg2, arg3, arg4) );

#endif

    }

%}

.

    ^ self argumentCountError:4

!

value:arg1 value:arg2 value:arg3 value:arg4 value:arg5

    "evaluate the receiver with four arguments. The receiver must be a 5-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(5)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg1) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg1, arg2, arg3, arg4, arg5) );

#endif

        }

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 5, nil, home COMMA_SND, nil, &arg1) );

#else

        RETURN ( interpret(self, 5, nil, home COMMA_SND, nil, arg1, arg2, arg3, arg4, arg5) );

#endif

    }

%}

.

    ^ self argumentCountError:5

!

value:arg1 value:arg2 value:arg3 value:arg4 value:arg5 value:arg6

    "evaluate the receiver with four arguments. The receiver must be a 6-arg block."

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

    if (_INST(nargs) == _MKSMALLINT(6)) {

#if defined(THIS_CONTEXT)

        if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

            _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

        home = _BlockInstPtr(self)->b_home;

        thecode = _BlockInstPtr(self)->b_code;

        if (thecode != (OBJFUNC)nil) {

#ifdef PASS_ARG_REF

            RETURN ( (*thecode)(home COMMA_SND, &arg1) );

#else

            RETURN ( (*thecode)(home COMMA_SND, arg1, arg2, arg3, arg4, arg5, arg6) );

#endif

        }

#ifdef PASS_ARG_REF

        RETURN ( interpret(self, 6, nil, home COMMA_SND, nil, &arg1) );

#else

        RETURN ( interpret(self, 6, nil, home COMMA_SND, nil, arg1, arg2, arg3, arg4, arg5, arg6) );

#endif

    }

%}

.

    ^ self argumentCountError:6

!

valueWithArguments:argArray

    "evaluate the receiver with arguments taken from argArray.

     The size of the argArray must match the number of arguments the receiver expects."

    |a1 a2 a3 a4 a5 a6 a7|

    (argArray class == Array) ifFalse:[

        ^ self error:'argument must be an array'

    ].

    (argArray size == nargs) ifFalse:[

        ^ self argumentCountError:(argArray size)

    ].

%{

    REGISTER OBJFUNC thecode;

    OBJ home;

    extern OBJ interpret();

#if defined(THIS_CONTEXT)

    if (1 /* _intVal(__pilc->ilc_lineNo) > 0 */)

        _ContextInstPtr(__thisContext)->c_lineno = __pilc->ilc_lineNo;

#endif

    switch (_intVal(_INST(nargs))) {

        case 7:

            a7 = _ArrayInstPtr(argArray)->a_element[6];

        case 6:

            a6 = _ArrayInstPtr(argArray)->a_element[5];

        case 5:

            a5 = _ArrayInstPtr(argArray)->a_element[4];

        case 4:

            a4 = _ArrayInstPtr(argArray)->a_element[3];

        case 3:

            a3 = _ArrayInstPtr(argArray)->a_element[2];

        case 2:

            a2 = _ArrayInstPtr(argArray)->a_element[1];

        case 1: