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

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index b728c932cfa2261f65ad1023b1c48347b0d1ffb5..9c963f04c4121f7742a1a9773aacfad79f8651aa 100644 (file)
--- 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 8106349ff91709a40ff933483c5629d4db929ec5..3690ad3ad9ad81d0a91881829a725ae31c01b9bd 100644 (file)
--- 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))
-
+\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))
+\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