"

 COPYRIGHT (c) 1989 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.

"

CompiledCode subclass:#Block

	instanceVariableNames:'home nargs sourcePos initialPC'

	classVariableNames:'InvalidNewSignal'

	poolDictionaries:''

	category:'Kernel-Methods'

!

!Block class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1989 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.

"

!

documentation

"

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

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

    Blocks are never created explicitely; the only creation

    is done by the compilers, when some sourceCode is compiled to either

    machine or byteCode.

    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 context where the block was declared -

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

    This is still true after the method has returned - since the

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

    (i.e. Blocks are closures in Smalltalk/X)

    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 will trigger an error)

    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:

      home        <Context>         the context where this block was created (i.e. defined)

                                    this may be a blockContext or a methodContext

      nargs       <SmallInteger>    the number of arguments the block expects

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

                                    relative to methods source beginning

      initialPC   <SmallInteger>    the start position within the byteCode

                                    for compiled blocks, this is nil.

    Class variables:

      InvalidNewSignal              raised if a Block is tried to be created

                                    with new (which is not allowed).

                                    Only the VM is allowed to create Blocks.

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

"

! !

!Block class methodsFor:'initialization'!

initialize

    "create signals raised by various errors"

    InvalidNewSignal isNil ifTrue:[

        InvalidNewSignal := ErrorSignal newSignalMayProceed:false.

        InvalidNewSignal nameClass:self message:#invalidNewSignal.

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

    ]

    "Modified: 22.4.1996 / 16:34:20 / cg"

! !

!Block class methodsFor:'instance creation'!

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

    "create a new cheap (homeless) block.

     Not for public use - this is a special hook for the compiler."

    |newBlock|

    newBlock := super basicNew code:codeAddress 

			   byteCode:bCode

			   numArgs:numArgs

		     sourcePosition:sourcePos

			  initialPC:initialPC

			   literals:literals

			    dynamic:dynamic.

    ^ newBlock

!

new

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

    ^ InvalidNewSignal raise.

!

new:size

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

    ^ InvalidNewSignal raise.

! !

!Block class methodsFor:'queries'!

isBuiltInClass

    ^ self == Block

! !

!Block methodsFor:'STV compatibility'!

on:aSignal do:exceptionBlock

    "added for ST/V compatibility; evaluate the receiver,

     handling aSignal. The argument, exceptionBlock is evaluated

     if the signal is raised during evaluation.

     Warning: no warranty, if the code below mimics ST/V's behavior

     correctly - give me a note if it does not ."

    aSignal handle:[:ex |

	exceptionBlock value.

	ex return

    ] do:self

    "

     [

	1 foo

     ] on:MessageNotUnderstoodSignal do:[]

    "

! !

!Block methodsFor:'accessing'!

home

    "return the receivers home context (the context where it was

     created). For cheap blocks, nil is returned"

    ^ home

!

method

    "return the receivers method 

     (the method where the block was created)."

    home notNil ifTrue:[

	^ home method

    ].

    ^ nil

!

methodHome

    "return the receivers method home context (the context where it was

     defined). For cheap blocks, nil is returned"

    home notNil ifTrue:[

	^ home methodHome

    ].

    ^ home

!

numArgs

    "return the number of arguments I expect for evaluation"

    ^ nargs

! !

!Block methodsFor:'copying'!

deepCopy

    "raise an error - deepCopy is not allowed for blocks"

    ^ self deepCopyError

! !

!Block methodsFor:'error handling'!

invalidCodeObject

    "this error is triggered by the interpreter when a non-Block object

     is about to be executed.

     In this case, the VM sends this to the bad method (the receiver).

     Can only happen when the Compiler/runtime system is broken or

     someone played around."

    ^ InvalidCodeSignal

	raiseRequestWith:self

	errorString:'invalid block - not executable'

!

wrongNumberOfArguments:numberGiven

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

    ^ ArgumentSignal

	raiseRequestWith:self

	errorString:('block got ' , numberGiven printString ,

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

! !

!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;

    if (__INST(nargs) == __MKSMALLINT(0)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

	    /* compiled machine code */

	    RETURN ( (*thecode)(self, COMMA_SND) );

	}

	/* interpreted code */

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 0, nil, nil COMMA_SND, nil) );

# else

	RETURN ( __interpret(self, 0, nil, nil COMMA_SND, nil) );

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

	    /* compiled machine code */

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

	}

	/* interpreted code */

# ifdef PASS_ARG_POINTER

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

# else

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

# endif

#endif

    }

%}

.

    ^ self wrongNumberOfArguments:0

!

value:arg

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

%{  /* NOCONTEXT */

    REGISTER OBJFUNC thecode;

    OBJ home;

    if (__INST(nargs) == __MKSMALLINT(1)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

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

	}

	/* interpreted code */

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 1, nil, nil COMMA_SND, nil, &arg) );

# else

	RETURN ( __interpret(self, 1, nil, nil COMMA_SND, nil, arg) );

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

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

	}

	/* interpreted code */

# ifdef PASS_ARG_POINTER

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

# else

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

# endif

#endif

    }

%}

.

    ^ self wrongNumberOfArguments: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;

    if (__INST(nargs) == __MKSMALLINT(2)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 2, nil, nil COMMA_SND, nil, &arg1) );

# else

	RETURN ( __interpret(self, 2, nil, nil COMMA_SND, nil, arg1, arg2) );

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

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

# else

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

# endif

#endif

    }

%}

.

    ^ self wrongNumberOfArguments: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;

    if (__INST(nargs) == __MKSMALLINT(3)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 3, nil, nil COMMA_SND, nil, &arg1) );

# else

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

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

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

# else

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

# endif

#endif

    }

%}

.

    ^ self wrongNumberOfArguments: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;

    if (__INST(nargs) == __MKSMALLINT(4)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 4, nil, nil COMMA_SND, nil, &arg1) );

# else

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

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	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

#endif

    }

%}

.

    ^ self wrongNumberOfArguments: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;

    if (__INST(nargs) == __MKSMALLINT(5)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	RETURN ( __interpret(self, 5, nil, nil COMMA_SND, nil, &arg1) );

# else

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

# endif

#else

	home = __BlockInstPtr(self)->b_home;

	if (thecode != (OBJFUNC)nil) {

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

	}

# ifdef PASS_ARG_POINTER

	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

#endif

    }

%}

.

    ^ self wrongNumberOfArguments: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;

    if (__INST(nargs) == __MKSMALLINT(6)) {

#if defined(THIS_CONTEXT)

	if (__ISVALID_ILC_LNO(__pilc))

	    __ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);

#endif

	thecode = __BlockInstPtr(self)->b_code;

#ifdef NEW_BLOCK_CALL