"
 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 comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
	      All Rights Reserved

$Header: /cvs/stx/stx/libbasic/Block.st,v 1.35 1995-05-18 15:08:46 claus Exp $
'!

!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.
"
!

version
"
$Header: /cvs/stx/stx/libbasic/Block.st,v 1.35 1995-05-18 15:08:46 claus Exp $
"
!

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 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
    "setup the signals"

    InvalidNewSignal isNil ifTrue:[
	InvalidNewSignal := ErrorSignal newSignalMayProceed:false.
	InvalidNewSignal nameClass:self message:#invalidNewSignal.
	InvalidNewSignal notifierString:'blocks are only created by the system'.
    ]
! !

!Block methodsFor:'copying'!

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

    ^ self deepCopyError
! !

!Block class methodsFor:'queries'!

isBuiltInClass
    "this class is known by the run-time-system"

    ^ true
! !

!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 methodsFor:'testing'!

isBlock
    "return true, if this is a block - yes I am"

    ^ true
! !

!Block methodsFor:'accessing'!

numArgs
    "return the number of arguments I expect for evaluation"

    ^ nargs
!

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
!

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

!Block methodsFor:'private accessing'!

code:codeAddress byteCode:bCode numArgs:numArgs sourcePosition:srcPos initialPC:iPC literals:lits dynamic:dynamic
    "set all relevant internals"

    self code:codeAddress.
    byteCode := bCode.
    nargs := numArgs.
    sourcePos := srcPos.
    initialPC := iPC.
    literals := lits.
    self dynamic:dynamic
!

numArgs: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
! !

!Block methodsFor:'error handling'!

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')
!

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

!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(), interpret();

    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, (OBJ * 0)) );
# 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, (OBJ *) 0) );
# 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;
    extern OBJ __interpret(), interpret();

    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;
    extern OBJ __interpret(), interpret();

    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;
    extern OBJ __interpret(), interpret();

    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;
    extern OBJ __interpret(), interpret();

    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;
    extern OBJ __interpret(), interpret();

    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;
    extern OBJ __interpret(), interpret();

    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
	if (thecode != (OBJFUNC)nil) {
	    RETURN ( (*thecode)(self COMMA_SND, arg1, arg2, arg3, arg4, arg5, arg6) );
	}
# ifdef PASS_ARG_POINTER
	RETURN ( __interpret(self, 6, nil, nil COMMA_SND, nil, &arg1) );
# else
	RETURN ( interpret(self, 6, nil, nil COMMA_SND, nil, arg1, arg2, arg3, arg4, arg5, arg6) );
# endif
#else
	home = _BlockInstPtr(self)->b_home;
	if (thecode != (OBJFUNC)nil) {
	    RETURN ( (*thecode)(home COMMA_SND, arg1, arg2, arg3, arg4, arg5, arg6) );
	}
# ifdef PASS_ARG_POINTER
	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
#endif
    }
%}
.
    ^ self wrongNumberOfArguments:6
!

valueWithArguments:argArray
    "evaluate the receiver with arguments taken from argArray.
     ArgArray must be either an Array or nil.
     The size of the argArray must match the number of arguments the receiver expects."

    |a1 a2 a3 a4 a5 a6 a7|

    (argArray notNil and:[argArray class ~~ Array]) ifTrue:[
	^ self badArgumentArry
    ].
    (argArray size == nargs) ifFalse:[
	^ self wrongNumberOfArguments:(argArray size)
    ].
%{

    REGISTER OBJFUNC thecode;
    OBJ home;
    extern OBJ __interpret(), interpret();
    REGISTER OBJ *ap;
    int nargs;

#if defined(THIS_CONTEXT)
    if (__ISVALID_ILC_LNO(__pilc))
	    _ContextInstPtr(__thisContext)->c_lineno = __ILC_LNO_AS_OBJ(__pilc);
#endif
    switch (nargs = _intVal(_INST(nargs))) {
	default:
	    goto error;
	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:
	    a1 = _ArrayInstPtr(argArray)->a_element[0];
	case 0:
	    break;
    }
    thecode = _BlockInstPtr(self)->b_code;
#ifdef NEW_BLOCK_CALL
    if (thecode != (OBJFUNC)nil) {
	RETURN ( (*thecode)(self COMMA_SND, a1, a2, a3, a4, a5, a6, a7) );
    }
# ifdef PASS_ARG_POINTER
    RETURN ( __interpret(self, nargs, nil, nil COMMA_SND, nil, &a1) );
# else
    RETURN ( interpret(self, nargs, nil, nil COMMA_SND, nil, 
		       a1, a2, a3, a4, a5, a6, a7) );
# endif
#else
    home = _BlockInstPtr(self)->b_home;
    if (thecode != (OBJFUNC)nil) {
	RETURN ( (*thecode)(home COMMA_SND, a1, a2, a3, a4, a5, a6, a7) );
    }
# ifdef PASS_ARG_POINTER
    RETURN ( __interpret(self, nargs, nil, home COMMA_SND, nil, &a1) );
# else
    RETURN ( interpret(self, nargs, nil, home COMMA_SND, nil, 
		       a1, a2, a3, a4, a5, a6, a7) );
# endif
#endif

error: ;
%}
.
    "
     the above code only supports up-to 7 arguments
    "
    ^ ArgumentSignal
	raiseRequestWith:self
	errorString:'only blocks with up-to 7 arguments supported'
