From 16a2322d4943ee30f61728b8189390f85cd09a79 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 18 Nov 2004 18:17:59 +0000
Subject: [PATCH] Expand procedure DEFAULT-OBJECT?.

---
 v7/src/sf/usiexp.scm | 24 +++++++++++++++++++-----
 1 file changed, 19 insertions(+), 5 deletions(-)

diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm
index e2a5cbe8b..dfa2596b1 100644
--- a/v7/src/sf/usiexp.scm
+++ b/v7/src/sf/usiexp.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 4.43 2003/02/14 18:28:35 cph Exp $
+$Id: usiexp.scm,v 4.44 2004/11/18 18:17:59 cph Exp $
 
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright 1993,1994,1995,1997,2000,2001 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -505,7 +507,7 @@ USA.
 	    (make-type-test #f block (ucode-type big-flonum) operand)
 	    (make-type-test #f block (ucode-type recnum) operand)))))
       (if-not-expanded)))
-
+
 (define (symbol?-expansion expr operands if-expanded if-not-expanded block)
   (if (and (pair? operands)
 	   (null? (cdr operands)))
@@ -518,7 +520,17 @@ USA.
 	    (make-type-test #f block (ucode-type uninterned-symbol)
 			    operand)))))
       (if-not-expanded)))
-
+
+(define (default-object?-expansion expr operands if-expanded if-not-expanded
+	  block)
+  (if (and (pair? operands)
+	   (null? (cdr operands)))
+      (if-expanded
+       (make-combination expr block (ucode-primitive eq?)
+			 (list (car operands)
+			       (constant/make #f (default-object)))))
+      (if-not-expanded)))
+
 (define (make-disjunction expr . clauses)
   (let loop ((clauses clauses))
     (if (null? (cdr clauses))
@@ -542,7 +554,7 @@ USA.
        (constant/make (and expr (object/scode expr))
 		      (string->symbol (constant/value (car operands)))))
       (if-not-expanded)))
-
+
 (define (intern-expansion expr operands if-expanded if-not-expanded block)
   block
   (if (and (pair? operands)
@@ -643,6 +655,7 @@ USA.
     char=?
     complex?
     cons*
+    default-object?
     eighth
     exact-integer?
     exact-rational?
@@ -724,6 +737,7 @@ USA.
    char=?-expansion
    complex?-expansion
    cons*-expansion
+   default-object?-expansion
    eighth-expansion
    exact-integer?-expansion
    exact-rational?-expansion
-- 
2.25.1