fixed bug in environ that causes substring to fail when one of the items is "foo=".
This commit is contained in:
Abdulaziz Ghuloum
parent
212224b4cf
commit
1a7a4e1c2a
|
|
@ -1,615 +0,0 @@
|
||||||
|
|
||||||
;;; Copied From CSUG7:
|
|
||||||
|
|
||||||
;;; procedure: (pretty-format sym)
|
|
||||||
;;; returns: see below
|
|
||||||
;;; procedure: (pretty-format sym fmt)
|
|
||||||
;;; returns: unspecified
|
|
||||||
|
|
||||||
;;; By default, the pretty printer uses a generic algorithm for printing
|
|
||||||
;;; each form. This procedure is used to override this default and guide
|
|
||||||
;;; the pretty-printers treatment of specific forms. The symbol sym
|
|
||||||
;;; names a syntactic form or procedure. With just one argument,
|
|
||||||
;;; pretty-format returns the current format associated with sym, or #f
|
|
||||||
;;; if no format is associated with sym.
|
|
||||||
|
|
||||||
;;; In the two-argument case, the format fmt is associated with sym for
|
|
||||||
;;; future invocations of the pretty printer. fmt must be in the
|
|
||||||
;;; formatting language described below.
|
|
||||||
|
|
||||||
|
|
||||||
;;; <fmt> ::= (quote symbol)
|
|
||||||
;;; | var
|
|
||||||
;;; | symbol
|
|
||||||
;;; | (read-macro string symbol)
|
|
||||||
;;; | (meta)
|
|
||||||
;;; | (bracket . fmt-tail)
|
|
||||||
;;; | (alt fmt fmt*)
|
|
||||||
;;; | fmt-tail
|
|
||||||
;;; fmt-tail ::= ()
|
|
||||||
;;; | (tab fmt ...)
|
|
||||||
;;; | (fmt tab ...)
|
|
||||||
;;; | (tab fmt . fmt-tail)
|
|
||||||
;;; | (fmt ...)
|
|
||||||
;;; | (fmt . fmt-tail)
|
|
||||||
;;; | (fill tab fmt ...)
|
|
||||||
;;; tab ::= int
|
|
||||||
;;; | #f
|
|
||||||
|
|
||||||
;;; Some of the format forms are used for matching when there are
|
|
||||||
;;; multiple alternatives, while others are used for matching and
|
|
||||||
;;; control indentation or printing. A description of each fmt is given
|
|
||||||
;;; below.
|
|
||||||
|
|
||||||
|
|
||||||
;;; (quote symbol):
|
|
||||||
;;; This matches only the symbol symbol.
|
|
||||||
|
|
||||||
;;; var:
|
|
||||||
;;; This matches any symbol.
|
|
||||||
|
|
||||||
;;; symbol:
|
|
||||||
;;; This matches any input.
|
|
||||||
|
|
||||||
;;; (read-macro string symbol):
|
|
||||||
;;; This is used for read macros like quote and syntax. It matches any
|
|
||||||
;;; input of the form (symbol subform). For forms that match, the pretty
|
|
||||||
;;; printer prints string immediately followed by subform.
|
|
||||||
|
|
||||||
;;; (meta):
|
|
||||||
;;; This is a special case used for the meta keyword (Section 10.7)
|
|
||||||
;;; which is used as a keyword prefix of another form.
|
|
||||||
|
|
||||||
;;; (alt fmt fmt*):
|
|
||||||
;;; This compares the input against the specified formats and uses the
|
|
||||||
;;; one that is the closest match. Most often, one of the formats will
|
|
||||||
;;; match exactly, but in other cases, as when input is malformed or
|
|
||||||
;;; appears in abstract form in the template of a syntactic abstraction,
|
|
||||||
;;; none of the formats will match exactly.
|
|
||||||
|
|
||||||
;;; (bracket . fmt-tail):
|
|
||||||
;;; This matches any list-structured input and prints the input enclosed
|
|
||||||
;;; in square brackets, i.e., [ and ], rather than parentheses.
|
|
||||||
|
|
||||||
;;; fmt-tail:
|
|
||||||
;;; This matches any list-structured input. Indentation of
|
|
||||||
;;; list-structured forms is determined via the fmt-tail specifier used
|
|
||||||
;;; to the last two cases above. A description of each fmt-tail is given
|
|
||||||
;;; below.
|
|
||||||
|
|
||||||
|
|
||||||
;;; ():
|
|
||||||
;;; This matches an empty list tail.
|
|
||||||
|
|
||||||
;;; (tab fmt ...):
|
|
||||||
;;; This matches the tail of any proper list; if the tail is nonempty
|
|
||||||
;;; and the list does not fit entirely on the current line, a line break
|
|
||||||
;;; is inserted before the first subform of the tail and tab (see below)
|
|
||||||
;;; determines the amount by which this and all subsequent subforms are
|
|
||||||
;;; indented.
|
|
||||||
|
|
||||||
;;; (fmt tab ...):
|
|
||||||
;;; This matches the tail of any proper list; if the tail is nonempty
|
|
||||||
;;; and the list does not fit entirely on the current line, a line break
|
|
||||||
;;; is inserted after the first subform of the tail and tab (see below)
|
|
||||||
;;; determines the amount by which all subsequent subforms are indented.
|
|
||||||
|
|
||||||
;;; (tab fmt . fmt-tail):
|
|
||||||
;;; This matches a nonempty tail if the tail of the tail matches
|
|
||||||
;;; fmt-tail. If the list does not fit entirely on the current line, a
|
|
||||||
;;; line break is inserted before the first subform of the tail and tab
|
|
||||||
;;; (see below) determines the amount by which the subform is indented.
|
|
||||||
|
|
||||||
;;; (fmt ...):
|
|
||||||
;;; This matches the tail of any proper list and specified that no line
|
|
||||||
;;; breaks are to be inserted before or after the current or subsequent
|
|
||||||
;;; subforms.
|
|
||||||
|
|
||||||
;;; (fmt . fmt-tail):
|
|
||||||
;;; This matches a nonempty tail if the tail of the tail matches
|
|
||||||
;;; fmt-tail and specifies that no line break is to be inserted before
|
|
||||||
;;; or after the current subform.
|
|
||||||
|
|
||||||
;;; (fill tab fmt ...):
|
|
||||||
;;; This matches the tail of any proper list and invokes a fill mode in
|
|
||||||
;;; which the forms are packed with as many as will fit on each line. A
|
|
||||||
;;; tab determines the amount by which a list subform is indented. If
|
|
||||||
;;; tab is a nonnegative exact integer int, the subform is indented int
|
|
||||||
;;; spaces in from the character position just after the opening
|
|
||||||
;;; parenthesis or bracket of the parent form. If tab is #f, the
|
|
||||||
;;; standard indentation is used. The standard indentation can be
|
|
||||||
;;; determined or changed via the parameter pretty-standard-indent,
|
|
||||||
;;; which is described later in this section.
|
|
||||||
|
|
||||||
;;; In cases where a format is given that doesn't quite match, the
|
|
||||||
;;; pretty printer tries to use the given format as far as it can. For
|
|
||||||
;;; example, if a format matches a list-structured form with a specific
|
|
||||||
;;; number of subforms, but more or fewer subform are given, the pretty
|
|
||||||
;;; printer will discard or replicate subform formats as necessary.
|
|
||||||
|
|
||||||
;;; Here is an example showing the formatting of let might be specified.
|
|
||||||
|
|
||||||
;;; (pretty-format 'let
|
|
||||||
;;; '(alt (let ([bracket var x] 0 ...) #f e #f e ...)
|
|
||||||
;;; (let var ([bracket var x] 0 ...) #f e #f e ...)))
|
|
||||||
|
|
||||||
;;; Since let comes in two forms, named and unnamed, two alternatives
|
|
||||||
;;; are specified. In either case, the bracket fmt is used to enclose
|
|
||||||
;;; the bindings in square brackets, with all bindings after the first
|
|
||||||
;;; appearing just below the first (and just after the enclosing opening
|
|
||||||
;;; parenthesis), if they don't all fit on one line. Each body form is
|
|
||||||
;;; indented by the standard indentation.
|
|
||||||
|
|
||||||
;;; parameter: pretty-line-length
|
|
||||||
;;; parameter: pretty-one-line-limit
|
|
||||||
;;; The value of each of these parameters must be a positive fixnum.
|
|
||||||
|
|
||||||
;;; The parameters pretty-line-length and pretty-one-line-limit control
|
|
||||||
;;; the output produced by pretty-print. pretty-line-length determines
|
|
||||||
;;; after which character position (starting from the first) on a line
|
|
||||||
;;; the pretty printer attempts to cut off output. This is a soft limit
|
|
||||||
;;; only; if necessary, the pretty-printer will go beyond
|
|
||||||
;;; pretty-line-length.
|
|
||||||
|
|
||||||
;;; pretty-one-line-limit is similar to pretty-line-length, except that
|
|
||||||
;;; it is relative to the first nonblank position on each line of
|
|
||||||
;;; output. It is also a soft limit.
|
|
||||||
|
|
||||||
;;; parameter: pretty-initial-indent
|
|
||||||
;;; The value of this parameter must be a nonnegative fixnum.
|
|
||||||
|
|
||||||
;;; The parameter pretty-initial-indent is used to tell pretty-print
|
|
||||||
;;; where on an output line it has been called. If pretty-initial-indent
|
|
||||||
;;; is zero (the default), pretty-print assumes that the first line of
|
|
||||||
;;; output it produces will start at the beginning of the line. If set
|
|
||||||
;;; to a nonzero value n, pretty-print assumes that the first line will
|
|
||||||
;;; appear at character position n and will adjust its printing of
|
|
||||||
;;; subsequent lines.
|
|
||||||
|
|
||||||
;;; parameter: pretty-standard-indent
|
|
||||||
;;; The value of this parameter must be a nonnegative fixnum.
|
|
||||||
|
|
||||||
;;; This determines the amount by which pretty-print indents
|
|
||||||
;;; subexpressions of most forms, such as let expressions, from the
|
|
||||||
;;; form's keyword or first subexpression.
|
|
||||||
|
|
||||||
;;; parameter: pretty-maximum-lines
|
|
||||||
;;; The parameter pretty-maximum-lines controls how many lines
|
|
||||||
;;; pretty-print prints when it is called. If set to #f (the default),
|
|
||||||
;;; no limit is imposed; if set to a nonnegative fixnum n, at most n
|
|
||||||
;;; lines are printed.
|
|
||||||
|
|
||||||
(let ()
|
|
||||||
|
|
||||||
(begin ;;; symbol printing helpers
|
|
||||||
(define initial?
|
|
||||||
(lambda (c)
|
|
||||||
(or (letter? c) (special-initial? c))))
|
|
||||||
(define letter?
|
|
||||||
(lambda (c)
|
|
||||||
(or (and ($char<= #\a c) ($char<= c #\z))
|
|
||||||
(and ($char<= #\A c) ($char<= c #\Z)))))
|
|
||||||
(define digit?
|
|
||||||
(lambda (c)
|
|
||||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
|
||||||
(define special-initial?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
|
||||||
(define subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(or (initial? x)
|
|
||||||
(digit? x)
|
|
||||||
(special-subsequent? x))))
|
|
||||||
(define special-subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\+ #\- #\. #\@))))
|
|
||||||
(define subsequent*?
|
|
||||||
(lambda (str i n)
|
|
||||||
(or ($fx= i n)
|
|
||||||
(and (subsequent? ($string-ref str i))
|
|
||||||
(subsequent*? str ($fxadd1 i) n)))))
|
|
||||||
(define valid-symbol-string?
|
|
||||||
(lambda (str)
|
|
||||||
(or (let ([n ($string-length str)])
|
|
||||||
(and ($fx>= n 1)
|
|
||||||
(initial? ($string-ref str 0))
|
|
||||||
(subsequent*? str 1 n)))
|
|
||||||
(string=? str "+")
|
|
||||||
(string=? str "-")
|
|
||||||
(string=? str "..."))))
|
|
||||||
|
|
||||||
(define write-symbol-esc-loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless ($fx= i n)
|
|
||||||
(let ([c ($string-ref x i)])
|
|
||||||
(when (memq c '(#\\ #\|))
|
|
||||||
(write-char #\\ p))
|
|
||||||
(write-char c p))
|
|
||||||
(write-symbol-esc-loop x ($fxadd1 i) n p))))
|
|
||||||
(define write-symbol-esc
|
|
||||||
(lambda (x p)
|
|
||||||
(write-char #\| p)
|
|
||||||
(write-symbol-esc-loop x 0 ($string-length x) p)
|
|
||||||
(write-char #\| p)))
|
|
||||||
(define write-symbol
|
|
||||||
(lambda (x p)
|
|
||||||
(let ([str (symbol->string x)])
|
|
||||||
(if (valid-symbol-string? str)
|
|
||||||
(write-char* str p)
|
|
||||||
(write-symbol-esc str p))))))
|
|
||||||
(define (symbol-output symbol) ;-> var output box
|
|
||||||
(define (symbol-output-length str esc?)
|
|
||||||
(define (subs s n i)
|
|
||||||
(cond
|
|
||||||
[(fx= i n) n]
|
|
||||||
[(subsequent? (string-ref s i))
|
|
||||||
(subs s n (fxadd1 i))]
|
|
||||||
[else
|
|
||||||
(esc s n i i)]))
|
|
||||||
(define (esc s n i len)
|
|
||||||
(cond
|
|
||||||
[(fx= i n) (fx+ len 2)] ; for the bars
|
|
||||||
[(memv (string-ref s i) '(#\\ #\|))
|
|
||||||
(esc s n (fx+ i 1) (fx+ len 2))] ;;; for \ escape
|
|
||||||
[else
|
|
||||||
(esc s n (fx+ i 1) (fx+ len 1))]))
|
|
||||||
(define (init s n)
|
|
||||||
(cond
|
|
||||||
[(fx= n 0) 2] ; ||
|
|
||||||
[else
|
|
||||||
(case (string-ref s 0)
|
|
||||||
[(#\+ #\-)
|
|
||||||
(if (fx= n 1)
|
|
||||||
1
|
|
||||||
(esc s n 1 1))]
|
|
||||||
[(#\.)
|
|
||||||
(if (and (fx= n 3)
|
|
||||||
(char=? (string-ref s 1) #\.)
|
|
||||||
(char=? (string-ref s 2) #\.))
|
|
||||||
3
|
|
||||||
(esc s n 1 1))]
|
|
||||||
[else
|
|
||||||
(if (initial? (string-ref s 0))
|
|
||||||
(subs s n 1)
|
|
||||||
(esc s n 1 1))])]))
|
|
||||||
(if esc?
|
|
||||||
(esc str (string-length str) 0 0)
|
|
||||||
(init str (string-length str))))
|
|
||||||
(if (gensym? symbol)
|
|
||||||
`#(var ,symbol
|
|
||||||
,(symbol-output-length (gensym->string symbol) #f)
|
|
||||||
,(symbol-output-length (gensym->unique-string symbol) #t))
|
|
||||||
`#(var ,symbol
|
|
||||||
,(symbol-output-length (symbol->string symbol) #f))))
|
|
||||||
(define (number-output number) ; -> string
|
|
||||||
(number->string number))
|
|
||||||
(define (char-output char) ; -> string
|
|
||||||
(let ([i (char->integer char)])
|
|
||||||
(cond
|
|
||||||
[(fx< i (vector-length char-table))
|
|
||||||
(string-append "#\\" (vector-ref char-table i))]
|
|
||||||
[(fx< i 127)
|
|
||||||
(string-append "#\\" (string char))]
|
|
||||||
[(fx= i 127) "#\\del"]
|
|
||||||
[else (string-append "#\\+" (number->string i))])))
|
|
||||||
(define char-table ; first nonprintable chars
|
|
||||||
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
|
|
||||||
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
|
|
||||||
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
|
|
||||||
(define (string-output str) ; -> string | append
|
|
||||||
(define (f s n i len)
|
|
||||||
(cond
|
|
||||||
[(fx= i n) len]
|
|
||||||
[(memv (string-ref s i) '(#\newline #\" #\\ #\tab #\return))
|
|
||||||
(f s n (fxadd1 i) (fx+ len 2))]
|
|
||||||
[else
|
|
||||||
(f s n (fxadd1 i) (fxadd1 len))]))
|
|
||||||
(let ([n (string-length str)])
|
|
||||||
(let ([m (f str (string-length str) 0 0)])
|
|
||||||
(if (fx= n m)
|
|
||||||
`#(append "\"" ,str "\"")
|
|
||||||
`#(string ,m ,str)))))
|
|
||||||
|
|
||||||
(define (make-output x h i) ;-> output, i
|
|
||||||
(cond
|
|
||||||
[(or (pair? x) (vector? x))
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(cond
|
|
||||||
[(fx< n 0) ;;; shared and already printed
|
|
||||||
(values (ref-output n) i)]
|
|
||||||
[(fx= n 0) ;;; not shared
|
|
||||||
(if (pair? x)
|
|
||||||
(pair-output x h i)
|
|
||||||
(vector-output x h i))]
|
|
||||||
[else ;;; shared and this is the first ref
|
|
||||||
(let ([i (fx- i 1)])
|
|
||||||
(put-hash-table! h x i)
|
|
||||||
(let-values ([(no ni)
|
|
||||||
(if (pair? x)
|
|
||||||
(pair-output x h i)
|
|
||||||
(vector-output x h i))])
|
|
||||||
(values `#(append ,(mark-output i) ,no) ni)))]))]
|
|
||||||
[else
|
|
||||||
(if (pair? x)
|
|
||||||
(pair-output x h i)
|
|
||||||
(vector-output x h i))])]
|
|
||||||
[(symbol? x) (values (symbol-output x) i)]
|
|
||||||
[(number? x) (values (number-output x) i)]
|
|
||||||
[(char? x) (values (char-output x) i)]
|
|
||||||
[(boolean? x) (values (if x "#t" "#f") i)]
|
|
||||||
[(null? x) (values "()" i)]
|
|
||||||
[(eq? x (void)) (values "#<void>" i)]
|
|
||||||
[(eof-object? x) (values "#!eof" i)]
|
|
||||||
[(bwp-object? x) (values "#!bwp" i)]
|
|
||||||
[(hash-table? x) (values "#<hash-table>" i)]
|
|
||||||
[($unbound-object? x) (values "#<unbound-object>" i)]
|
|
||||||
[($forward-ptr? x) (values "#<forward-pointer>" i)]
|
|
||||||
[else (values "#<unknown>" i)]))
|
|
||||||
(define (vector-output x h i)
|
|
||||||
(let* ([n (vector-length x)]
|
|
||||||
[v (make-vector n)])
|
|
||||||
(let f ([idx 0] [i i])
|
|
||||||
(cond
|
|
||||||
[(fx= idx n)
|
|
||||||
(values `#(vector ,v) i)]
|
|
||||||
[else
|
|
||||||
(let-values ([(o i)
|
|
||||||
(make-output (vector-ref x idx) i)])
|
|
||||||
(vector-set! v idx o)
|
|
||||||
(f (fxadd1 idx) i))]))))
|
|
||||||
(define (make-pair-output x h i)
|
|
||||||
;;; first cut, assume no special formatting
|
|
||||||
(errrrrrrrrrrrrrr))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define write-list
|
|
||||||
(lambda (x p h i)
|
|
||||||
(cond
|
|
||||||
[(and (pair? x)
|
|
||||||
(or (not (get-hash-table h x #f))
|
|
||||||
(fxzero? (get-hash-table h x 0))))
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-list (cdr x) p h
|
|
||||||
(writer (car x) p h i))]
|
|
||||||
[(null? x) i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-char #\. p)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer x p h i)])))
|
|
||||||
(define write-vector
|
|
||||||
(lambda (x p h i)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\( p)
|
|
||||||
(let ([n (vector-length x)])
|
|
||||||
(let ([i
|
|
||||||
(cond
|
|
||||||
[(fx> n 0)
|
|
||||||
(let f ([idx 1] [i (writer (vector-ref x 0) p h i)])
|
|
||||||
(cond
|
|
||||||
[(fx= idx n)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(f (fxadd1 idx)
|
|
||||||
(writer (vector-ref x idx) p h i))]))]
|
|
||||||
[else i])])
|
|
||||||
(write-char #\) p)
|
|
||||||
i))))
|
|
||||||
(define write-record
|
|
||||||
(lambda (x p h i)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\[ p)
|
|
||||||
(let ([i (writer (record-name x) p h i)])
|
|
||||||
(let ([n (record-length x)])
|
|
||||||
(let f ([idx 0] [i i])
|
|
||||||
(cond
|
|
||||||
[(fx= idx n)
|
|
||||||
(write-char #\] p)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(f (fxadd1 idx)
|
|
||||||
(writer (record-ref x idx) p h i))]))))))
|
|
||||||
(define macro
|
|
||||||
(lambda (x)
|
|
||||||
(define macro-forms
|
|
||||||
'([quote . "'"]
|
|
||||||
[quasiquote . "`"]
|
|
||||||
[unquote . ","]
|
|
||||||
[unquote-splicing . ",@"]
|
|
||||||
[syntax . "#'"]
|
|
||||||
[|#primitive| . "#%"]))
|
|
||||||
(and (pair? x)
|
|
||||||
(let ([d ($cdr x)])
|
|
||||||
(and (pair? d)
|
|
||||||
(null? ($cdr d))))
|
|
||||||
(assq ($car x) macro-forms))))
|
|
||||||
(define write-pair
|
|
||||||
(lambda (x p h i)
|
|
||||||
(write-char #\( p)
|
|
||||||
(let ([i (writer (car x) p h i)])
|
|
||||||
(let ([i (write-list (cdr x) p h i)])
|
|
||||||
(write-char #\) p)
|
|
||||||
i))))
|
|
||||||
(define write-ref
|
|
||||||
(lambda (n p)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-fixnum (fx- -1 n) p)
|
|
||||||
(write-char #\# p)))
|
|
||||||
(define write-mark
|
|
||||||
(lambda (n p)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-fixnum (fx- -1 n) p)
|
|
||||||
(write-char #\= p)))
|
|
||||||
(define writer
|
|
||||||
(lambda (x p h i)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(pretty-pair x p h i)]
|
|
||||||
[(symbol? x)
|
|
||||||
(if (gensym? x)
|
|
||||||
(write-gensym x p h i)
|
|
||||||
(begin (write-symbol x p) i))]
|
|
||||||
[(fixnum? x)
|
|
||||||
(write-fixnum x p)
|
|
||||||
i]
|
|
||||||
[(string? x)
|
|
||||||
(write-string x p)
|
|
||||||
i]
|
|
||||||
[(boolean? x)
|
|
||||||
(write-char* (if x "#t" "#f") p)
|
|
||||||
i]
|
|
||||||
[(char? x)
|
|
||||||
(write-character x p)
|
|
||||||
i]
|
|
||||||
[(procedure? x)
|
|
||||||
(write-char* "#<procedure>" p)
|
|
||||||
i]
|
|
||||||
[(output-port? x)
|
|
||||||
(write-char* "#<output-port " p)
|
|
||||||
(let ([i (writer (output-port-name x) p #t h i)])
|
|
||||||
(write-char #\> p)
|
|
||||||
i)]
|
|
||||||
[(input-port? x)
|
|
||||||
(write-char* "#<input-port " p)
|
|
||||||
(let ([i (writer (input-port-name x) p #t h i)])
|
|
||||||
(write-char #\> p)
|
|
||||||
i)]
|
|
||||||
[(vector? x)
|
|
||||||
(write-shareable x p h i write-vector)]
|
|
||||||
[(null? x)
|
|
||||||
(write-char #\( p)
|
|
||||||
(write-char #\) p)
|
|
||||||
i]
|
|
||||||
[(eq? x (void))
|
|
||||||
(write-char* "#<void>" p)
|
|
||||||
i]
|
|
||||||
[(eof-object? x)
|
|
||||||
(write-char* "#!eof" p)
|
|
||||||
i]
|
|
||||||
[(bwp-object? x)
|
|
||||||
(write-char* "#!bwp" p)
|
|
||||||
i]
|
|
||||||
[(record? x)
|
|
||||||
(let ([printer (record-printer x)])
|
|
||||||
(if (procedure? printer)
|
|
||||||
(begin (printer x p) i)
|
|
||||||
(write-shareable x p h i write-record)))]
|
|
||||||
[(hash-table? x)
|
|
||||||
(write-char* "#<hash-table>" p)
|
|
||||||
i]
|
|
||||||
[($unbound-object? x)
|
|
||||||
(write-char* "#<unbound-object>" p)
|
|
||||||
i]
|
|
||||||
[($forward-ptr? x)
|
|
||||||
(write-char* "#<forward-ptr>" p)
|
|
||||||
i]
|
|
||||||
[(number? x)
|
|
||||||
(write-char* (number->string x) p)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char* "#<unknown>" p)
|
|
||||||
i])))
|
|
||||||
|
|
||||||
|
|
||||||
(define (hasher x h)
|
|
||||||
(define (vec-graph x i j h)
|
|
||||||
(unless (fx= i j)
|
|
||||||
(graph (vector-ref x i) h)
|
|
||||||
(vec-graph x (fxadd1 i) j h)))
|
|
||||||
(define (vec-dynamic x i j h)
|
|
||||||
(unless (fx= i j)
|
|
||||||
(dynamic (vector-ref x i) h)
|
|
||||||
(vec-dynamic x (fxadd1 i) j h)))
|
|
||||||
(define (graph x h)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(graph (car x) h)
|
|
||||||
(graph (cdr x) h)])]
|
|
||||||
[(vector? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(vec-graph x 0 (vector-length x) h)])]
|
|
||||||
[(gensym? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))])]))
|
|
||||||
(define (dynamic x h)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(dynamic (car x) h)
|
|
||||||
(dynamic (cdr x) h)
|
|
||||||
(when (and (get-hash-table h x #f)
|
|
||||||
(fxzero? (get-hash-table h x #f)))
|
|
||||||
(put-hash-table! h x #f))])]
|
|
||||||
[(vector? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(vec-dynamic x 0 (vector-length x) h)
|
|
||||||
(when (and (get-hash-table h x #f)
|
|
||||||
(fxzero? (get-hash-table h x #f)))
|
|
||||||
(put-hash-table! h x #f))])]))
|
|
||||||
(if (print-graph)
|
|
||||||
(graph x h)
|
|
||||||
(dynamic x h)))
|
|
||||||
|
|
||||||
(define (write x p)
|
|
||||||
(let ([h (make-hash-table)])
|
|
||||||
(hasher x h)
|
|
||||||
(writer x p h 0))
|
|
||||||
(flush-output-port p))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(let ()
|
|
||||||
;;; <fmt> ::= (quote symbol)
|
|
||||||
;;; | var
|
|
||||||
;;; | symbol
|
|
||||||
;;; | (read-macro string symbol)
|
|
||||||
;;; | (meta)
|
|
||||||
;;; | (bracket . fmt-list)
|
|
||||||
;;; | (alt fmt fmt*)
|
|
||||||
;;; | fmt-list
|
|
||||||
;;; fmt-list ::= ()
|
|
||||||
;;; | (tab fmt ...)
|
|
||||||
;;; | (fmt tab ...)
|
|
||||||
;;; | (tab fmt . fmt-list)
|
|
||||||
;;; | (fmt ...)
|
|
||||||
;;; | (fmt . fmt-list)
|
|
||||||
;;; | (fill tab fmt ...)
|
|
||||||
;;; tab ::= int
|
|
||||||
;;; | #f
|
|
||||||
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
||||||
(pretty-format
|
|
||||||
'([letrec (_ ((x _) ...) #t _ _ ...)]
|
|
||||||
[let (_ x ([x _] 0 ...) #t _ _ ...)]
|
|
||||||
[cond (_ (or (_ 0 _) (_ '=> 0 _)) ...)]
|
|
||||||
|
|
||||||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -99,5 +99,7 @@
|
||||||
(let ([n (string-length s)])
|
(let ([n (string-length s)])
|
||||||
(let ([i (loc= s 0 n)])
|
(let ([i (loc= s 0 n)])
|
||||||
(cons (substring s 0 i)
|
(cons (substring s 0 i)
|
||||||
(substring s (fxadd1 i) n)))))
|
(if (fx< (fxadd1 i) n)
|
||||||
|
(substring s (fxadd1 i) n)
|
||||||
|
"")))))
|
||||||
(foreign-call "ikrt_environ"))))
|
(foreign-call "ikrt_environ"))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue