Merge pull request #462 from herbie-fp/deprecate-bessel

Deprecate Bessel functions

Author: bksaiki

src/errors.rkt

@@ -2,6 +2,7 @@
 (require "config.rkt")
 (provide raise-herbie-error raise-herbie-syntax-error
          raise-herbie-sampling-error raise-herbie-missing-error
+         syntax->error-format-string
          herbie-error->string herbie-error-url
          (struct-out exn:fail:user:herbie)
          (struct-out exn:fail:user:herbie:syntax)
@@ -42,20 +43,23 @@
   (format "https://herbie.uwplse.org/doc/~a/~a"
           *herbie-version* (exn:fail:user:herbie-url exn)))
 
+(define (syntax->error-format-string stx)
+  (define file
+    (if (path? (syntax-source stx))
+        (let-values ([(base name dir?) (split-path (syntax-source stx))])
+          (path->string name))
+        (syntax-source stx)))
+  (format "~a:~a:~a: ~~a" file (or (syntax-line stx) "")
+                              (or (syntax-column stx) (syntax-position stx))))
+
 (define (herbie-error->string err)
   (with-output-to-string
     (λ ()
       (match err
         [(exn:fail:user:herbie:syntax message marks url locations)
          (eprintf "~a\n" message)
          (for ([(stx message) (in-dict locations)])
-           (define file
-             (if (path? (syntax-source stx))
-                 (let-values ([(base name dir?) (split-path (syntax-source stx))])
-                   (path->string name))
-                 (syntax-source stx)))
-           (eprintf "  ~a:~a:~a: ~a\n" file (or (syntax-line stx) "")
-                    (or (syntax-column stx) (syntax-position stx)) message))
+           (eprintf "  ~a\n" (format (syntax->error-format-string stx) message)))
          (when url
            (eprintf "See <https://herbie.uwplse.org/doc/~a/~a> for more.\n" *herbie-version* url))]
         [(exn:fail:user:herbie message marks url)

src/reprs/binary32.rkt

@@ -115,11 +115,7 @@
        #`(begin
            (define fl-proc
             (get-ffi-obj '#,cname #f (_fun #,@(build-list num-args (λ (_) #'_float)) -> _float)
-                         (λ () (warn 'unsupported #:url "faq.html#native-ops"
-                                     "native `~a` not supported on your system, disabling operator. ~a"
-                                     '#,cname
-                                     "Consider using :precision racket for Racket-only operators.")
-                               #f)))
+                         (λ () #f)))
            (when fl-proc
             (define-operator-impl (op #,name #,@(build-list num-args (λ (_) #'binary32))) binary32
               [fl fl-proc] [key value] ...))))]))

src/reprs/binary64.rkt

@@ -47,13 +47,9 @@
             [sym2-append (λ (x y) (string->symbol (string-append (symbol->string x) (symbol->string y))))]
             [name (sym2-append (syntax-e (car (syntax-e (cadr (syntax-e stx))))) '.f64)])
        #`(begin
-           (define fl-proc
+          (define fl-proc
             (get-ffi-obj 'op #f (_fun #,@(build-list num-args (λ (_) #'_double)) -> _double)
-                         (λ () (warn 'unsupported #:url "faq.html#native-ops"
-                                     "native `~a` not supported on your system, disabling operator. ~a"
-                                     'op
-                                     "Consider using :precision racket for Racket-only operators.")
-                               #f)))
+                          (λ () #f)))
            (when fl-proc
             (define-operator-impl (op #,name #,@(build-list num-args (λ (_) #'binary64))) binary64
               [fl fl-proc] [key value] ...))))]))

src/reprs/fallback.rkt

@@ -94,8 +94,6 @@
  [expm1 (from-bigfloat bfexpm1)]
  [fabs abs]
  [floor floor]
- [j0 (from-bigfloat bfbesj0)]
- [j1 (from-bigfloat bfbesj1)]
  [lgamma log-gamma]
  [log (no-complex log)]
  [log10 (no-complex (λ (x) (log x 10)))]
@@ -110,9 +108,7 @@
  [tan tan]
  [tanh tanh]
  [tgamma gamma]
- [trunc truncate]
- [y0 (from-bigfloat bfbesy0)]
- [y1 (from-bigfloat bfbesy1)])
+ [trunc truncate])
 
 (define-2ary-fallback-operators
  [+ +]
@@ -149,3 +145,36 @@
 
 (define-operator-impl (>= >=.rkt racket racket) bool
   [fl >=])
+
+;; Deprecated
+
+;; copied from <herbie>/syntax/syntax.rkt
+(module hairy racket/base
+  (require ffi/unsafe)
+  (provide check-native-1ary-exists?)
+
+  (define (check-native-1ary-exists? op)
+    (let ([f32-name (string->symbol (string-append (symbol->string op) "f"))])
+      (or (get-ffi-obj op #f (_fun _double -> _double) (λ () #f))
+          (get-ffi-obj f32-name #f (_fun _float -> _float) (λ () #f)))))
+)
+
+(require (submod "." hairy))
+
+; can't load these without native support
+
+(when (check-native-1ary-exists? 'j0)
+  (define-operator-impl (j0 j0.rkt racket) racket
+    [fl (from-bigfloat bfbesj0)]))
+
+(when (check-native-1ary-exists? 'j1)
+  (define-operator-impl (j1 j1.rkt racket) racket
+    [fl (from-bigfloat bfbesj1)]))
+ 
+(when (check-native-1ary-exists? 'y0)
+  (define-operator-impl (y0 y0.rkt racket) racket
+    [fl (from-bigfloat bfbesy0)]))
+
+(when (check-native-1ary-exists? 'y1)
+  (define-operator-impl (y1 y1.rkt racket) racket
+    [fl (from-bigfloat bfbesy1)]))

src/syntax/syntax-check.rkt

@@ -4,64 +4,69 @@
 (require "../common.rkt" "../conversions.rkt" "../errors.rkt" "../interface.rkt" "syntax.rkt")
 (provide assert-program!)
 
-(define (check-expression* stx vars error!)
-  (match stx
-    [#`,(? number?) (void)]
-    [#`,(? constant-operator?) (void)]
-    [#`,(? variable? var)
-     (unless (set-member? vars stx)
-       (error! stx "Unknown variable ~a" var))]
-    [#`(let* ((#,vars* #,vals) ...) #,body)
-     (define bindings
-       (for/fold ([vars vars]) ([var vars*] [val vals])
-         (unless (identifier? var)
-           (error! var "Invalid variable name ~a" var))
-         (check-expression* val vars error!)
-         (bound-id-set-union vars (immutable-bound-id-set (list var)))))
-     (check-expression* body bindings error!)]
-    [#`(let ((#,vars* #,vals) ...) #,body)
-     ;; These are unfolded by desugaring
-     (for ([var vars*] [val vals])
-       (unless (identifier? var)
-         (error! var "Invalid variable name ~a" var))
-       (check-expression* val vars error!))
-     (check-expression* body (bound-id-set-union vars (immutable-bound-id-set vars*)) error!)]
-    [#`(let #,varlist #,body)
-     (error! stx "Invalid `let` expression variable list ~a" (syntax->datum varlist))
-     (check-expression* body vars error!)]
-    [#`(let #,args ...)
-     (error! stx "Invalid `let` expression with ~a arguments (expects 2)" (length args))
-     (unless (null? args) (check-expression* (last args) vars error!))]
-    [#`(if #,cond #,ift #,iff)
-     (check-expression* cond vars error!)
-     (check-expression* ift vars error!)
-     (check-expression* iff vars error!)]
-    [#`(if #,args ...)
-     (error! stx "Invalid `if` expression with ~a arguments (expects 3)" (length args))
-     (unless (null? args) (check-expression* (last args) vars error!))]
-    [#`(! #,props ... #,body)
-     (check-properties* props '() body)
-     (check-expression* body vars error!)]
-    [#`(,(? (curry set-member? '(+ - * / and or = != < > <= >=))) #,args ...)
-     ;; These expand by associativity so we don't check the number of arguments
-     (for ([arg args]) (check-expression* arg vars error!))]
-    [#`(#,f-syntax #,args ...)
-     (define f (syntax->datum f-syntax))
-     (cond
-      [(operator-exists? f)
+
+
+(define (check-expression* stx vars error! deprecated-ops)
+  (let loop ([stx stx] [vars vars])
+    (match stx
+     [#`,(? number?) (void)]
+     [#`,(? constant-operator?) (void)]
+     [#`,(? variable? var)
+      (unless (set-member? vars stx)
+        (error! stx "Unknown variable ~a" var))]
+     [#`(let* ((#,vars* #,vals) ...) #,body)
+      (define bindings
+        (for/fold ([vars vars]) ([var vars*] [val vals])
+          (unless (identifier? var)
+            (error! var "Invalid variable name ~a" var))
+          (loop val vars)
+          (bound-id-set-union vars (immutable-bound-id-set (list var)))))
+      (loop body bindings)]
+     [#`(let ((#,vars* #,vals) ...) #,body)
+      ;; These are unfolded by desugaring
+      (for ([var vars*] [val vals])
+        (unless (identifier? var)
+          (error! var "Invalid variable name ~a" var))
+        (loop val vars))
+      (loop body (bound-id-set-union vars (immutable-bound-id-set vars*)))]
+     [#`(let #,varlist #,body)
+      (error! stx "Invalid `let` expression variable list ~a" (syntax->datum varlist))
+      (loop body vars)]
+     [#`(let #,args ...)
+      (error! stx "Invalid `let` expression with ~a arguments (expects 2)" (length args))
+      (unless (null? args) (loop (last args) vars))]
+     [#`(if #,cond #,ift #,iff)
+      (loop cond vars)
+      (loop ift vars)
+      (loop iff vars)]
+     [#`(if #,args ...)
+      (error! stx "Invalid `if` expression with ~a arguments (expects 3)" (length args))
+      (unless (null? args) (loop (last args) vars))]
+     [#`(! #,props ... #,body)
+      (check-properties* props '() body deprecated-ops)
+      (loop body vars)]
+     [#`(,(? (curry set-member? '(+ - * / and or = != < > <= >=))) #,args ...)
+      ;; These expand by associativity so we don't check the number of arguments
+      (for ([arg args]) (loop arg vars))]
+     [#`(#,f-syntax #,args ...)
+      (define f (syntax->datum f-syntax))
+      (cond
+       [(operator-exists? f)
         (define arity (length (real-operator-info f 'itype)))
         (unless (= arity (length args))
           (error! stx "Operator ~a given ~a arguments (expects ~a)"
-                  f (length args) arity))]
-      [(hash-has-key? (*functions*) f)
+                  f (length args) arity))
+        (when (operator-deprecated? f)
+          (set-add! deprecated-ops f))]
+       [(hash-has-key? (*functions*) f)
         (match-define (list vars _ _) (hash-ref (*functions*) f))
         (unless (= (length vars) (length args))
           (error! stx "Function ~a given ~a arguments (expects ~a)"
                   f (length args) (length vars)))]
-      [else
+       [else
         (error! stx "Unknown operator ~a" f)])
-     (for ([arg args]) (check-expression* arg vars error!))]
-    [_ (error! stx "Unknown syntax ~a" (syntax->datum stx))]))
+      (for ([arg args]) (loop arg vars))]
+     [_ (error! stx "Unknown syntax ~a" (syntax->datum stx))])))
 
 (define (check-property* prop error!)
   (unless (identifier? prop)
@@ -70,7 +75,7 @@
   (unless (equal? (substring name 0 1) ":")
     (error! prop "Invalid property name ~a" prop)))
 
-(define (check-properties* props vars error!)
+(define (check-properties* props vars error! deprecated-ops)
   (define prop-dict
     (let loop ([props props] [out '()])
       (match props
@@ -108,10 +113,10 @@
         (error! cite "Invalid :cite ~a; must be a list" cite)))   
 
   (when (dict-has-key? prop-dict ':pre)
-    (check-expression* (dict-ref prop-dict ':pre) vars error!))
+    (check-expression* (dict-ref prop-dict ':pre) vars error! deprecated-ops))
 
   (when (dict-has-key? prop-dict ':herbie-target)
-    (check-expression* (dict-ref prop-dict ':herbie-target) vars error!))
+    (check-expression* (dict-ref prop-dict ':herbie-target) vars error! deprecated-ops))
 
   (when (dict-has-key? prop-dict ':herbie-conversions)
     (define conversion-stx (dict-ref prop-dict ':herbie-conversions))
@@ -138,8 +143,14 @@
       (error! stx "Argument ~a is not a variable name" var))
    (when (check-duplicate-identifier vars*)
       (error! stx "Duplicate argument name ~a" (check-duplicate-identifier vars*))))
-  (check-properties* props (immutable-bound-id-set vars*) error!)
-  (check-expression* body (immutable-bound-id-set vars*) error!))
+  (define deprecated-ops (mutable-set))
+  (check-properties* props (immutable-bound-id-set vars*) error! deprecated-ops)
+  (check-expression* body (immutable-bound-id-set vars*) error! deprecated-ops)
+  (for ([op (in-set deprecated-ops)])
+    (define message
+      (format (syntax->error-format-string stx)
+        (format "operator `~a` is deprecated." op)))
+    (warn 'deprecated #:url "faq.html#deprecated-ops" message)))
 
 (define (check-fpcore* stx error!)
   (match stx
@@ -154,16 +165,6 @@
    [_
     (error! stx "Not an FPCore: ~a" stx)]))
 
-(define (assert-expression! stx vars)
-  (define errs
-    (reap [sow]
-          (define (error! stx fmt . args)
-            (define args* (map (λ (x) (if (syntax? x) (syntax->datum x) x)) args))
-            (sow (cons stx (apply format fmt args*))))
-          (check-expression* stx vars error!)))
-  (unless (null? errs)
-    (raise-herbie-syntax-error "Invalid expression" #:locations errs)))
-
 (define (assert-program! stx)
   (define errs
     (reap [sow]
@@ -172,7 +173,8 @@
             (sow (cons stx (apply format fmt args*))))
           (check-fpcore* stx error!)))
   (unless (null? errs)
-    (raise-herbie-syntax-error "Invalid program" #:locations errs)))
+    (raise-herbie-syntax-error "Invalid program" #:locations errs))
+  (print-warnings))
 
 ;; testing FPCore format
 (module+ test