deps on define-return and let-assert + library messages
This commit is contained in:
+90
-109
@@ -21,21 +21,19 @@
|
||||
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
|
||||
|
||||
valid-ffmpeg-versions
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Create log definitions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(sl-def-log racket-sound sound)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provide some loop constructions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax while
|
||||
(syntax-rules ()
|
||||
((_ cond body ...)
|
||||
@@ -77,6 +75,80 @@
|
||||
(do-for-f))))))
|
||||
(do-for-f))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Loading libraries
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define valid-ffmpeg-versions
|
||||
(make-hash (list (list 'avutil 58 60 "libavcodec")
|
||||
(list 'avcodec 60 62 "libavutil")
|
||||
(list 'avformat 60 62 "libswresample")
|
||||
(list 'swresample 4 6 "libavformat")
|
||||
))
|
||||
)
|
||||
|
||||
(define (version-str kind)
|
||||
(let ((v (hash-ref valid-ffmpeg-versions kind)))
|
||||
(format " - ~a~a - ~a~a\n" (caddr v) (car v) (caddr v) (cadr v))
|
||||
)
|
||||
)
|
||||
|
||||
(define (lib-not-found-message orig-libs libs-path)
|
||||
(displayln (format "Warning: Cannot find library, tried ~a in ~a" orig-libs libs-path))
|
||||
(let ((st (system-type 'os*)))
|
||||
(cond ((eq? st 'windows)
|
||||
(displayln
|
||||
(format
|
||||
"\nLibraries for Windows should have been downloaded to\n\n - ~a\n"
|
||||
(soundlibs-directory))))
|
||||
((eq? st 'linux)
|
||||
(displayln
|
||||
(string-append
|
||||
"Make sure you have installed the following libraries,\n"
|
||||
"e.g. on a debian based system with apt:\n"
|
||||
"\n"
|
||||
" FLAC : sudo apt install libflac12\n"
|
||||
" mpg123 : libmpg123-0\n"
|
||||
" libao : libao4\n"
|
||||
" ffmpeg : libavcodec60 libavutil58 libswresample4 libavformat60\n"
|
||||
"\n"
|
||||
)))
|
||||
((eq? st 'macosx)
|
||||
(displayln
|
||||
(string-append
|
||||
"Make sure you have the right libraries installed, using 'homebrew', see https://brew.sh/\n"
|
||||
"\n"
|
||||
" brew install ffmpeg-full\n"
|
||||
" brew install libao\n"
|
||||
" brew install mpg123\n"
|
||||
" brew install flac\n"
|
||||
"\n"
|
||||
)))
|
||||
(else
|
||||
(displayln
|
||||
(string-append
|
||||
"Make sure you have the right libraries installed on your system and reachable by racket\n"
|
||||
"\n"
|
||||
"You need following libraries:\n"
|
||||
"\n"
|
||||
"- xiph libao (https://xiph.org).\n"
|
||||
"- xiph libFLAC (https://xiph.org).\n"
|
||||
"- ffmpeg of the right version (https://ffmpeg.org).\n"
|
||||
"- libmpg123 (https://mpg123.org).\n"
|
||||
"\n")
|
||||
))
|
||||
)
|
||||
(displayln
|
||||
(string-append "NB. currently supported major versions for the ffmpeg libraries are:\n"
|
||||
"\n"
|
||||
(version-str 'avcodec)
|
||||
(version-str 'avutil)
|
||||
(version-str 'swresample)
|
||||
(version-str 'avformat)
|
||||
"\n"
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
(define (build-lib-path p)
|
||||
(if (eq? (system-type 'os) 'macosx)
|
||||
@@ -90,7 +162,7 @@
|
||||
(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))
|
||||
(lib-not-found-message orig-libs libs-path)
|
||||
#f)
|
||||
(ffi-lib (car libs-to-try) versions
|
||||
#:get-lib-dirs (λ () libs-path)
|
||||
@@ -106,6 +178,11 @@
|
||||
(define (get-lib libs-to-try versions)
|
||||
(get-lib* libs-to-try libs-to-try versions))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; integer->int-bytes and vise versa.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax-rule (integer->int-bytes v size signed? big? bs pos)
|
||||
(if (= size 3)
|
||||
(if big?
|
||||
@@ -137,102 +214,6 @@
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user