From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 19 Nov 2004 17:40:30 +0000 (+0000)
Subject: DEFAULT-OBJECT? is no longer a special form.
X-Git-Tag: 20090517-FFI~1455
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b0b0eb8bc3f7149e9cd1c841165108ca4529156a;p=mit-scheme.git

DEFAULT-OBJECT? is no longer a special form.
---

diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm
index 05c026be2..321ff2106 100644
--- a/v7/src/edwin/evlcom.scm
+++ b/v7/src/edwin/evlcom.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: evlcom.scm,v 1.68 2003/02/14 18:28:12 cph Exp $
+$Id: evlcom.scm,v 1.69 2004/11/19 17:35:08 cph Exp $
 
 Copyright 1986,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
 Copyright 1995,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
-Copyright 2003 Massachusetts Institute of Technology
+Copyright 2003,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -253,23 +253,21 @@ Has no effect if evaluate-in-inferior-repl is false."
   (let ((buffer (current-buffer)))
     (eval-with-history (apply prompt-for-expression
 			      prompt
-			      (cond ((default-object? default)
-				     default-object-kludge)
-				    ((or (symbol? default)
-					 (pair? default)
-					 (vector? default))
-				     `',default)
-				    (else default))
+			      (if (or (symbol? default)
+				      (pair? default)
+				      (vector? default))
+				  `',default
+				  default)
 			      options)
 		       (evaluation-environment buffer))))
 