! !

!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:'privileged evaluation'!

valueUninterruptably
    "evaluate the receiver with interrupts blocked.
     This does not prevent preemption by a higher priority processes
     if any becomes runnable due to the evaluation of the receiver
     (i.e. if a semaphore is signalled)."

    Processor activeProcess uninterruptablyDo:self
!

valueUnpreemptively
    "evaluate the receiver without the possiblity of preemption
     (i.e. at a very high priority)"

    |oldPrio activeProcess|

    activeProcess := Processor activeProcess.
    oldPrio := activeProcess changePriority:(Processor highestPriority).
    self valueNowOrOnUnwindDo:[
	activeProcess priority:oldPrio
    ]
! !

!Block methodsFor:'unwinding'!

valueNowOrOnUnwindDo:aBlock
    "evaluate the receiver - after that, or when some method sent within unwinds (i.e. does
     a long return), evaluate the argument, aBlock.
     This is used to make certain that cleanup actions (for example closing files etc.) are
     executed regardless of error actions"

    |v|

    v := self value.       "the real logic is in Context>>unwind"
    aBlock value.
    ^ v

    "
     in the following example, f will be closed even if the block
     returns with 'oops'. There are many more applications of this kind
     found in the system.
    "
    "
     |f|

     f := 'Makefile' asFilename readStream.
     [
	l := f nextLine.
	l isNil ifTrue:[^ 'oops']
     ] valueNowOrOnUnwindDo:[
	f close
     ]
    "
!

valueOnUnwindDo:aBlock
    "evaluate the receiver - when some method sent within unwinds (i.e. does
     a long return), evaluate the argument, aBlock.
     This is used to make certain that cleanup actions (for example closing files etc.) are
     executed regardless of error actions"

    ^ self value        "the real logic is in Context>>unwind"
! !

!Block methodsFor:'looping'!

whileTrue:aBlock
    "evaluate the argument, aBlock while the receiver evaluates to true.
     - usually open coded by compilers, but needed here for #perform 
       and expression evaluation."

    "this implementation is for purists ... :-)"

    self value ifFalse:[^ nil].
    aBlock value.
    thisContext restart

    "
     |n|

     n := 1.
     [n <= 10] whileTrue:[
	n printNewline.
	n := n + 1
     ]
    "
!

whileFalse:aBlock
    "evaluate the argument, aBlock while the receiver evaluates to false.
     - usually open coded by compilers, but needed here for #perform 
       and expression evaluation."

    "this implementation is for purists ... :-)"

    self value ifTrue:[^ nil].
    aBlock value.
    thisContext restart

    "
     |n|

     n := 1.
     [n > 10] whileFalse:[
	n printNewline.
	n := n + 1
     ]
    "
!

whileTrue
    "evaluate the receiver while it evaluates to true (ST80 compatibility)"

    "this implementation is for purists ... :-)"

    self value ifFalse:[^ nil].
    thisContext restart

    "
     |n|

     n := 1.
     [n printNewline. (n := n + 1) <= 10] whileTrue
    "
!

whileFalse
    "evaluate the receiver while it evaluates to false (ST80 compatibility)"

    "this implementation is for purists ... :-)"

    self value ifTrue:[^ nil].
    thisContext restart

    "
     |n|

     n := 1.
     [n printNewline. (n := n + 1) > 10] whileFalse
    "
!

doWhile:aBlock
    "repeat the receiver block until aBlock evaluates to false.
     The receiver is evaluated at least once."

    "this implementation is for purists ... :-)"

    self value.
    aBlock value ifFalse:[^ nil].
    thisContext restart

    "
     |n|

     n := 1.
     [n printNewline] doWhile:[ (n := n + 1) <= 5 ]
    "
!

