suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- added tests for the case and exclusive-cond syntax-error calls

Browse Source 
4.ms, root-experr-compile-0-f-f-f
- added print-extended-identifier parameter.  when #t, symbols like
  1+ and +++ print without escapes.
    priminfo.ss, print.ss,
    6.ms

original commit: 603019ea82afda1926462214576ef92df15e43c8
This commit is contained in:
dybvig 2016-08-22 21:41:53 -04:00
parent 3c1f43380b
commit 0bd87e4c4d
6 changed files with 100 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
LOG
View File

@ -298,4 +298,10 @@
7.ms
- fixed a bug in case and exclusive-cond syntax-error calls causing an
exception in syntax-error instead of the intended error message.
s/syntax.ss
syntax.ss
- added tests for the case and exclusive-cond syntax-error calls
4.ms, root-experr-compile-0-f-f-f
- added print-extended-identifier parameter. when #t, symbols like
1+ and +++ print without escapes.
priminfo.ss, print.ss,
6.ms

4
mats/4.ms
View File

@ -393,6 +393,8 @@
)
(mat exclusive-cond
(error? ; invalid syntax
(exclusive-cond [a . b]))
(let ((a 'a))
(and (begin (set! a 3)
(exclusive-cond ((= a 4) #f) ((= a 3) #t) (else #f)))
@ -464,6 +466,8 @@
)
(mat case
(error? ; invalid syntax
(case 3 [a . b]))
(eq? (case 'a [a 'yes] [b 'no]) 'yes)
(let ((a 'a))
(and

10
mats/6.ms
View File

@ -1085,6 +1085,16 @@
(pretty-print '#(1 2 3 3 3))
(pretty-print '#vfx(5 7 9 8 8 9 -1 -1)))))
"#5(1 2 3)\n#8vfx(5 7 9 8 8 9 -1)\n")
(equal? (parameterize ([print-extended-identifiers #f])
(with-output-to-string
(lambda ()
(for-each pretty-print '(1+ +++ .. |12| xyz aBc |-155| |.5e7| |.5e|)))))
"\\x31;+\n\\x2B;++\n\\x2E;.\n\\x31;2\nxyz\naBc\n\\x2D;155\n\\x2E;5e7\n\\x2E;5e\n")
(equal? (parameterize ([print-extended-identifiers #t])
(with-output-to-string
(lambda ()
(for-each pretty-print '(1+ +++ .. |12| xyz aBc |-155| |.5e7| |.5e|)))))
"1+\n+++\n..\n\\x31;2\nxyz\naBc\n\\x2D;155\n\\x2E;5e7\n.5e\n")
(equal? (parameterize ([print-gensym #f])
(format "~s" '(#3# #3=#{g0 fool})))
"(g0 g0)")

2
mats/root-experr-compile-0-f-f-f
View File

@ -243,7 +243,9 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat apply: "apply: (1 2 1 2 1 2 ...) is circular".
4.mo:Expected error in mat begin: "invalid syntax (begin)".
4.mo:Expected error in mat cond: "invalid syntax x".
4.mo:Expected error in mat exclusive-cond: "invalid exclusive-cond clause (a . b)".
4.mo:Expected error in mat exclusive-cond: "invalid syntax x".
4.mo:Expected error in mat case: "invalid case clause (a . b)".
4.mo:Expected error in mat r6rs:case: "invalid syntax (r6rs:case (quote a) (a (quote yes)) (b (quote no)))".
4.mo:Expected error in mat r6rs:case: "invalid syntax (case (quote a) (a (quote yes)) (b (quote no)))".
4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)".

1
s/primdata.ss
View File

@ -972,6 +972,7 @@
(pretty-standard-indent [sig [() -> (ufixnum)] [(ufixnum) -> (void)]] [flags])
(print-brackets [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(print-char-name [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(print-extended-identifiers [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(print-gensym [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted])
(print-graph [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(print-length [sig [() -> (maybe-ufixnum)] [(maybe-ufixnum) -> (void)]] [flags])

77
s/print.ss
View File

@ -1143,6 +1143,77 @@ floating point returns with (1 0 -1 ...).
[else (print-hex-char c p)]))
(s1 s p n (fx+ i 1))))
(define extended-identifier?
(let ()
(define-syntax state-machine
(lambda (x)
(syntax-case x ()
((_k start-state (name def (test e) ...) ...)
(with-implicit (_k s i n) ; support num4 kludge
#'(let ()
(define name
(lambda (s i n)
(if (= i n)
def
(let ([g (string-ref s i)])
(state-machine-help (s i n) g (test e) ... ))))) ...
(lambda (string)
(start-state string 0 (string-length string)))))))))
(define-syntax state-machine-help
(syntax-rules (else to skip)
[(_ (s i n) c [test (skip to x)] more ...)
(state-machine-help (s i n) c [test (x s i n)] more ...)]
[(_ (s i n) c [test (to x)] more ...)
(state-machine-help (s i n) c [test (x s (fx+ i 1) n)] more ...)]
[(_ (s i n) c [else e]) e]
[(_ (s i n) c [test e] more ...)
(if (state-machine-test c test)
e
(state-machine-help (s i n)c more ...))]))
(define-syntax state-machine-test
(syntax-rules (-)
[(_ c (char1 - char2))
(char<=? char1 c char2)]
[(_ c (e1 e2 ...))
(or (state-machine-test c e1) (state-machine-test c e2) ...)]
[(_ c char)
(char=? c char)]))
(state-machine start
(start #f ; start state
[((#\a - #\z) (#\A - #\Z)) (to sym)]
[(#\- #\+) (to num1)]
[(#\* #\= #\> #\<) (to sym)]
[(#\0 - #\9) (to num4)]
[#\. (to num2)]
[(#\{ #\}) (to brace)]
[else (skip to sym)])
(num1 #t ; seen + or -
[(#\0 - #\9) (to num4)]
[#\. (to num3)]
[(#\i #\I) (to num5)]
[else (skip to sym)])
(num2 #f ; seen .
[(#\0 - #\9) (to num4)]
[else (skip to sym)])
(num3 #f ; seen +. or -.
[(#\0 - #\9) (to num4)]
[else (skip to sym)])
(num4 #f ; seen digit, +digit, -digit, or .digit
[else ; kludge
(if (number? ($str->num s n 10 #f #f)) ; grabbing private s and n
#f
(sym s i n))]) ; really (skip to sym)
(num5 #f ; bars: seen +i, -i, +I, or -I
[else (skip to sym)])
(sym #t ; safe symbol
[((#\a - #\z) (#\A - #\Z) #\- #\? (#\0 - #\9) #\* #\! #\= #\> #\< #\+ #\/)
(to sym)]
[((#\nul - #\space) #\( #\) #\[ #\] #\{ #\} #\" #\' #\` #\, #\; #\" #\\ #\|)
#f]
[else (to sym)])
(brace #t ; { or }
[else #f]))))
(define wrsymbol
(case-lambda
[(s p) (wrsymbol s p #f)]
@ -1152,7 +1223,9 @@ floating point returns with (1 0 -1 ...).
(s1 s p n 0)
(if (fx= n 0)
(display-string "||" p)
(s0 s p n))))])))
(if (and (print-extended-identifiers) (extended-identifier? s))
(display-string s p)
(s0 s p n)))))])))
(set! $write-pretty-quick
(lambda (x lev len env p)
@ -1237,6 +1310,8 @@ floating point returns with (1 0 -1 ...).
(define print-vector-length ($make-thread-parameter #f (lambda (x) (and x #t))))
(define print-extended-identifiers ($make-thread-parameter #f (lambda (x) (and x #t))))
(define print-precision
($make-thread-parameter
#f