reduce-historical/psl-1983/kernel/binding.red

%
% BINDING.RED - Primitives to support Lambda binding
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        18 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>BINDING.RED.2, 21-Dec-82 15:57:06, Edit by BENSON
%  Added call to %clear-catch-stack in ClearBindings

% Support for binding in compiled code is in FAST-BINDER.RED

on SysLisp;

internal WConst BndStkSize = 2000;

internal WArray BndStk[BndStkSize];

% Only these WVars, which contain addresses rather than indexes, will be
% used to access the binding stack

exported WVar BndStkLowerBound = &BndStk[0],
	      BndStkUpperBound = &BndStk[BndStkSize-1],
	      BndStkPtr = &BndStk[0];

% Only the macros BndStkID, BndStkVal and AdjustBndStkPtr will be used
% to access or modify the binding stack and pointer.

syslsp procedure BStackOverflow();
<<  ChannelPrin2(LispVar ErrOUT!*,
		 "***** Binding stack overflow, restarting...");
    ChannelWriteChar(LispVar ErrOUT!*,
		     char EOL);
    Reset() >>;

syslsp procedure BStackUnderflow();
<<  ChannelPrin2(LispVar ErrOUT!*,
		 "***** Binding stack underflow, restarting...");
    ChannelWriteChar(LispVar ErrOUT!*,
		     char EOL);
    Reset() >>;

syslsp procedure CaptureEnvironment();	 %. Save bindings to be restored
    BndStkPtr;

syslsp procedure RestoreEnvironment Ptr;	%. Restore old bindings
<<  if Ptr < BndStkLowerBound then BStackUnderflow()
    else while BndStkPtr > Ptr do
    <<  SymVal BndStkID BndStkPtr := BndStkVal BndStkPtr;
	BndStkPtr := AdjustBndStkPtr(BndStkPtr, -1) >> >>;

syslsp procedure ClearBindings();	 %. Restore bindings to top level
<<  RestoreEnvironment BndStkLowerBound;
    !%clear!-catch!-stack() >>;

syslsp procedure UnBindN N;		%. Support for Lambda and Prog interp
    RestoreEnvironment AdjustBndStkPtr(BndStkPtr, -IntInf N);

syslsp procedure LBind1(IDName, ValueToBind);	%. Support for Lambda
    if not IDP IDName then
	NonIDError(IDName, "binding")
    else if null IDName or IDName eq 'T then
	StdError '"T and NIL cannot be rebound"
    else
    <<  BndStkPtr := AdjustBndStkPtr(BndStkPtr, 1);
	if BndStkPtr > BndStkUpperBound then BStackOverflow()
	else
	<<  IDName := IDInf IDName;
	    BndStkID BndStkPtr := IDName;
	    BndStkVal BndStkPtr := SymVal IDName;
	    SymVal IDName := ValueToBind >> >>;

syslsp procedure PBind1 IDName;		%. Support for PROG
    LBind1(IDName, NIL);

off SysLisp;

END;