(;; SCCS   : @(#)FAIL.LSP	3.9 2/4/86
;;; File   : $xerox/fail.lsp
;;; Author : Richard A. O'Keefe
;;; Purpose: Define the failure instruction.
PROGN
;;; ------------------------------------------------------------------------
;;
;;	WARNING: This material is CONFIDENTIAL and proprietary to Quintus
;;	Computer Systems Inc.  This notice is protection against inadvertent
;;	disclosure and does not constitute publication or reflect any intent
;;	to publish.
;;
;;	Copyright (C) 1985, by Quintus Computer Systems, Inc.
;;	All rights reserved.
;;
;;	CAVEAT LECTOR: This software is under development.  No warrantee is
;;	made that it is any use for anything at all.
;;
;;; ------------------------------------------------------------------------


;;  The following macros access saved values in a choice point or an
;;  environment.

(def.const saved.B  -4)
(def.const saved.BP -3)
(def.const saved.TR -2)
(def.const saved.H  -1)
(def.const saved.CE  0)
(def.const saved.CP  1)
(def.const saved.B0  2)


;;  it is IMPORTANT that fast.fail sets R

(def.open fast.fail ()
    (put.24 R  (add.cell B -7))
    (put.24 E  (get.addr R 5))		; C was "Tr0"
    (until (same.addr TR E)
	(put.24 S (get.addr TR 0))
	(increment.cell.pointer TR)
	(put.cell S 0 (tag.ref S))
    )					; C is now dead
    (put.24 B0 (get.addr R 0))
    (put.24 E  (get.addr R 1))
    (put.24 CP (get.addr R 2))
    (put.24 H  (get.addr R 6))
    (put.24 P  (get.addr R 4))
    (continue.at (get.24 P))
)



;;  The new macro (index.fail) replaces the old one (easy.fail).
;;  As this version of the emulator has four indexing opcodes --
;;  {just,try,retry,trust}.index.else -- it is possible to tell
;;  at emulator-compile time whether there is a choice point to
;;  revert to particularly rapidly or not.

(def.open index.fail ()
    (put.24 R (add.cell B -7))		; passed to {retry/trust}
    (continue.at (get.addr B saved.BP))	; .{index/me}.else
)



(def.both.mode fail ()
    (fast.fail)
)



;;  This is a hack for scanning the Prolog stack.  See traverse←stack
;;  and its surroundings in clauses.pl.  The new function QP.PRUNEP
;;  replaces the test Ptr>>8 < Count on the Dandelion.

(def.global QP.NXTICP)			; current pointer into stack

(def.subr QP.NXTICP (FIRST)
    (if (NOT (SMALLP FIRST)) then	; is a stack pointer
	(SETQ QP.NXTICP FIRST)		; (was (get.24 B))
    )
    (if (EQ QP.NXTICP QP.init.E) then
	(VALUES 0 0)
    else
	(VALUES (\ADDBASE (\GETBASEPTR QP.NXTICP -6) -1)
	    (PROGN (SETQ QP.NXTICP (\GETBASEPTR QP.NXTICP -8)) 0))
    )
)


(def.subr QP.PRUNEP (Ptr COUNT)
    ;;  test whether (Ptr-QP.init.E) >> 7 < COUNT
    (IGREATERP (IPLUS 
	(LLSH (IDIFFERENCE (\HILOC Ptr) (\HILOC QP.init.E)) 9)
	(LRSH (IDIFFERENCE (\LOLOC Ptr) (\LOLOC QP.init.E)) 7))
	COUNT)
)


) STOP