#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (system base syntax)
(else
(warning 'format loc 'wrong-num-args (length args)))))
+ (define (check-simple-format-args args loc)
+ ;; Check the arguments to the `simple-format' procedure, which is
+ ;; less capable than that of (ice-9 format).
+
+ (define allowed-chars
+ '(#\A #\S #\a #\s #\~ #\%))
+
+ (define (format-chars fmt)
+ (let loop ((chars (string->list fmt))
+ (result '()))
+ (match chars
+ (()
+ (reverse result))
+ ((#\~ opt rest ...)
+ (loop rest (cons opt result)))
+ ((_ rest ...)
+ (loop rest result)))))
+
+ (match args
+ ((port ($ <const> _ (? string? fmt)) _ ...)
+ (let ((opts (format-chars fmt)))
+ (or (every (cut memq <> allowed-chars) opts)
+ (begin
+ (warning 'format loc 'simple-format fmt
+ (find (negate (cut memq <> allowed-chars)) opts))
+ #f))))
+ ((port (($ <const> _ '_) fmt) args ...)
+ (check-simple-format-args `(,port ,fmt ,args) loc))
+ (_ #t)))
+
(define (resolve-toplevel name)
(and (module? env)
(false-if-exception (module-ref env name))))
(match x
(($ <application> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
- (and (or (eq? proc format)
- (eq? proc (@ (ice-9 format) format)))
- (check-format-args args (or src (find pair? locs))))))
+ (if (or (and (eq? proc (@ (guile) simple-format))
+ (check-simple-format-args args
+ (or src (find pair? locs))))
+ (eq? proc (@ (ice-9 format) format)))
+ (check-format-args args (or src (find pair? locs))))))
+ (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (check-format-args args (or src (find pair? locs))))
+ (($ <application> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
+ args)
+ (and (check-simple-format-args args
+ (or src (find pair? locs)))
+ (check-format-args args (or src (find pair? locs)))))
(_ #t))
#t)
(pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
(null? (call-with-warnings
(lambda ()
- (compile '(format some-port "~&~3_~~ ~\n~12they~%")
+ (compile '((@ (ice-9 format) format) some-port
+ "~&~3_~~ ~\n~12they~%")
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "two missing arguments"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo ~10,2f and bar ~S~%")
+ (compile '((@ (ice-9 format) format) #f
+ "foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "literals"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
+ (compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "literals with selector"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~2[foo~;bar~;baz~;~] ~A"
+ (compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "escapes (exact count)"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[~a~;~a~]")
+ (compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "escapes with selector"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~1[chbouib~;~a~]")
+ (compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "escapes, range"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[chbouib~;~a~;~2*~a~]")
+ (compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "@"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~@[temperature=~d~]")
+ (compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "nested"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]")
+ (compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unterminated"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~[unterminated")
+ (compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unexpected ~;"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo~;bar")
+ (compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unexpected ~]"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "foo~]")
+ (compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~{...~}"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~{~S~} ~A"
+ (compile '((@ (ice-9 format) format) #f "~A ~{~S~} ~A"
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~{~S~}" 1 2 3)
+ (compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~@{...~}"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~@{~S~}" 1 2 3)
+ (compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~@{...~}, too few args"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~A ~@{~S~}")
+ (compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "unterminated ~{...~}"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~{")
+ (compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~(...~)"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~:@(~A ~A~)" 'foo 'bar)
+ (compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~v_foo")
+ (compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~v:@y"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~v:@y" 1 123)
+ (compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "~*"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~2*~a" 'a 'b)
+ (compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(pass-if "~?"
(null? (call-with-warnings
(lambda ()
- (compile '(format #f "~?" "~d ~d" '(1 2))
+ (compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f
+ (compile '((@ (ice-9 format) format) #f
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
(pass-if "complex 2"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f
+ (compile '((@ (ice-9 format) format) #f
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
(pass-if "complex 3"
(let ((w (call-with-warnings
(lambda ()
- (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
+ (compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
- #:to 'assembly)))))))
+ #:to 'assembly)))))
+
+ (with-test-prefix "simple-format"
+
+ (pass-if "good"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "wrong number of args"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "wrong number")))))
+
+ (pass-if "unsupported"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(simple-format #t "foo ~x~%" 16)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unsupported format option"))))))))