From: Chris Hanson Date: Wed, 30 Mar 2005 03:53:06 +0000 (+0000) Subject: Reimplement the mechanism that is used to determine when X-Git-Tag: 20090517-FFI~1343 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=908ba96d35d03c0bf1012d80010e5d8cecbc3b50;p=mit-scheme.git Reimplement the mechanism that is used to determine when canonicalization of symbols takes effect. In the new mechanism, calls to the parser can optionally supply an environment in place of the parser table that could previously be given, and the variable *PARSER-CANONICALIZE-SYMBOLS?* is looked up in that environment. The environment defaults to the nearest REPL environment. This causes canonicalization to be effect in environments that specify it, and not in other environments. In addition, the other parser parameters were changed to use this same model, including the parser table. Likewise, the unparser table is now managed this way, and callers of the unparser may supply an environment in place of the previously accepted unparser table. (The unparser needs a rewrite, though, so no further changes were made to it.) --- diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm index 9935c374a..28dce3b81 100644 --- a/v7/src/6001/make.scm +++ b/v7/src/6001/make.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: make.scm,v 15.37 2004/12/13 03:22:21 cph Exp $ +$Id: make.scm,v 15.38 2005/03/30 03:52:20 cph Exp $ Copyright 1991,1992,1993,1995,1996,1998 Massachusetts Institute of Technology -Copyright 1999,2001,2002,2004 Massachusetts Institute of Technology +Copyright 1999,2001,2002,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -44,11 +44,9 @@ USA. ;;; Customize the runtime system: (set! repl:allow-restart-notifications? #f) (set! repl:write-result-hash-numbers? #f) -(set! *unparse-disambiguate-null-as-itself?* #f) -(set! *unparse-disambiguate-null-lambda-list?* true) -(set! *pp-default-as-code?* true) +(set! *pp-default-as-code?* #t) (set! *pp-named-lambda->define?* 'LAMBDA) -(set! x-graphics:auto-raise? true) +(set! x-graphics:auto-raise? #t) (set! (access write-result:undefined-value-is-special? (->environment '(RUNTIME USER-INTERFACE))) #f) diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm index b551610e5..f1a39c032 100644 --- a/v7/src/edwin/autold.scm +++ b/v7/src/edwin/autold.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: autold.scm,v 1.65 2003/02/14 18:28:10 cph Exp $ +$Id: autold.scm,v 1.66 2005/03/30 03:52:58 cph Exp $ -Copyright 1986, 1989-2001 Massachusetts Institute of Technology +Copyright 1987,1989,1990,1991,1992,1999 Massachusetts Institute of Technology +Copyright 2000,2001,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -226,6 +227,5 @@ Second arg PURIFY? means purify the file's contents after loading; (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (fluid-let ((load/suppress-loading-message? #t) - (*parser-canonicalize-symbols?* #t)) + (fluid-let ((load/suppress-loading-message? #t)) (load filename environment 'DEFAULT purify?))))))) \ No newline at end of file diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index eaaf2ed13..492e3bbd0 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: schmod.scm,v 1.68 2004/01/16 19:26:06 cph Exp $ +$Id: schmod.scm,v 1.69 2005/03/30 03:53:06 cph Exp $ Copyright 1986,1989,1990,1991,1992,1998 Massachusetts Institute of Technology -Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology +Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -222,18 +222,21 @@ The following commands evaluate Scheme expressions: (standard-completion (extract-string start end) (lambda (prefix if-unique if-not-unique if-not-found) (let ((completions - (let ((completions - (obarray-completions - (if *parser-canonicalize-symbols?* - (string-downcase prefix) - prefix)))) - (if (not bound-only?) - completions - (let ((environment (evaluation-environment #f))) - (list-transform-positive completions + (let ((environment (evaluation-environment #f))) + (let ((completions + (obarray-completions + (if (and bound-only? + (environment-lookup + environment + '*PARSER-CANONICALIZE-SYMBOLS?*)) + (string-downcase prefix) + prefix)))) + (if bound-only? + (keep-matching-items completions (lambda (name) - (environment-bound? environment name)))))))) - (cond ((null? completions) + (environment-bound? environment name))) + completions))))) + (cond ((not (pair? completions)) (if-not-found)) ((null? (cdr completions)) (if-unique (system-pair-car (car completions)))) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 0ef389beb..a6c085283 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: input.scm,v 14.30 2004/11/19 17:40:30 cph Exp $ +$Id: input.scm,v 14.31 2005/03/30 03:49:59 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1997,1999,2002,2003 Massachusetts Institute of Technology -Copyright 2004 Massachusetts Institute of Technology +Copyright 2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -189,13 +189,8 @@ USA. (define (read-string delimiters #!optional port) (input-port/read-string (optional-input-port port 'READ-STRING) delimiters)) -(define (read #!optional port parser-table) - (parse-object (optional-input-port port 'READ) - (if (default-object? parser-table) - (current-parser-table) - (begin - (guarantee-parser-table parser-table 'READ) - parser-table)))) +(define (read #!optional port environment) + (parse-object (optional-input-port port 'READ) environment)) (define (read-line #!optional port) (input-port/read-line (optional-input-port port 'READ-LINE))) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index c3f88b9e0..eb5e659c1 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.69 2005/03/29 05:03:53 cph Exp $ +$Id: load.scm,v 14.70 2005/03/30 03:50:09 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology -Copyright 2004 Massachusetts Institute of Technology +Copyright 2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -219,7 +219,7 @@ USA. purify?)) (let ((value-stream (lambda () - (eval-stream (read-stream port) environment)))) + (eval-stream (read-stream port environment) environment)))) (if load-noisily? (write-stream (value-stream) (lambda (exp&value) @@ -341,14 +341,14 @@ USA. (cdr frob)))))) object)) -(define (read-file filename) +(define (read-file filename #!optional environment) (call-with-input-file (pathname-default-version filename 'NEWEST) (lambda (port) - (stream->list (read-stream port))))) + (stream->list (read-stream port environment))))) -(define (read-stream port) +(define (read-stream port environment) (parse-objects port - (current-parser-table) + environment (lambda (object) (and (eof-object? object) (begin diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index c97d22c3e..4e0821ba4 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: option.scm,v 14.45 2005/03/08 20:45:24 cph Exp $ +$Id: option.scm,v 14.46 2005/03/30 03:52:00 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1997,1998,2001,2002 Massachusetts Institute of Technology @@ -61,10 +61,9 @@ USA. (define (make-load-environment) (extend-top-level-environment system-global-environment)) - (fluid-let ((*parser-canonicalize-symbols?* #t)) - (if (memq name loaded-options) - name - (find-option *options* *parent*))))) + (if (memq name loaded-options) + name + (find-option *options* *parent*)))) (define (define-load-option name . loaders) (set! *options* (cons (cons name loaders) *options*)) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index ce383aca3..f3c81e01b 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: output.scm,v 14.35 2004/11/19 17:37:48 cph Exp $ +$Id: output.scm,v 14.36 2005/03/30 03:50:18 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1999,2001,2002,2003 Massachusetts Institute of Technology -Copyright 2004 Massachusetts Institute of Technology +Copyright 2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -63,8 +63,8 @@ USA. (define (output-port/discretionary-flush port) ((port/operation/discretionary-flush-output port) port)) -(define (output-port/write-object port object unparser-table) - (unparse-object/top-level object port #t unparser-table)) +(define (output-port/write-object port object environment) + (unparse-object/top-level object port #t environment)) (define (output-port/x-size port) (or (let ((operation (port/operation port 'X-SIZE))) @@ -138,24 +138,19 @@ USA. (fix:> n 0))) (output-port/discretionary-flush port)))) -(define (display object #!optional port unparser-table) +(define (display object #!optional port environment) (let ((port (optional-output-port port 'DISPLAY))) - (unparse-object/top-level object port #f - (optional-unparser-table unparser-table - 'DISPLAY)) + (unparse-object/top-level object port #f environment) (output-port/discretionary-flush port))) -(define (write object #!optional port unparser-table) +(define (write object #!optional port environment) (let ((port (optional-output-port port 'WRITE))) - (output-port/write-object port object - (optional-unparser-table unparser-table 'WRITE)) + (output-port/write-object port object environment) (output-port/discretionary-flush port))) -(define (write-line object #!optional port unparser-table) +(define (write-line object #!optional port environment) (let ((port (optional-output-port port 'WRITE-LINE))) - (output-port/write-object port object - (optional-unparser-table unparser-table - 'WRITE-LINE)) + (output-port/write-object port object environment) (output-port/write-char port #\newline) (output-port/discretionary-flush port))) @@ -178,11 +173,6 @@ USA. (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/parse.scm b/v7/src/runtime/parse.scm index cd89f56f9..50aeebf2c 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: parse.scm,v 14.57 2004/11/19 18:15:01 cph Exp $ +$Id: parse.scm,v 14.58 2005/03/30 03:50:26 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology -Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology +Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -34,14 +34,17 @@ USA. (define *parser-canonicalize-symbols?* #t) (define *parser-associate-positions?* #f) (define ignore-extra-list-closes #t) +(define runtime-parser-radix 10) +(define runtime-parser-canonicalize-symbols? #t) +(define runtime-parser-associate-positions? #t) -(define (parse-object port table) - ((top-level-parser port) port table)) +(define (parse-object port environment) + ((top-level-parser port) port environment)) -(define (parse-objects port table last-object?) +(define (parse-objects port environment last-object?) (let ((parser (top-level-parser port))) (let loop () - (let ((object (parser port table))) + (let ((object (parser port environment))) (if (last-object? object) '() (cons-stream object (loop))))))) @@ -50,9 +53,9 @@ USA. (or (port/operation port 'READ) (let ((read-start (port/operation port 'READ-START)) (read-finish (port/operation port 'READ-FINISH))) - (lambda (port table) + (lambda (port environment) (if read-start (read-start port)) - (let ((db (initial-db port table))) + (let ((db (initial-db port environment))) (let ((object (dispatch port db 'TOP-LEVEL))) (if read-finish (read-finish port)) (finish-parsing object db))))))) @@ -102,6 +105,8 @@ USA. (define char-set/atom-delimiters) (define char-set/symbol-quotes) (define char-set/number-leaders) +(define *parser-table*) +(define runtime-parser-table) (define (initialize-package!) (let* ((constituents @@ -161,7 +166,8 @@ USA. (set! char-set/atom-delimiters atom-delimiters) (set! char-set/symbol-quotes symbol-quotes) (set! char-set/number-leaders number-leaders)) - (set-current-parser-table! system-global-parser-table) + (set! *parser-table* system-global-parser-table) + (set! runtime-parser-table system-global-parser-table) (initialize-condition-types!)) (define-integrable (atom-delimiter? char) @@ -211,38 +217,38 @@ USA. continue-parsing) (define (handler:atom port db ctx char) - db ctx - (receive (string quoted?) (parse-atom port (list char)) + ctx + (receive (string quoted?) (parse-atom port db (list char)) (if quoted? (%string->symbol string) - (or (string->number string *parser-radix*) + (or (string->number string (db-radix db)) (%string->symbol string))))) (define (handler:symbol port db ctx char) - db ctx - (receive (string quoted?) (parse-atom port (list char)) + ctx + (receive (string quoted?) (parse-atom port db (list char)) quoted? (%string->symbol string))) (define (handler:number port db ctx char1 char2) - db ctx - (parse-number port (list char1 char2))) + ctx + (parse-number port db (list char1 char2))) -(define (parse-number port prefix) - (let ((string (parse-atom/no-quoting port prefix))) - (or (string->number string *parser-radix*) +(define (parse-number port db prefix) + (let ((string (parse-atom/no-quoting port db prefix))) + (or (string->number string (db-radix db)) (error:illegal-number string)))) -(define (parse-atom port prefix) - (parse-atom-1 port prefix #t)) +(define (parse-atom port db prefix) + (parse-atom-1 port db prefix #t)) -(define (parse-atom/no-quoting port prefix) - (parse-atom-1 port prefix #f)) +(define (parse-atom/no-quoting port db prefix) + (parse-atom-1 port db prefix #f)) -(define (parse-atom-1 port prefix quoting?) +(define (parse-atom-1 port db prefix quoting?) (let ((port* (open-output-string)) (canon - (if *parser-canonicalize-symbols?* + (if (db-canonicalize-symbols? db) char-downcase identity-procedure)) (%read @@ -425,22 +431,22 @@ USA. (integer->char (fix:+ (fix:lsh (fix:+ (fix:lsh d1 3) d2) 3) d3)))))) (define (handler:false port db ctx char1 char2) - db ctx - (let ((string (parse-atom/no-quoting port (list char1 char2)))) + ctx + (let ((string (parse-atom/no-quoting port db (list char1 char2)))) (if (not (string-ci=? string "#f")) (error:illegal-boolean string))) #f) (define (handler:true port db ctx char1 char2) - db ctx - (let ((string (parse-atom/no-quoting port (list char1 char2)))) + ctx + (let ((string (parse-atom/no-quoting port db (list char1 char2)))) (if (not (string-ci=? string "#t")) (error:illegal-boolean string))) #t) (define (handler:bit-string port db ctx char1 char2) - db ctx char1 char2 - (let ((string (parse-atom/no-quoting port '()))) + ctx char1 char2 + (let ((string (parse-atom/no-quoting port db '()))) (let ((n-bits (string-length string))) (unsigned-integer->bit-string n-bits @@ -478,8 +484,8 @@ USA. (loop))))))))) (define (handler:named-constant port db ctx char1 char2) - db ctx char1 char2 - (let ((name (parse-atom/no-quoting port '()))) + ctx char1 char2 + (let ((name (parse-atom/no-quoting port db '()))) (cond ((string-ci=? name "null") '()) ((string-ci=? name "false") #f) ((string-ci=? name "true") #t) @@ -498,8 +504,8 @@ USA. (define lambda-key-tag (object-new-type (ucode-type constant) 5)) (define (handler:unhash port db ctx char1 char2) - db ctx char1 char2 - (let ((object (parse-unhash (parse-number port '())))) + ctx char1 char2 + (let ((object (parse-unhash (parse-number port db '())))) ;; This may seem a little random, because #@N doesn't just ;; return an object. However, the motivation for this piece of ;; syntax is convenience -- and 99.99% of the time the result of @@ -573,17 +579,39 @@ USA. char)) (define-structure db - (parser-table #f read-only #t) + (environment #f read-only #t) (shared-objects #f read-only #t) (get-position #f read-only #t) position-mapping) -(define (initial-db port table) - (make-db table (make-shared-objects) (position-operation port) '())) +(define (initial-db port environment) + (let ((environment + (if (or (default-object? environment) + (parser-table? environment)) + (nearest-repl/environment) + (begin + (guarantee-environment environment #f) + environment)))) + (make-db environment + (make-shared-objects) + (position-operation port environment) + '()))) + +(define (db-radix db) + (environment-lookup (db-environment db) '*PARSER-RADIX*)) + +(define (db-canonicalize-symbols? db) + (environment-lookup (db-environment db) '*PARSER-CANONICALIZE-SYMBOLS?*)) + +(define (db-associate-positions? db) + (environment-lookup (db-environment db) '*PARSER-ASSOCIATE-POSITIONS?*)) + +(define (db-parser-table db) + (environment-lookup (db-environment db) '*PARSER-TABLE*)) -(define (position-operation port) +(define (position-operation port environment) (let ((default (lambda (port) port #f))) - (if *parser-associate-positions?* + (if (environment-lookup environment '*PARSER-ASSOCIATE-POSITIONS?*) (or (port/operation port 'POSITION) default) default))) @@ -598,7 +626,7 @@ USA. (db-position-mapping db))))) (define-integrable (finish-parsing object db) - (if *parser-associate-positions?* + (if (db-associate-positions? db) (cons object (db-position-mapping db)) object)) diff --git a/v7/src/runtime/partab.scm b/v7/src/runtime/partab.scm index cfb7a1e94..cebc5d9f9 100644 --- a/v7/src/runtime/partab.scm +++ b/v7/src/runtime/partab.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: partab.scm,v 14.8 2004/01/15 21:00:12 cph Exp $ +$Id: partab.scm,v 14.9 2005/03/30 03:50:36 cph Exp $ -Copyright 1988,1996,2004 Massachusetts Institute of Technology +Copyright 1988,1996,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -42,30 +42,12 @@ USA. (error:wrong-type-argument special "dispatch vector" 'MAKE-PARSER-TABLE)) (%make-parser-table initial special)) -(define (guarantee-parser-table table caller) - (if (not (parser-table? table)) - (error:wrong-type-argument table "parser table" caller)) - table) +(define-guarantee parser-table "parser table") (define (parser-table/copy table) (%make-parser-table (vector-copy (parser-table/initial table)) (vector-copy (parser-table/special table)))) -(define (current-parser-table) - *current-parser-table*) - -(define (set-current-parser-table! table) - (guarantee-parser-table table 'SET-CURRENT-PARSER-TABLE!) - (set! *current-parser-table* table) - unspecific) - -(define (with-current-parser-table table thunk) - (guarantee-parser-table table 'WITH-CURRENT-PARSER-TABLE) - (fluid-let ((*current-parser-table* table)) - (thunk))) - -(define *current-parser-table*) - (define (parser-table/entry table key) (receive (v n) (decode-key table key 'PARSER-TABLE/ENTRY) (vector-ref v n))) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index f9b9de645..b56d35a7a 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: pp.scm,v 14.46 2003/02/14 18:28:33 cph Exp $ +$Id: pp.scm,v 14.47 2005/03/30 03:50:48 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1995,1996,1999 Massachusetts Institute of Technology -Copyright 2001,2002,2003 Massachusetts Institute of Technology +Copyright 2001,2002,2003,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -519,10 +519,7 @@ USA. (define print-procedure) (define (kernel/print-procedure nodes optimistic pessimistic depth) - (if (and *unparse-disambiguate-null-lambda-list?* - (member (car nodes) '("#f" "#F"))) - (*unparse-string "()") - (print-node (car nodes) optimistic 0)) + (print-node (car nodes) optimistic 0) (let ((rest (cdr nodes))) (if (not (null? rest)) (begin @@ -692,7 +689,7 @@ USA. (unparser (make-unparser-state port list-depth #t - (current-unparser-table)) + (nearest-repl/environment)) object)))) (define (walk-pair pair list-depth) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 71bad22de..25a911612 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.535 2005/03/29 05:04:09 cph Exp $ +$Id: runtime.pkg,v 14.536 2005/03/30 03:51:02 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -2464,9 +2464,15 @@ USA. *parser-associate-positions?* *parser-canonicalize-symbols?* *parser-radix* + *parser-table* parse-object parse-objects system-global-parser-table) + (export (runtime) + (*parser-associate-positions?* runtime-parser-associate-positions?) + (*parser-canonicalize-symbols?* runtime-parser-canonicalize-symbols?) + (*parser-radix* runtime-parser-radix) + (*parser-table* runtime-parser-table)) (export (runtime character) char-set/atom-delimiters) (export (runtime syntactic-closures) @@ -2490,15 +2496,13 @@ USA. (files "partab") (parent (runtime)) (export () - current-parser-table + error:not-parser-table guarantee-parser-table make-parser-table parser-table/copy parser-table/entry parser-table/set-entry! - parser-table? - set-current-parser-table! - with-current-parser-table) + parser-table?) (export (runtime parser) parser-table/initial parser-table/special)) @@ -4003,8 +4007,6 @@ USA. (export () *unparse-abbreviate-quotations?* *unparse-compound-procedure-names?* - *unparse-disambiguate-null-as-itself?* - *unparse-disambiguate-null-lambda-list?* *unparse-primitives-by-name?* *unparse-uninterned-symbols-by-name?* *unparse-with-datum?* @@ -4013,19 +4015,17 @@ USA. *unparser-list-depth-limit* *unparser-radix* *unparser-string-length-limit* - current-unparser-table + *unparser-table* + error:not-unparser-state + error:not-unparser-table guarantee-unparser-state guarantee-unparser-table - make-unparser-state make-unparser-table system-global-unparser-table unparse-char unparse-object unparse-string - unparser-state/list-depth unparser-state/port - unparser-state/slashify? - unparser-state/unparser-table unparser-state? unparser-table/copy unparser-table/entry @@ -4038,6 +4038,7 @@ USA. (export (runtime output-port) unparse-object/top-level) (export (runtime pretty-printer) + make-unparser-state unparse-list/prefix-pair? unparse-list/unparser unparse-vector/unparser) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index b809bdef0..1555be790 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: unpars.scm,v 14.62 2004/11/19 07:14:57 cph Exp $ +$Id: unpars.scm,v 14.63 2005/03/30 03:51:11 cph Exp $ Copyright 1986,1987,1990,1991,1992,1995 Massachusetts Institute of Technology -Copyright 1996,2001,2002,2003,2004 Massachusetts Institute of Technology +Copyright 1996,2001,2002,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -41,20 +41,19 @@ USA. (set! *unparse-primitives-by-name?* #f) (set! *unparse-uninterned-symbols-by-name?* #f) (set! *unparse-with-maximum-readability?* #f) - (set! *unparse-disambiguate-null-as-itself?* #t) - (set! *unparse-disambiguate-null-lambda-list?* #f) (set! *unparse-compound-procedure-names?* #t) (set! *unparse-with-datum?* #f) (set! *unparse-abbreviate-quotations?* #f) (set! system-global-unparser-table (make-system-global-unparser-table)) - (set! *default-list-depth* 0) + (set! *unparser-table* system-global-unparser-table) + (set! *default-unparser-state* #f) (set! non-canon-symbol-quoted (char-set-union char-set/atom-delimiters char-set/symbol-quotes)) (set! canon-symbol-quoted (char-set-union non-canon-symbol-quoted char-set:upper-case)) - (set-current-unparser-table! system-global-unparser-table)) + unspecific) (define *unparser-radix*) (define *unparser-list-breadth-limit*) @@ -63,24 +62,14 @@ USA. (define *unparse-primitives-by-name?*) (define *unparse-uninterned-symbols-by-name?*) (define *unparse-with-maximum-readability?*) -(define *unparse-disambiguate-null-as-itself?*) -(define *unparse-disambiguate-null-lambda-list?*) (define *unparse-compound-procedure-names?*) (define *unparse-with-datum?*) (define *unparse-abbreviate-quotations?*) (define system-global-unparser-table) -(define *default-list-depth*) +(define *unparser-table*) +(define *default-unparser-state*) (define non-canon-symbol-quoted) (define canon-symbol-quoted) -(define *current-unparser-table*) - -(define (current-unparser-table) - *current-unparser-table*) - -(define (set-current-unparser-table! table) - (guarantee-unparser-table table 'SET-CURRENT-UNPARSER-TABLE!) - (set! *current-unparser-table* table) - unspecific) (define (make-system-global-unparser-table) (let ((table (make-unparser-table unparse/default))) @@ -97,7 +86,7 @@ USA. (INTERNED-SYMBOL ,unparse/interned-symbol) (LIST ,unparse/pair) (NEGATIVE-FIXNUM ,unparse/number) - (NULL ,unparse/null) + (FALSE ,unparse/false) (POSITIVE-FIXNUM ,unparse/number) (PRIMITIVE ,unparse/primitive-procedure) (PROCEDURE ,unparse/compound-procedure) @@ -117,10 +106,7 @@ USA. (conc-name unparser-table/)) (dispatch-vector #f read-only #t)) -(define (guarantee-unparser-table table procedure) - (if (not (unparser-table? table)) - (error:wrong-type-argument table "unparser table" procedure)) - table) +(define-guarantee unparser-table "unparser table") (define (make-unparser-table default-method) (%make-unparser-table @@ -142,18 +128,13 @@ USA. (port #f read-only #t) (list-depth #f read-only #t) (slashify? #f read-only #t) - (unparser-table #f read-only #t)) + (environment #f read-only #t)) -(define (guarantee-unparser-state state procedure) - (if (not (unparser-state? state)) - (error:wrong-type-argument state "unparser state" procedure)) - state) +(define-guarantee unparser-state "unparser state") (define (with-current-unparser-state state procedure) (guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE) - (fluid-let - ((*default-list-depth* (unparser-state/list-depth state)) - (*current-unparser-table* (unparser-state/unparser-table state))) + (fluid-let ((*default-unparser-state* state)) (procedure (unparser-state/port state)))) ;;;; Top Level @@ -172,33 +153,52 @@ USA. (unparser-state/port state) (unparser-state/list-depth state) (unparser-state/slashify? state) - (unparser-state/unparser-table state))) - -(define (unparse-object/top-level object port slashify? table) - (unparse-object/internal object port *default-list-depth* slashify? table)) - -(define (unparse-object/internal object port list-depth slashify? table) + (unparser-state/environment state))) + +(define (unparse-object/top-level object port slashify? environment) + (unparse-object/internal + object + port + (if *default-unparser-state* + (unparser-state/list-depth *default-unparser-state*) + 0) + slashify? + (if (or (default-object? environment) + (unparser-table? environment)) + (if *default-unparser-state* + (unparser-state/environment *default-unparser-state*) + (nearest-repl/environment)) + (begin + (guarantee-environment environment #f) + environment)))) + +(define (unparse-object/internal object port list-depth slashify? environment) (fluid-let ((*output-port* port) (*list-depth* list-depth) (*slashify?* slashify?) - (*unparser-table* table) - (*dispatch-vector* (unparser-table/dispatch-vector table))) + (*environment* environment) + (*dispatch-table* + (unparser-table/dispatch-vector + (let ((table + (environment-lookup environment '*UNPARSER-TABLE*))) + (guarantee-unparser-table table #f) + table)))) (*unparse-object object))) (define-integrable (invoke-user-method method object) (method (make-unparser-state *output-port* *list-depth* *slashify?* - *unparser-table*) + *environment*) object)) (define *list-depth*) (define *slashify?*) -(define *unparser-table*) -(define *dispatch-vector*) +(define *environment*) +(define *dispatch-table*) (define (*unparse-object object) - ((vector-ref *dispatch-vector* + ((vector-ref *dispatch-table* ((ucode-primitive primitive-object-type 1) object)) object)) @@ -302,19 +302,13 @@ USA. (SEQUENCE-2 . SEQUENCE) (SEQUENCE-3 . SEQUENCE))) -(define (unparse/null object) - (if (eq? object '()) - (if (and (eq? object #f) - (not *unparse-disambiguate-null-as-itself?*)) - (*unparse-string "#f") - (*unparse-string "()")) - (if (eq? object #f) - (*unparse-string "#f") - (unparse/default object)))) +(define (unparse/false object) + (if (eq? object #f) + (*unparse-string "#f") + (unparse/default object))) (define (unparse/constant object) - (cond ((not object) (*unparse-string "#f")) - ((null? object) (*unparse-string "()")) + (cond ((null? object) (*unparse-string "()")) ((eq? object #t) (*unparse-string "#t")) ((default-object? object) (*unparse-string "#!default")) ((eof-object? object) (*unparse-string "#!eof")) @@ -344,10 +338,12 @@ USA. (define (unparse-symbol symbol) (let ((s (symbol-name symbol))) - (if (or (string-find-next-char-in-set s - (if *parser-canonicalize-symbols?* - canon-symbol-quoted - non-canon-symbol-quoted)) + (if (or (string-find-next-char-in-set + s + (if (environment-lookup *environment* + '*PARSER-CANONICALIZE-SYMBOLS?*) + canon-symbol-quoted + non-canon-symbol-quoted)) (fix:= (string-length s) 0) (and (char-set-member? char-set/number-leaders (string-ref s 0)) (string->number s))) @@ -490,26 +486,12 @@ USA. (invoke-user-method unparse-record record))) (define (unparse/pair pair) - (let ((prefix (unparse-list/prefix-pair? pair))) - (if prefix - (unparse-list/prefix-pair prefix pair) - (let ((method (unparse-list/unparser pair))) - (cond (method - (invoke-user-method method pair)) - ((and *unparse-disambiguate-null-lambda-list?* - (eq? (safe-car pair) 'LAMBDA) - (pair? (safe-cdr pair)) - (null? (safe-car (safe-cdr pair))) - (pair? (safe-cdr (safe-cdr pair)))) - (limit-unparse-depth - (lambda () - (*unparse-char #\() - (*unparse-object (safe-car pair)) - (*unparse-string " ()") - (unparse-tail (safe-cdr (safe-cdr pair)) 3) - (*unparse-char #\))))) - (else - (unparse-list pair))))))) + (cond ((unparse-list/prefix-pair? pair) + => (lambda (prefix) (unparse-list/prefix-pair prefix pair))) + ((unparse-list/unparser pair) + => (lambda (method) (invoke-user-method method pair))) + (else + (unparse-list pair)))) (define (unparse-list list) (limit-unparse-depth diff --git a/v7/src/sicp/studen.scm b/v7/src/sicp/studen.scm index 4185b8442..9c7c25a8b 100644 --- a/v7/src/sicp/studen.scm +++ b/v7/src/sicp/studen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: studen.scm,v 1.13 2003/02/14 18:28:35 cph Exp $ +$Id: studen.scm,v 1.14 2005/03/30 03:52:40 cph Exp $ Copyright (c) 1987-1999 Massachusetts Institute of Technology @@ -98,12 +98,12 @@ USA. (access set-atom-delimiters! (->environment '(runtime parser)))) (define (enable-system-syntax) - (set-current-parser-table! system-global-parser-table) + (set! *parser-table* system-global-parser-table) (set-atom-delimiters! 'mit-scheme) (set-repl/syntax-table! (nearest-repl) system-global-syntax-table)) (define (disable-system-syntax) - (set-current-parser-table! *student-parser-table*) + (set! *parser-table* *student-parser-table*) (set-atom-delimiters! 'sicp) (set-repl/syntax-table! (nearest-repl) *student-syntax-table*))