-(define (prompt-for-expression prompt #!optional default-object . options)
+(define (prompt-for-expression prompt #!optional default . options)
   (read-from-string
    (apply prompt-for-string
 	  prompt
-	  (and (not (or (default-object? default-object)
-			(eq? default-object-kludge default-object)))
-	       (write-to-string default-object))
+	  (if (default-object? default)
+	      #f
+	      (write-to-string default))
 	  'MODE
 	  (let ((environment (ref-variable scheme-environment)))
 	    (lambda (buffer)
@@ -280,9 +278,6 @@ Has no effect if evaluate-in-inferior-repl is false."
 	      (local-set-variable! scheme-environment environment buffer)))
 	  options)))
 
-(define default-object-kludge
-  (list 'DEFAULT-OBJECT-KLUDGE))
-
 (define (read-from-string string)
   (bind-condition-handler (list condition-type:error) evaluation-error-handler
     (lambda ()
diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm
index 5c4e88fcd..0ef389beb 100644
--- a/v7/src/runtime/input.scm
+++ b/v7/src/runtime/input.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: input.scm,v 14.29 2004/11/19 06:59:41 cph Exp $
+$Id: input.scm,v 14.30 2004/11/19 17:40:30 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1997,1999,2002,2003 Massachusetts Institute of Technology
@@ -142,17 +142,6 @@ USA.
 
 ;;;; High level
 
-(define-syntax optional-input-port
-  (sc-macro-transformer
-   (lambda (form environment)
-     (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form))
-	 (let ((port (close-syntax (cadr form) environment))
-	       (caller (close-syntax (caddr form) environment)))
-	   `(IF (DEFAULT-OBJECT? ,port)
-		(CURRENT-INPUT-PORT)
-		(GUARANTEE-INPUT-PORT ,port ,caller)))
-	 (ill-formed-syntax form)))))
-
 (define (char-ready? #!optional port interval)
   (let ((port (optional-input-port port 'CHAR-READY?))
 	(interval
@@ -231,4 +220,9 @@ USA.
 	  ((external-string? string)
 	   (input-port/read-external-substring! port string start end))
 	  (else
-	   (error:wrong-type-argument string "string" 'READ-SUBSTRING!)))))
\ No newline at end of file
+	   (error:wrong-type-argument string "string" 'READ-SUBSTRING!)))))
+
+(define (optional-input-port port caller)
+  (if (default-object? port)
+      (current-input-port)
+      (guarantee-input-port port caller)))
\ No newline at end of file
diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 27466298e..ce383aca3 100644
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: output.scm,v 14.34 2004/05/26 17:03:14 cph Exp $
+$Id: output.scm,v 14.35 2004/11/19 17:37:48 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1999,2001,2002,2003 Massachusetts Institute of Technology
@@ -84,17 +84,6 @@ USA.
 
 ;;;; High level
 
-(define-syntax optional-output-port
-  (sc-macro-transformer
-   (lambda (form environment)
-     (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form))
-	 (let ((port (close-syntax (cadr form) environment))
-	       (caller (close-syntax (caddr form) environment)))
-	   `(IF (DEFAULT-OBJECT? ,port)
-		(CURRENT-OUTPUT-PORT)
-		(GUARANTEE-OUTPUT-PORT ,port ,caller)))
-	 (ill-formed-syntax form)))))
-
 (define (write-char char #!optional port)
   (let ((port (optional-output-port port 'WRITE-CHAR)))
     (if (let ((n (output-port/write-char port char)))
@@ -149,17 +138,6 @@ USA.
 	       (fix:> n 0)))
 	(output-port/discretionary-flush port))))
 
-(define-syntax optional-unparser-table
-  (sc-macro-transformer
-   (lambda (form environment)
-     (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form))
-	 (let ((unparser-table (close-syntax (cadr form) environment))
-	       (caller (close-syntax (caddr form) environment)))
-	   `(IF (DEFAULT-OBJECT? ,unparser-table)
-		(CURRENT-UNPARSER-TABLE)
-		(GUARANTEE-UNPARSER-TABLE ,unparser-table ,caller)))
-	 (ill-formed-syntax form)))))
-
 (define (display object #!optional port unparser-table)
   (let ((port (optional-output-port port 'DISPLAY)))
     (unparse-object/top-level object port #f
@@ -195,6 +173,16 @@ USA.
 
 (define beep (wrap-custom-operation-0 'BEEP))
 (define clear (wrap-custom-operation-0 'CLEAR))
+
+(define (optional-output-port port caller)
+  (if (default-object? port)
+      (current-output-port)
+      (guarantee-output-port port caller)))
+
+(define (optional-unparser-table unparser-table caller)
+  (if (default-object? unparser-table)
+      (current-unparser-table)
+      (guarantee-unparser-table unparser-table caller)))
 
 ;;;; Tabular output
 
diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm
index 0f594c87c..65bc22840 100644
--- a/v7/src/runtime/random.scm
+++ b/v7/src/runtime/random.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: random.scm,v 14.35 2004/01/09 20:22:22 cph Exp $
+$Id: random.scm,v 14.36 2004/11/19 17:34:27 cph Exp $
 
 Copyright 1988,1989,1993,1994,1995,1996 Massachusetts Institute of Technology
 Copyright 1998,1999,2000,2001,2003,2004 Massachusetts Institute of Technology
@@ -131,9 +131,7 @@ USA.
 ;;;; Operations producing random values
 
 (define (random modulus #!optional state)
-  (let ((state
-	 (guarantee-random-state (if (default-object? state) #f state)
-				 'RANDOM)))
+  (let ((state (guarantee-random-state state 'RANDOM)))
     ;; Kludge: an exact integer modulus means that result is an exact
     ;; integer.  Otherwise, the result is a real number.
     (cond ((int:integer? modulus)
@@ -159,9 +157,7 @@ USA.
   (flo:/ (int:->flonum (%random-integer flimit state)) flimit.))
 
 (define (random-byte-vector n #!optional state)
-  (let ((state
-	 (guarantee-random-state (if (default-object? state) #f state)
-				 'RANDOM-BYTE-VECTOR))
+  (let ((state (guarantee-random-state state 'RANDOM-BYTE-VECTOR))
 	(s (make-string n)))
     (do ((i 0 (fix:+ i 1)))
 	((fix:= i n))
@@ -200,27 +196,26 @@ USA.
 ;;;; Operations on state
 
 (define (make-random-state #!optional state)
-  (let ((state (if (default-object? state) #f state)))
-    (if (or (eq? #t state) (int:integer? state))
-	;; Use good random source if available
-	(if (file-readable? "/dev/urandom")
-	    (call-with-input-file "/dev/urandom"
-	      (lambda (port)
-		(initial-random-state
-		 (lambda (b)
-		   (let outer ()
-		     (let inner
-			 ((m #x100)
-			  (n (char->integer (read-char port))))
-		       (cond ((< m b)
-			      (inner (* m #x100)
-				     (+ (* n #x100)
-					(char->integer (read-char port)))))
-			     ((< n b) n)
-			     (else (outer)))))))))
-	    (simple-random-state))
-	(copy-random-state
-	 (guarantee-random-state state 'MAKE-RANDOM-STATE)))))
+  (if (or (eq? #t state) (int:integer? state))
+      ;; Use good random source if available
+      (if (file-readable? "/dev/urandom")
+	  (call-with-input-file "/dev/urandom"
+	    (lambda (port)
+	      (initial-random-state
+	       (lambda (b)
+		 (let outer ()
+		   (let inner
+		       ((m #x100)
+			(n (char->integer (read-char port))))
+		     (cond ((< m b)
+			    (inner (* m #x100)
+				   (+ (* n #x100)
+				      (char->integer (read-char port)))))
+			   ((< n b) n)
+			   (else (outer)))))))))
+	  (simple-random-state))
+      (copy-random-state
+       (guarantee-random-state state 'MAKE-RANDOM-STATE))))
 
 (define (simple-random-state)
   (initial-random-state
@@ -373,7 +368,7 @@ USA.
 	 (flo:vector-set! v1 i (flo:vector-ref v2 i)))))))
 
 (define (guarantee-random-state state procedure)
-  (if state
+  (if (if (default-object? state) #f state)
       (begin
 	(if (not (random-state? state))
 	    (error:wrong-type-argument state "random state" procedure))
diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm
index 0e744708e..3fb220baf 100644
--- a/v7/src/runtime/unsyn.scm
+++ b/v7/src/runtime/unsyn.scm
@@ -1,9 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: unsyn.scm,v 14.31 2004/11/19 06:56:37 cph Exp $
+$Id: unsyn.scm,v 14.32 2004/11/19 17:38:51 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1994,1995,1996,2001,2002 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -46,7 +47,6 @@ USA.
 			     (QUOTATION ,unsyntax-QUOTATION)
 			     (SEQUENCE ,unsyntax-SEQUENCE-object)
 			     (THE-ENVIRONMENT ,unsyntax-THE-ENVIRONMENT-object)
-			     (UNASSIGNED? ,unsyntax-UNASSIGNED?-object)
 			     (VARIABLE ,unsyntax-VARIABLE-object))))
   unspecific)
 
@@ -189,9 +189,6 @@ USA.
       '()
       `(,(unsyntax-object value))))
 
-(define (unsyntax-UNASSIGNED?-object object)
-  `(DEFAULT-OBJECT? ,(unassigned?-name object)))
-
 (define (unsyntax-COMMENT-object comment)
   (let ((expression (unsyntax-object (comment-expression comment))))
     (if unsyntaxer:show-comments?