#| -*-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.
;;; 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)
#| -*-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.
(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
#| -*-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.
(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))))
#| -*-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.
(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)))
#| -*-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.
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)
(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
#| -*-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
(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*))
#| -*-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.
(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)))
(fix:> n 0)))
(output-port/discretionary-flush port))))
\f
-(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)))
(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)))
\f
;;;; Tabular output
#| -*-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.
(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)))))))
(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)))))))
(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
(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)
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))))
\f
-(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
(integer->char (fix:+ (fix:lsh (fix:+ (fix:lsh d1 3) d2) 3) d3))))))
\f
(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
(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)
(define lambda-key-tag (object-new-type (ucode-type constant) 5))
\f
(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
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)))
(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))
\f
#| -*-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.
(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)))
#| -*-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.
(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
(unparser (make-unparser-state port
list-depth
#t
- (current-unparser-table))
+ (nearest-repl/environment))
object))))
\f
(define (walk-pair pair list-depth)
#| -*-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
*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)
(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))
(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?*
*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
(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)
#| -*-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.
(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*)
(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)))
(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)
(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
(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))))
\f
;;;; Top Level
(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))
\f
(SEQUENCE-2 . SEQUENCE)
(SEQUENCE-3 . SEQUENCE)))
\f
-(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"))
(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)))
(invoke-user-method unparse-record record)))
\f
(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
#| -*-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
(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*))
projects / mit-scheme.git / commitdiff