From b0b0eb8bc3f7149e9cd1c841165108ca4529156a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 19 Nov 2004 17:40:30 +0000 Subject: [PATCH] DEFAULT-OBJECT? is no longer a special form. --- v7/src/edwin/evlcom.scm | 27 ++++++++------------ v7/src/runtime/input.scm | 20 ++++++--------- v7/src/runtime/output.scm | 34 ++++++++----------------- v7/src/runtime/random.scm | 53 ++++++++++++++++++--------------------- v7/src/runtime/unsyn.scm | 7 ++---- 5 files changed, 55 insertions(+), 86 deletions(-) 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? -- 2.25.1