From 0bd87e4c4daa9e87c7b893c27749d27644b48143 Mon Sep 17 00:00:00 2001 From: dybvig Date: Mon, 22 Aug 2016 21:41:53 -0400 Subject: [PATCH] - 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 original commit: 603019ea82afda1926462214576ef92df15e43c8 --- LOG | 8 +++- mats/4.ms | 4 ++ mats/6.ms | 10 +++++ mats/root-experr-compile-0-f-f-f | 2 + s/primdata.ss | 1 + s/print.ss | 77 +++++++++++++++++++++++++++++++- 6 files changed, 100 insertions(+), 2 deletions(-) diff --git a/LOG b/LOG index 952f88e6a2..1f8b5eeba2 100644 --- a/LOG +++ b/LOG @@ -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 diff --git a/mats/4.ms b/mats/4.ms index a9c338bafe..b5c625abbe 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -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 diff --git a/mats/6.ms b/mats/6.ms index b3587a69be..fba59afa00 100644 --- a/mats/6.ms +++ b/mats/6.ms @@ -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)") diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index beb1c93d3f..f7f9dc3b5b 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -243,7 +243,9 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: # (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]) diff --git a/s/print.ss b/s/print.ss index 2c1ae350a4..ab873eae72 100644 --- a/s/print.ss +++ b/s/print.ss @@ -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