doUntil:aBlock
    "repeat the receiver block until aBlock evaluates to true.
     The receiver is evaluated at least once.
     This is the same as '... doWhile:[... not]' "

    "this implementation is for purists ... :-)"

    self value.
    aBlock value ifTrue:[^ nil].
    thisContext restart

    "
     |n|

     n := 1.
     [n printNewline] doUntil:[ (n := n + 1) > 5 ]
    "
!

repeat
    "repeat the receiver forever - same as loop, for ST-80 compatibility"

    self value.
    thisContext restart
!

loop
    "repeat the receiver forever (should contain a return somewhere).
     Inspired by a corresponding Self method."

    self value.
    thisContext restart

    "
     |n|

     n := 1.
     [
	n printNewline.
	n >= 10 ifTrue:[^ nil].
	n := n + 1
     ] loop
    "
!

valueWithExit
    "the receiver must be a block of one argument.  It is evaluated, and is passed a block,
     which, if sent a value:-message, will exit the receiver block, returning the parameter of the 
     value:-message. Used for premature returns to the caller.
     Taken from a manchester goody (a similar construct also appears in Self)."

    ^ self value: [:exitValue | ^exitValue]

    "
     [:exit |
	1 to:10 do:[:i |
	    Transcript showCr:i.
	    i == 5 ifTrue:[exit value:'thats it']
	].
	'regular block-value; never returned'
     ] valueWithExit
    "
!

loopWithExit
    "the receiver must be a block of one argument.  It is evaluated in a loop forever, 
     and is passed a block, which, if sent a value:-message, will exit the receiver block, 
     returning the parameter of the value:-message. Used for loops with exit in the middle.
     Inspired by a corresponding Self method."

    |exitBlock|

    exitBlock := [:exitValue | ^ exitValue].
    [true] whileTrue:[self value:exitBlock]

    "
     |i|
     i := 1.
     [:exit |
	Transcript showCr:i.
	i == 5 ifTrue:[exit value:'thats it'].
	i := i + 1
     ] loopWithExit
    "
! !

!Block methodsFor:'process creation'!

newProcess
    "create a new (unscheduled) process executing the receiver"

    ^ Process for:self priority:(Processor activePriority)
!

newProcessWithArguments:argArray
    "create a new (unscheduled) process executing the receiver,
     passing the elements in argArray as arguments to the receiver block."

    ^ [self valueWithArguments:argArray] newProcess
!

fork
    "create a new process executing the receiver at the current priority."

    ^ self newProcess resume
!

forkWith:argArray
    "create a new process executing the receiver,
     passing elements in argArray as arguments to the receiver block."

    ^ [self valueWithArguments:argArray] fork.
!

forkAt:priority
    "create a new process executing the receiver at a different priority."

    ^ (self newProcess priority:priority) resume
!

promise
    "create a promise on the receiver. The promise will evaluate the
     receiver and promise to return the value with the #value message.
     The evaluation will be performed as a separate process.
     Asking the promise for its value will either block the asking process
     (if the evaluation has not yet been finished) or return the value
     immediately."

    ^ Promise value:self
!

promiseAt:prio
    "create a promise on the receiver. The promise will evaluate the
     receiver and promise to return thevalue with the #value message.
     The evaluation will be performed as a separate process running at prio.
     Asking the promise for its value will either block the asking process
     (if the evaluation has not yet been finished) or return the value
     immediately."

    ^ Promise value:self priority:prio
! !

!Block methodsFor:'printing & storing'!

printOn:aStream
    "append a a printed representation of the block to aStream"

    |homeClass h sel methodClass|

    "cheap blocks have no home context, but a method instead"

    (home isNil or:[home isContext not]) ifTrue:[
	aStream nextPutAll:'[] in '.

	"
	 currently, some cheap blocks don't know where they have been created
	"
	aStream nextPutAll:' ??? (optimized)'.
	^ self
    ].

    "a full blown block (with home, but without method)"

    aStream nextPutAll:'[] in '. 
    h := self methodHome.
    sel := h selector.
"/ old:
"/    home receiver class name printOn:aStream.
"/ new:
"/    (h searchClass whichClassImplements:sel) name printOn:aStream.
    methodClass := h methodClass.
    methodClass isNil ifTrue:[
	'UnboundMethod' printOn:aStream.
    ] ifFalse:[
	methodClass name printOn:aStream.
    ].
    aStream nextPut:$-.
    sel printOn:aStream.

"
    aStream nextPutAll:'[] in '.
    homeClass := home containingClass.
    homeClass notNil ifTrue:[
	homeClass name printOn:aStream.
	aStream space.
	(homeClass selectorForMethod:home) printOn:aStream
    ] ifFalse:[
	aStream nextPutAll:' ???' 
    ]
"
! !