racket only ffmpeg backend. Now no racket-sound-libs are needed anymore.
This commit is contained in:
File diff suppressed because it is too large
Load Diff
+90
-251
@@ -1,8 +1,6 @@
|
||||
(module ffmpeg_ffi racket/base
|
||||
(module ffmpeg_ffi_v2 racket/base
|
||||
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/define
|
||||
ffi/unsafe/alloc
|
||||
(require "ffmpeg-definitions.rkt"
|
||||
"private/utils.rkt"
|
||||
)
|
||||
|
||||
@@ -10,174 +8,53 @@
|
||||
fmpg-version
|
||||
)
|
||||
|
||||
;; The native shim is the new instance-only FFmpeg audio API. It exposes a
|
||||
;; single opaque fmpg_instance pointer and keeps stream-index, packets,
|
||||
;; decoder state and file metadata inside that instance. The public C header
|
||||
;; says that output is always signed 32-bit interleaved PCM and that the
|
||||
;; current buffer pointer is valid until the next decode/seek/close/free call.
|
||||
|
||||
;; Adjust the names below if your shared library has another basename.
|
||||
;; get-lib is used in the same style as libmpg123-ffi.rkt.
|
||||
(when (eq? (system-type 'os) 'windows)
|
||||
; preload ffmpeg dlls.
|
||||
(void
|
||||
(begin
|
||||
(get-lib '("avutil-60.dll") '(#f))
|
||||
(get-lib '("swresample-6.dll") '(#f))
|
||||
(get-lib '("avcodec-62") '(#f))
|
||||
(get-lib '("avformat-62.dll") '(#f))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define lib (get-lib '("ffmpeg_audio" "libffmpeg_audio") '(#f)))
|
||||
|
||||
(define-ffi-definer define-ffmpeg-audio lib
|
||||
#:default-make-fail make-not-available)
|
||||
|
||||
(define _fmpg_instance _pointer)
|
||||
|
||||
(define (fmpg-version)
|
||||
(let* ((v (fmpg_version))
|
||||
(patch (remainder v 256))
|
||||
(minor (remainder (quotient v 256) 256))
|
||||
(major (quotient v 65536))
|
||||
)
|
||||
(list major minor patch)))
|
||||
|
||||
;; Handler adapter for ffmpeg-decoder.rkt. The decoder keeps using the
|
||||
;; same command protocol, while this module delegates to ffmpeg-definitions.rkt.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Native bindings
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-ffmpeg-audio fmpg_init
|
||||
(_fun -> _fmpg_instance))
|
||||
|
||||
(define-ffmpeg-audio fmpg_free
|
||||
(_fun _fmpg_instance -> _void))
|
||||
|
||||
(define-ffmpeg-audio fmpg_open_file
|
||||
(_fun _fmpg_instance _string/utf-8 -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_close
|
||||
(_fun _fmpg_instance -> _void))
|
||||
|
||||
(define-ffmpeg-audio fmpg_is_open
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_audio_stream_count
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_audio_sample_rate
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_audio_channels
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_audio_bits_per_sample
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_audio_bytes_per_sample
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_duration_ms
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_duration_samples
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_title
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_author
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_album
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_genre
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_comment
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_copyright
|
||||
(_fun _fmpg_instance -> _string/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_year
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_track
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_file_bitrate
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_decode_next
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_seek_ms
|
||||
(_fun _fmpg_instance _int64 -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_buffer
|
||||
(_fun _fmpg_instance -> _pointer))
|
||||
|
||||
(define-ffmpeg-audio fmpg_buffer_size
|
||||
(_fun _fmpg_instance -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_buffer_samples
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_buffer_start_sample
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_buffer_end_sample
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_sample_position
|
||||
(_fun _fmpg_instance -> _int64))
|
||||
|
||||
(define-ffmpeg-audio fmpg_timecode
|
||||
(_fun _fmpg_instance -> _double))
|
||||
|
||||
(define-ffmpeg-audio fmpg_ffmpeg_version
|
||||
(_fun -> _string*/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_int_version2string
|
||||
(_fun _int -> _string*/utf-8))
|
||||
|
||||
(define-ffmpeg-audio fmpg_compatible_ffmpeg
|
||||
(_fun -> _int))
|
||||
|
||||
(define-ffmpeg-audio fmpg_version
|
||||
(_fun -> _int))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Our interface for decoding to racket
|
||||
;; Helpers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ok? r)
|
||||
(not (= r 0)))
|
||||
|
||||
(define (str v)
|
||||
(if (string? v) v ""))
|
||||
(define (filename->string filename)
|
||||
(cond
|
||||
[(path? filename) (path->string filename)]
|
||||
[(string? filename) filename]
|
||||
[else #f]))
|
||||
|
||||
(define (known-int64? v)
|
||||
(and (integer? v) (not (= v -1))))
|
||||
(define (fmpg-version)
|
||||
(ffmpeg-version 'avformat))
|
||||
|
||||
(define (copy-current-buffer fh)
|
||||
(let ((size (fmpg_buffer_size fh)))
|
||||
(let ((buffer (fmpg-buffer fh))
|
||||
(size (fmpg-buffer-size fh)))
|
||||
(cond
|
||||
((<= size 0) (values #f 0))
|
||||
(else
|
||||
(let ((src (fmpg_buffer fh)))
|
||||
(if (eq? src #f)
|
||||
(error (format "fmpg_buffer: got NULL for ~a bytes" size))
|
||||
;(let ((dst (malloc size 'nonatomic)))
|
||||
(let ((dst (make-bytes size)))
|
||||
(memcpy dst src size)
|
||||
(values dst size))))))))
|
||||
[(or (eq? buffer #f) (<= size 0)) (values #f 0)]
|
||||
[else
|
||||
(let ((bs (make-bytes size)))
|
||||
(bytes-copy! bs 0 buffer 0 size)
|
||||
(values bs size))])))
|
||||
|
||||
(define (reset-info! set-rate! set-channels! set-sample-bits!
|
||||
set-sample-bytes! set-pcm-length! set-duration-ms!
|
||||
set-audio-streams! set-ffmpeg-file! set-current-pcm-pos!
|
||||
set-bitrate!)
|
||||
(set-rate! -1)
|
||||
(set-channels! -1)
|
||||
(set-sample-bits! -1)
|
||||
(set-sample-bytes! -1)
|
||||
(set-pcm-length! -1)
|
||||
(set-duration-ms! -1)
|
||||
(set-audio-streams! -1)
|
||||
(set-ffmpeg-file! "")
|
||||
(set-current-pcm-pos! 0)
|
||||
(set-bitrate! -1))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Handler protocol used by ffmpeg-decoder.rkt
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (fmpg-ffi-decoder-handler)
|
||||
|
||||
@@ -192,23 +69,31 @@
|
||||
(define audio-streams -1)
|
||||
(define ffmpeg-file "")
|
||||
(define current-pcm-pos 0)
|
||||
|
||||
(define title "")
|
||||
(define author "")
|
||||
(define album "")
|
||||
(define genre "")
|
||||
(define comment "")
|
||||
(define copyright "")
|
||||
(define year -1)
|
||||
(define track -1)
|
||||
(define bitrate -1)
|
||||
|
||||
(define (set-rate! v) (set! rate v))
|
||||
(define (set-channels! v) (set! channels v))
|
||||
(define (set-sample-bits! v) (set! sample-bits v))
|
||||
(define (set-sample-bytes! v) (set! sample-bytes v))
|
||||
(define (set-pcm-length! v) (set! pcm-length v))
|
||||
(define (set-duration-ms! v) (set! duration-ms v))
|
||||
(define (set-audio-streams! v) (set! audio-streams v))
|
||||
(define (set-ffmpeg-file! v) (set! ffmpeg-file v))
|
||||
(define (set-current-pcm-pos! v) (set! current-pcm-pos v))
|
||||
(define (set-bitrate! v) (set! bitrate v))
|
||||
|
||||
(define (reset!)
|
||||
(reset-info! set-rate! set-channels! set-sample-bits!
|
||||
set-sample-bytes! set-pcm-length! set-duration-ms!
|
||||
set-audio-streams! set-ffmpeg-file! set-current-pcm-pos!
|
||||
set-bitrate!))
|
||||
|
||||
(define (new)
|
||||
(if (eq? fh #f)
|
||||
(begin
|
||||
(set! fh (fmpg_init))
|
||||
(set! fh (fmpg-init))
|
||||
(when (eq? fh #f)
|
||||
(error "fmpg_init: could not allocate ffmpeg instance"))
|
||||
(error "fmpg-init: could not allocate ffmpeg instance"))
|
||||
#t)
|
||||
(error "ffmpeg handle already initialized, delete it first")))
|
||||
|
||||
@@ -216,44 +101,31 @@
|
||||
(if (eq? fh #f)
|
||||
(error "ffmpeg handle has already been deleted")
|
||||
(begin
|
||||
(fmpg_free fh)
|
||||
(fmpg-close! fh)
|
||||
(set! fh #f)
|
||||
(set! rate -1)
|
||||
(set! channels -1)
|
||||
(set! sample-bits -1)
|
||||
(set! sample-bytes -1)
|
||||
(set! pcm-length -1)
|
||||
(set! duration-ms -1)
|
||||
(set! audio-streams -1)
|
||||
(set! ffmpeg-file "")
|
||||
(set! current-pcm-pos 0)
|
||||
(reset!)
|
||||
#t)))
|
||||
|
||||
(define (fetch-info)
|
||||
(set! rate (fmpg_audio_sample_rate fh))
|
||||
(set! channels (fmpg_audio_channels fh))
|
||||
(set! sample-bits (fmpg_audio_bits_per_sample fh))
|
||||
(set! sample-bytes (fmpg_audio_bytes_per_sample fh))
|
||||
(set! pcm-length (fmpg_duration_samples fh))
|
||||
(set! duration-ms (fmpg_duration_ms fh))
|
||||
(set! audio-streams (fmpg_audio_stream_count fh))
|
||||
(set! title (str (fmpg_file_title fh)))
|
||||
(set! author (str (fmpg_file_author fh)))
|
||||
(set! album (str (fmpg_file_album fh)))
|
||||
(set! genre (str (fmpg_file_genre fh)))
|
||||
(set! comment (str (fmpg_file_comment fh)))
|
||||
(set! copyright (str (fmpg_file_copyright fh)))
|
||||
(set! year (fmpg_file_year fh))
|
||||
(set! track (fmpg_file_track fh))
|
||||
(set! bitrate (fmpg_file_bitrate fh)))
|
||||
(set! rate (fmpg-audio-sample-rate fh))
|
||||
(set! channels (fmpg-audio-channels fh))
|
||||
(set! sample-bits (fmpg-audio-bits-per-sample fh))
|
||||
(set! sample-bytes (fmpg-audio-bytes-per-sample fh))
|
||||
(set! pcm-length (fmpg-duration-samples fh))
|
||||
(set! duration-ms (fmpg-duration-ms fh))
|
||||
(set! audio-streams (fmpg-audio-stream-count fh))
|
||||
(set! bitrate (fmpg-file-bitrate fh)))
|
||||
|
||||
(define (init file)
|
||||
(unless (ok? (fmpg_open_file fh file))
|
||||
(error (format "fmpg_open_file: could not open ~a" file)))
|
||||
(set! ffmpeg-file (format "~a" file))
|
||||
(set! current-pcm-pos 0)
|
||||
(fetch-info)
|
||||
#t)
|
||||
(let ((filename (filename->string file)))
|
||||
(unless filename
|
||||
(error (format "fmpg-open-file!: expected path or string, got ~a" file)))
|
||||
(unless (ok? (fmpg-open-file! fh filename))
|
||||
(error (format "fmpg-open-file!: could not open ~a" filename)))
|
||||
(set! ffmpeg-file filename)
|
||||
(set! current-pcm-pos 0)
|
||||
(fetch-info)
|
||||
#t))
|
||||
|
||||
(define (ffmpeg-format cb)
|
||||
(cb current-pcm-pos rate channels sample-bits sample-bytes pcm-length))
|
||||
@@ -267,76 +139,43 @@
|
||||
(info-sound "rate : ~a" rate)
|
||||
(info-sound "pcm-length : ~a" pcm-length)
|
||||
(info-sound "duration-ms : ~a" duration-ms)
|
||||
(info-sound "title : ~a" title)
|
||||
(info-sound "author : ~a" author)
|
||||
(info-sound "album : ~a" album)
|
||||
(info-sound "genre : ~a" genre)
|
||||
(info-sound "year : ~a" year)
|
||||
(info-sound "track : ~a" track)
|
||||
(info-sound "bitrate : ~a" bitrate)
|
||||
#t)
|
||||
|
||||
(define (close)
|
||||
(unless (eq? fh #f)
|
||||
(when (ok? (fmpg_is_open fh))
|
||||
(fmpg_close fh))
|
||||
(set! channels -1)
|
||||
(set! pcm-length -1)
|
||||
(set! duration-ms -1)
|
||||
(set! rate -1)
|
||||
(set! sample-bits -1)
|
||||
(set! sample-bytes -1)
|
||||
(set! audio-streams -1)
|
||||
(set! ffmpeg-file "")
|
||||
(when (ok? (fmpg-is-open fh))
|
||||
(fmpg-close! fh))
|
||||
(reset!)
|
||||
#t))
|
||||
|
||||
(define (read cb format-cb)
|
||||
;; Unlike mpg123, this shim already has a fixed output format after
|
||||
;; fmpg_open_file. Still report the format lazily on the first read so
|
||||
;; the decoder layer can keep exactly the same structure as mp3-decoder.
|
||||
(when (= current-pcm-pos 0)
|
||||
(ffmpeg-format format-cb))
|
||||
(if (ok? (fmpg_decode_next fh))
|
||||
(if (ok? (fmpg-decode-next! fh))
|
||||
(let-values ([(buffer size) (copy-current-buffer fh)])
|
||||
(cond
|
||||
((or (eq? buffer #f) (<= size 0))
|
||||
;; Defensive: fmpg_decode_next should only return 1 when there
|
||||
;; is PCM data, but if the native side ever returns an empty
|
||||
;; block, simply read again.
|
||||
(read cb format-cb))
|
||||
(else
|
||||
;; The start sample is the absolute music position of the first
|
||||
;; sample frame in this buffer. This is more useful than the
|
||||
;; end position for UI and progress reporting.
|
||||
(let ((pcm-pos (fmpg_buffer_start_sample fh)))
|
||||
(set! current-pcm-pos (fmpg_buffer_end_sample fh))
|
||||
(cb 'data pcm-pos buffer size)))))
|
||||
[(or (eq? buffer #f) (<= size 0)) (read cb format-cb)]
|
||||
[else
|
||||
(let ((pcm-pos (fmpg-buffer-start-sample fh)))
|
||||
(set! current-pcm-pos (fmpg-buffer-end-sample fh))
|
||||
(cb 'data pcm-pos buffer size))]))
|
||||
(cb 'done -1 #f 0))
|
||||
#t)
|
||||
|
||||
(define (seek pcm-pos)
|
||||
(let* ((r (if (and (integer? rate) (> rate 0)) rate 44100))
|
||||
(ms (inexact->exact
|
||||
(round (* 1000.0 (/ pcm-pos r))))))
|
||||
(unless (ok? (fmpg_seek_ms fh ms))
|
||||
(error (format "fmpg_seek_ms: could not seek to sample ~a (~a ms)"
|
||||
pcm-pos ms)))
|
||||
(set! current-pcm-pos (fmpg_sample_position fh))
|
||||
(ms (inexact->exact (round (* 1000.0 (/ pcm-pos r))))))
|
||||
(unless (ok? (fmpg-seek-ms! fh ms))
|
||||
(error (format "fmpg-seek-ms!: could not seek to sample ~a (~a ms)" pcm-pos ms)))
|
||||
(set! current-pcm-pos (fmpg-sample-position fh))
|
||||
#t))
|
||||
|
||||
(define (tell)
|
||||
(if (eq? fh #f) 0 (fmpg_sample_position fh)))
|
||||
(if (eq? fh #f) 0 (fmpg-sample-position fh)))
|
||||
|
||||
(define (metadata)
|
||||
(let ((h (make-hash)))
|
||||
(hash-set! h 'title title)
|
||||
(hash-set! h 'author author)
|
||||
(hash-set! h 'album album)
|
||||
(hash-set! h 'genre genre)
|
||||
(hash-set! h 'comment comment)
|
||||
(hash-set! h 'copyright copyright)
|
||||
(hash-set! h 'year year)
|
||||
(hash-set! h 'track track)
|
||||
(hash-set! h 'bitrate bitrate)
|
||||
(hash-set! h 'duration-ms duration-ms)
|
||||
(hash-set! h 'audio-streams audio-streams)
|
||||
|
||||
+2
-2
@@ -16,8 +16,8 @@
|
||||
(define test-file3-id 3)
|
||||
(define test-file4-id 4)
|
||||
|
||||
(set! test-file3 (build-path tests "idyll.flac"))
|
||||
(set! test-file4 (build-path tests "idyll.mp3"))
|
||||
(set! test-file3 (build-path tests "mahler-1.mp3"))
|
||||
(set! test-file4 (build-path tests "mahler-2.mp3"))
|
||||
|
||||
;(define fmt (ao-mk-format 24 48000 2 'big-endian))
|
||||
;(define ao-h (ao-open-live #f fmt))
|
||||
|
||||
@@ -0,0 +1,102 @@
|
||||
#lang racket/base
|
||||
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/define
|
||||
ffi/unsafe/alloc
|
||||
(for-syntax racket/base)
|
||||
"utils.rkt"
|
||||
)
|
||||
|
||||
(provide make-offsets
|
||||
def-cstruct
|
||||
struct-helpers
|
||||
)
|
||||
|
||||
(define (make-offsets* defs)
|
||||
(let ((name-store (make-hash)))
|
||||
|
||||
(define (expand-type n t)
|
||||
(if (= n 0)
|
||||
'()
|
||||
(cons t (expand-type (- n 1) t))))
|
||||
|
||||
(define (make-types defs idx)
|
||||
(if (null? defs)
|
||||
'()
|
||||
(let ((d (car defs)))
|
||||
(let ((t (if (list? d)
|
||||
(if (symbol? (car d))
|
||||
(let ((name (car d)))
|
||||
(hash-set! name-store name (list idx (cadr d)))
|
||||
(list 1 (cadr d)))
|
||||
d)
|
||||
(list 1 d))))
|
||||
(append (expand-type (car t) (cadr t))
|
||||
(make-types (cdr defs) (+ idx (car t))))))
|
||||
))
|
||||
|
||||
(let ((offsets (compute-offsets (make-types defs 0))))
|
||||
(let ((keys (hash-keys name-store))
|
||||
(offs (make-hash)))
|
||||
(for-each (λ (key)
|
||||
(let* ((idx-t (hash-ref name-store key))
|
||||
(idx (car idx-t))
|
||||
(t (cadr idx-t)))
|
||||
(hash-set! offs key (list (list-ref offsets idx) t))
|
||||
)
|
||||
)
|
||||
keys)
|
||||
offs))))
|
||||
|
||||
|
||||
(define-syntax (make-offset stx)
|
||||
(syntax-case stx ()
|
||||
((_ (x t))
|
||||
(cond
|
||||
((number? (syntax->datum #'x)) #'(list x t))
|
||||
(else #'(list 'x t))
|
||||
)
|
||||
)
|
||||
((_ t)
|
||||
#'(list 1 t))
|
||||
)
|
||||
)
|
||||
|
||||
(define-syntax make-offsets
|
||||
(syntax-rules ()
|
||||
((_ a ...)
|
||||
(make-offsets* (list (make-offset a) ...)))))
|
||||
|
||||
(define-syntax def-cstruct
|
||||
(syntax-rules ()
|
||||
((_ name (t ...) offs)
|
||||
(define-cstruct name
|
||||
([t (cadr (hash-ref offs 't)) #:offset (car (hash-ref offs 't))]
|
||||
...)))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal structures for ffmpeg decoding
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax def-struct-helpers
|
||||
(syntax-rules ()
|
||||
((_ (struct-get get struct-set set))
|
||||
(begin
|
||||
(define get struct-get)
|
||||
(define set struct-set))
|
||||
)
|
||||
((_ (struct-get get))
|
||||
(define get struct-get)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define-syntax struct-helpers
|
||||
(syntax-rules ()
|
||||
((_ a ...)
|
||||
(begin
|
||||
(def-struct-helpers a)
|
||||
...))))
|
||||
@@ -21,6 +21,17 @@
|
||||
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)
|
||||
@@ -126,4 +137,102 @@
|
||||
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