gemigreerd-racket-audio/private/utils.rkt

(module utils racket/base

  (require racket/path
           racket/runtime-path
           ffi/unsafe
           setup/dirs
           "downloader.rkt"
           simple-log
           )
  
  (provide while
           until
           build-lib-path
           get-lib
           do-for
           dbg-sound
           info-sound
           err-sound
           warn-sound
           fatal-sound
           sync-log-sound
           integer->int-bytes
           int-bytes->integer

           let/assert
           make-assert
           a-eq? a-!eq?
           a->? a-<=? a->=? a-<? a-=? a-!=?
           a-nullptr? a-!nullptr?
           a-true? a-false?
           
           define/return
           return
           
           )

  (sl-def-log racket-sound sound)

  (define-syntax while
    (syntax-rules ()
      ((_ cond body ...)
       (letrec ((while-f (lambda (last-result)
                           (if cond
                               (let ((last-result (begin
                                                    body
                                                    ...)))
                                 (while-f last-result))
                               last-result))))
         (while-f #f))
       )
      ))

  (define-syntax until
    (syntax-rules ()
      ((_ cond body ...)
       (letrec ((until-f (lambda (last-result)
                           (if cond
                               last-result
                               (let ((last-reult (begin
                                                   body
                                                   ...)))
                                 (until-f last-result))))))
         (until-f #f)))))

  (define-syntax do-for
    (syntax-rules ()
      ((_ (init cond next) body ...)
       (begin
         init
         (letrec ((do-for-f (lamba ()
                                   (if cond
                                       (begin
                                         (begin
                                           body
                                           ...)
                                         next
                                         (do-for-f))))))
           (do-for-f))))))


  (define (build-lib-path p)
    (if (eq? (system-type 'os) 'macosx)
       (let ((brew-lib "/opt/homebrew/lib"))
          (cons (soundlibs-directory) (cons brew-lib p)))
       (cons (soundlibs-directory) p)))

  (define (get-lib* libs-to-try orig-libs versions)
    (unless (soundlibs-available?)
      (download-soundlibs))
    (let ((libs-path (build-lib-path (get-lib-search-dirs))))
      (if (null? libs-to-try)
          (begin
            (displayln (format "Warning: Cannot find library, tried ~a in ~a" orig-libs libs-path))
            #f)
          (ffi-lib (car libs-to-try) versions
                   #:get-lib-dirs (λ () libs-path)
                   #:fail (λ ()
                            (ffi-lib (car libs-to-try) versions
                                     #:fail (λ () 
                                              (get-lib* (cdr libs-to-try) orig-libs versions))))
                   )
          )
      )
    )

  (define (get-lib libs-to-try versions)
    (get-lib* libs-to-try libs-to-try versions))

  (define-syntax-rule (integer->int-bytes v size signed? big? bs pos)
    (if (= size 3)
        (if big?
            (begin
              (bytes-set! bs pos       (bitwise-and (arithmetic-shift v -16) #xff))
              (bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8)  #xff))
              (bytes-set! bs (+ pos 2) (bitwise-and v #xff)))
            (begin
              (bytes-set! bs pos       (bitwise-and v #xff))
              (bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8)  #xff))
              (bytes-set! bs (+ pos 2) (bitwise-and (arithmetic-shift v -16) #xff))))
        (integer->integer-bytes v size signed? big? bs pos)))

  (define-syntax-rule (int-bytes->integer bs signed? big? start end)
    (let ([size (- end start)])
      (if (= size 3)
          (let* ([b0 (bytes-ref bs start)]
                 [b1 (bytes-ref bs (+ start 1))]
                 [b2 (bytes-ref bs (+ start 2))]
                 [u  (if big?
                         (bitwise-ior (arithmetic-shift b0 16)
                                      (arithmetic-shift b1 8)
                                      b2)
                         (bitwise-ior b0
                                      (arithmetic-shift b1 8)
                                      (arithmetic-shift b2 16)))])
            (if (and signed? (not (zero? (bitwise-and u #x800000))))
                (- u #x1000000)
                u))
          (integer-bytes->integer bs signed? big? start end))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; let/assert
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


  (define-syntax make-assert
    (syntax-rules ()
      ((_ name not-name pred)
       (begin
         (define-syntax name
           (syntax-rules ()
             ((_ const)
              (λ (x) (pred x const)))))
         (define-syntax not-name
           (syntax-rules ()
             ((_ const)
              (λ (x) (not (pred x const))))))
         )
       )
      )
    )

  (make-assert a-eq? a-!eq? eq?)

  (define a-nullptr? (a-eq? #f))
  (define a-!nullptr? (a-!eq? #f))

  (make-assert a->? a-<=? >)
  (make-assert a->=? a-<? >=)
  (make-assert a-=? a-!=? =)

  (define a-true? (a-eq? #t))
  (define a-false? (a-eq? #f))

  (struct exn:let/assert exn (value) #:transparent)

  (define (raise-let/assert v)
    (raise (exn:let/assert "let/assert" (current-continuation-marks) v)))

  (define (let/assert-value r)
    (exn:let/assert-value r))

  (define-syntax assert-expr
    (syntax-rules ()
      ((_ expr cond retval)
       (let ((a expr)) (if (cond a) a (raise-let/assert retval))))
      ((_ expr)
       expr)
      )
    )

  (define-syntax let/assert
    (syntax-rules ()
      ((_ ((v rest ...) ...) b1 ...)
       (with-handlers ([exn:let/assert? let/assert-value])
         (let* ((v (assert-expr rest ...))
                ...)
           b1
           ...
           )
         )
       )
      )
    )

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; define/return
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (struct exn:return exn (value) #:transparent)

  (define (raise-return v)
    (raise (exn:return "return" (current-continuation-marks) v)))

  (define (return-value r)
    (exn:return-value r))
  
  (define-syntax return
    (syntax-rules ()
      ((_ val)
       (raise-return val))))

  (define-syntax define/return
    (syntax-rules ()
      ((_ (name ...) b1 ...)
       (define (name ...)
         (with-handlers ([exn:return? return-value])
           b1
           ...
           )
         )
       )
      )
    )
            
           
       
  
) ; end of module