From a89050d49d5d0c260a9e86e1a65ca725f488f2c3 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 5 Jan 2019 19:29:24 +0000
Subject: [PATCH] Integrate GUARANTEE.

For this to be effective, SF makes the assumption that predicates do
not modify their own definitions, like

(define (foo? x) (set! foo? (lambda (x) x #f)) #t)
(guarantee foo? 42)

Such is the depravity of arbitrary side effects not represented in a
type system...!
---
 src/runtime/boot.scm |  2 ++
 src/sf/usiexp.scm    | 71 +++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 72 insertions(+), 1 deletion(-)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index b728c932c..9c963f04c 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -405,7 +405,9 @@ USA.
     (lambda ()
       (set-predicate<=! p1 p2))))
 
+(declare (integrate-operator guarantee))
 (define (guarantee predicate object #!optional caller)
+  (declare (integrate-operator predicate))
   (if (not (predicate object))
       (error:not-a predicate object caller))
   object)
diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm
index 8106349ff..3690ad3ad 100644
--- a/src/sf/usiexp.scm
+++ b/src/sf/usiexp.scm
@@ -566,7 +566,74 @@ USA.
 			    (list (first operands) (constant/make #f #f))))
 	    (else (make-combination expr block (ucode-primitive not) operands)))
       #f))
-
+
+(define (guarantee-expansion expr operands block)
+  (if (and (pair? operands)
+	   (pair? (cdr operands))
+	   (or (null? (cddr operands))
+	       (and (pair? (cddr operands))
+		    (null? (cdddr operands)))))
+      (let ((predicate-expr (car operands))
+	    (object-expr (cadr operands))
+	    (caller-expr (and (pair? (cddr operands)) (caddr operands))))
+	(combination/make
+	 expr
+	 block
+	 (let ((block (block/make block #t '())))
+	   (define (*const v) (constant/make #f v))
+	   (define (*ref var) (reference/make #f block var))
+	   (define (*begin . actions) (sequence/make #f actions))
+	   (define (*app operator operands)
+	     (combination/make #f block operator operands))
+	   (define (*lambda name variables body)
+	     (procedure/make #f block name variables '() #f body))
+	   (define (*declare declarations body)
+	     (declaration/make #f
+			       (declarations/parse block declarations)
+			       body))
+	   (define (*if predicate consequent alternative)
+	     (conditional/make #f predicate consequent alternative))
+	   (define (make-variable name)
+	     (variable/make&bind!
+	      block
+	      (string->uninterned-symbol (symbol->string name))))
+	   (let ((predicate-var (make-variable 'predicate))
+		 (object-var (make-variable 'object))
+		 (caller-var (and caller-expr (make-variable 'caller))))
+	     (let* ((variables
+		     (cons* predicate-var
+			    object-var
+			    (if caller-var (list caller-var) '()))))
+	       (*lambda scode-lambda-name:let variables
+		 (*declare
+		   ;; This declaration is not generally valid in
+		   ;; substituting the definition of GUARANTEE as
+		   ;; written; it encodes the assumption that
+		   ;; predicates do not modify their own definitions.
+		   ;; For example,
+		   ;;
+		   ;;	(define (foo? x) (set! foo? (lambda (x) #f)) #t)
+		   ;;	(guarantee foo? x)
+		   ;;
+		   ;; violates the assumption.
+		   (if (reference? predicate-expr)
+		       `((INTEGRATE ,(variable/name predicate-var)))
+		       '())
+		   (*begin
+		     (*if (*app (*ref predicate-var) (list (*ref object-var)))
+			  (*const unspecific)
+			  (*app (access/make #f block (*const #f) 'error:not-a)
+				(cons* (*ref predicate-var)
+				       (*ref object-var)
+				       (if caller-var
+					   (list (*ref caller-var))
+					   '()))))
+		     (*ref object-var)))))))
+	 (cons* predicate-expr
+		object-expr
+		(if caller-expr (list caller-expr) '()))))
+      #f))
+
 (define (type-test-expansion type)
   (lambda (expr operands block)
     (if (and (pair? operands)
@@ -741,6 +808,7 @@ USA.
 	    fix:=
 	    fix:>=
 	    fourth
+	    guarantee
 	    int:->flonum
 	    int:integer?
 	    intern
@@ -823,6 +891,7 @@ USA.
 	   fix:=-expansion
 	   fix:>=-expansion
 	   fourth-expansion
+	   guarantee-expansion
 	   int:->flonum-expansion
 	   exact-integer?-expansion
 	   intern-expansion
-- 
2.25.1