1.1--- a/lisp/ffi/readline/pkg.lisp Wed Sep 18 21:48:06 2024 -0400
1.2+++ b/lisp/ffi/readline/pkg.lisp Thu Sep 19 23:23:02 2024 -0400
1.3@@ -2,6 +2,8 @@
1.4
1.5 ;;; Commentary:
1.6
1.7+;; https://github.com/vindarel/cl-readline
1.8+
1.9 ;;; Code:
1.10 (defpackage :readline
1.11 (:use :cl :sb-alien :std/alien)
1.12@@ -10,61 +12,3 @@
1.13 (in-package :readline)
1.14
1.15 (define-alien-loader "readline" t "/usr/lib/")
1.16-
1.17-(macrolet ((def-rl-var (name var type)
1.18- `(define-alien-variable (,name ,var) ,type)))
1.19- (def-rl-var "rl_line_buffer" *line-buffer* c-string)
1.20- (def-rl-var "rl_point" *point* int)
1.21- (def-rl-var "rl_end" *end* int)
1.22- (def-rl-var "rl_mark" *mark* int)
1.23- (def-rl-var "rl_done" *point* boolean)
1.24- (def-rl-var "rl_num_chars_to_read" *num-chars-to-read* int)
1.25- (def-rl-var "rl_pending_input" *pending-input* int)
1.26- (def-rl-var "rl_dispatching" *point* boolean)
1.27- (def-rl-var "rl_erase_empty_line" *point* boolean)
1.28- (def-rl-var "rl_prompt" *prompt* c-string)
1.29- (def-rl-var "rl_display_prompt" *display-prompt* c-string)
1.30- (def-rl-var "rl_already_prompted" *already-prompted* boolean)
1.31- (def-rl-var "rl_library_version" *library-version* c-string)
1.32- ;; (def-rl-var "rl_readline_version" *readline-version* version)
1.33- (def-rl-var "rl_gnu_readline_p" *gnu-readline-p* boolean)
1.34- (def-rl-var "rl_terminal_name" *terminal-name* c-string)
1.35- (def-rl-var "rl_readline_name" *readline-name* c-string)
1.36- (def-rl-var "rl_instream" *instream* (* t))
1.37- (def-rl-var "rl_outstream" *outstream* (* t))
1.38- (def-rl-var "rl_prefer_env_winsize" *prefer-env-winsize* boolean)
1.39- (def-rl-var "rl_last_func" *last-func* (* t))
1.40- (def-rl-var "rl_startup_hook" *startup-hook* (* t))
1.41- (def-rl-var "rl_pre_input_hook" *pre-input-hook* (* t))
1.42- (def-rl-var "rl_event_hook" *event-hook* (* t))
1.43- (def-rl-var "rl_getc_function" *getc-function* (* t))
1.44- (def-rl-var "rl_signal_event_hook" *signal-event-hook* (* t))
1.45- (def-rl-var "rl_input-available_hook" *input-available-hook* (* t))
1.46- (def-rl-var "rl_redisplay_function" *redisplay-function* (* t))
1.47- (def-rl-var "rl_prep_term_function" *prep-term-function* (* t))
1.48- (def-rl-var "rl_deprep_term_function" *deprep-term-function* (* t))
1.49- (def-rl-var "rl_executing_keymap" *executing-keymap* (* t))
1.50- (def-rl-var "rl_binding_keymap" *binding-keymap* (* t))
1.51- (def-rl-var "rl_executing_macro" *executing-macro* c-string)
1.52- (def-rl-var "rl_executing_key" *executing-key* char)
1.53- (def-rl-var "rl_executing_keyseq" *executing-keyseq* c-string)
1.54- (def-rl-var "rl_key_sequence_length" *key-sequence-length* int)
1.55- ;; (def-rl-var "rl_readline_state" *readline-state* int)
1.56- (def-rl-var "rl_explicit_arg" *explicit-arg* boolean)
1.57- (def-rl-var "rl_numeric_arg" *numeric-arg* int)
1.58- ;; (def-rl-var "rl_editing_mode" *editing-mode* int)
1.59- (def-rl-var "rl_catch_sigwinch" *catch-sigwinch* boolean)
1.60- (def-rl-var "rl_change_environment" *change-environment* boolean)
1.61- (def-rl-var "rl_attempted_completion_function" *attempted-completion-function* (* t))
1.62- (def-rl-var "rl_completion_display_matches_hook" *completion-display-matches-hook* (* t))
1.63- (def-rl-var "rl_basic_word_break_characters" *basic-word-break-characters* c-string)
1.64- (def-rl-var "rl_completer_word_break_character" *completer-word-break-characters* c-string)
1.65- (def-rl-var "rl_completion_query_items" *completer-query-items* int)
1.66- (def-rl-var "rl_completion_append_character" *completion-append-character* char)
1.67- (def-rl-var "rl_ignore_completion_duplicates" *ignore-completion-duplicates* boolean)
1.68- (def-rl-var "rl_attempted_completion_over" *attempted-completion-over* boolean)
1.69- (def-rl-var "rl_sort_completion_matches" *sort-completion-matches* boolean)
1.70- ;; (def-rl-var "rl_completion_type" *completion-type* completion-type)
1.71- (def-rl-var "rl_inhibit_completion" *inhibit-completion* boolean)
1.72- (def-rl-var "history_base" *history-base* int)
1.73- (def-rl-var "history_length" *history-length* int))
2.1--- a/lisp/ffi/readline/readline.lisp Wed Sep 18 21:48:06 2024 -0400
2.2+++ b/lisp/ffi/readline/readline.lisp Thu Sep 19 23:23:02 2024 -0400
2.3@@ -1,7 +1,242 @@
2.4 ;;; readline/readline.lisp --- Readline Alien Routines
2.5
2.6-;; also consider https://github.com/antirez/linenoise
2.7+;; This implementation is based on Vindarel's cl-readline: https://github.com/vindarel/cl-readline
2.8
2.9 ;;; Code:
2.10 (in-package :readline)
2.11
2.12+(define-alien-enum (rl-completion-type int :test eq)
2.13+ :standard-completion 9
2.14+ :display-and-perform 33
2.15+ :insert-all 42
2.16+ :list-all 63
2.17+ :not-list-cmn-prefix 64)
2.18+
2.19+(define-alien-type rl-history-entry (struct rl-history-entry
2.20+ (line (* t))
2.21+ (time (* t))
2.22+ (data (* t))))
2.23+(macrolet ((def-rl-var (name var type)
2.24+ `(define-alien-variable (,name ,var) ,type)))
2.25+ (def-rl-var "rl_line_buffer" *line-buffer* c-string)
2.26+ (def-rl-var "rl_point" *point* int)
2.27+ (def-rl-var "rl_end" *end* int)
2.28+ (def-rl-var "rl_mark" *mark* int)
2.29+ (def-rl-var "rl_done" *point* boolean)
2.30+ (def-rl-var "rl_num_chars_to_read" *num-chars-to-read* int)
2.31+ (def-rl-var "rl_pending_input" *pending-input* int)
2.32+ (def-rl-var "rl_dispatching" *point* boolean)
2.33+ (def-rl-var "rl_erase_empty_line" *erase-empty-line* boolean)
2.34+ (def-rl-var "rl_prompt" *prompt* c-string)
2.35+ (def-rl-var "rl_display_prompt" *display-prompt* c-string)
2.36+ (def-rl-var "rl_already_prompted" *already-prompted* boolean)
2.37+ (def-rl-var "rl_library_version" *library-version* c-string)
2.38+ (def-rl-var "rl_readline_version" *readline-version* int)
2.39+ (def-rl-var "rl_gnu_readline_p" *gnu-readline-p* boolean)
2.40+ (def-rl-var "rl_terminal_name" *terminal-name* c-string)
2.41+ (def-rl-var "rl_readline_name" *readline-name* c-string)
2.42+ (def-rl-var "rl_instream" *instream* (* t))
2.43+ (def-rl-var "rl_outstream" *outstream* (* t))
2.44+ (def-rl-var "rl_prefer_env_winsize" *prefer-env-winsize* boolean)
2.45+ (def-rl-var "rl_last_func" *last-func* (* t))
2.46+ (def-rl-var "rl_startup_hook" *startup-hook* (* t))
2.47+ (def-rl-var "rl_pre_input_hook" *pre-input-hook* (* t))
2.48+ (def-rl-var "rl_event_hook" *event-hook* (* t))
2.49+ (def-rl-var "rl_getc_function" *getc-function* (* t))
2.50+ (def-rl-var "rl_signal_event_hook" *signal-event-hook* (* t))
2.51+ (def-rl-var "rl_input-available_hook" *input-available-hook* (* t))
2.52+ (def-rl-var "rl_redisplay_function" *redisplay-function* (* t))
2.53+ (def-rl-var "rl_prep_term_function" *prep-term-function* (* t))
2.54+ (def-rl-var "rl_deprep_term_function" *deprep-term-function* (* t))
2.55+ (def-rl-var "rl_executing_keymap" *executing-keymap* (* t))
2.56+ (def-rl-var "rl_binding_keymap" *binding-keymap* (* t))
2.57+ (def-rl-var "rl_executing_macro" *executing-macro* c-string)
2.58+ (def-rl-var "rl_executing_key" *executing-key* char)
2.59+ (def-rl-var "rl_executing_keyseq" *executing-keyseq* c-string)
2.60+ (def-rl-var "rl_key_sequence_length" *key-sequence-length* int)
2.61+ (def-rl-var "rl_readline_state" *readline-state* int)
2.62+ (def-rl-var "rl_explicit_arg" *explicit-arg* boolean)
2.63+ (def-rl-var "rl_numeric_arg" *numeric-arg* int)
2.64+ (def-rl-var "rl_editing_mode" *editing-mode* int)
2.65+ (def-rl-var "rl_catch_sigwinch" *catch-sigwinch* boolean)
2.66+ (def-rl-var "rl_change_environment" *change-environment* boolean)
2.67+ (def-rl-var "rl_attempted_completion_function" *attempted-completion-function* (* t))
2.68+ (def-rl-var "rl_completion_display_matches_hook" *completion-display-matches-hook* (* t))
2.69+ (def-rl-var "rl_basic_word_break_characters" *basic-word-break-characters* c-string)
2.70+ (def-rl-var "rl_completer_word_break_character" *completer-word-break-characters* c-string)
2.71+ (def-rl-var "rl_completion_query_items" *completer-query-items* int)
2.72+ (def-rl-var "rl_completion_append_character" *completion-append-character* char)
2.73+ (def-rl-var "rl_ignore_completion_duplicates" *ignore-completion-duplicates* boolean)
2.74+ (def-rl-var "rl_attempted_completion_over" *attempted-completion-over* boolean)
2.75+ (def-rl-var "rl_sort_completion_matches" *sort-completion-matches* boolean)
2.76+ (def-rl-var "rl_completion_type" *completion-type* rl-completion-type)
2.77+ (def-rl-var "rl_inhibit_completion" *inhibit-completion* boolean)
2.78+ (def-rl-var "history_base" *history-base* int)
2.79+ (def-rl-var "history_length" *history-length* int))
2.80+
2.81+(defvar *states*
2.82+ '(:initializing ; 0x0000001 initializing
2.83+ :initialized ; 0x0000002 initialization done
2.84+ :termprepped ; 0x0000004 terminal is prepped
2.85+ :readcmd ; 0x0000008 reading a command key
2.86+ :metanext ; 0x0000010 reading input after ESC
2.87+ :dispatching ; 0x0000020 dispatching to a command
2.88+ :moreinput ; 0x0000040 reading more input in a command function
2.89+ :isearch ; 0x0000080 doing incremental search
2.90+ :nsearch ; 0x0000100 doing non-incremental search
2.91+ :search ; 0x0000200 doing a history search
2.92+ :numericarg ; 0x0000400 reading numeric argument
2.93+ :macroinput ; 0x0000800 getting input from a macro
2.94+ :macrodef ; 0x0001000 defining keyboard macro
2.95+ :overwrite ; 0x0002000 overwrite mode
2.96+ :completing ; 0x0004000 doing completion
2.97+ :sighandler ; 0x0008000 in readline sighandler
2.98+ :undoing ; 0x0010000 doing an undo
2.99+ :inputpending ; 0x0020000 rl_execute_next called
2.100+ :ttycsaved ; 0x0040000 tty special chars saved
2.101+ :callback ; 0x0080000 using the callback interface
2.102+ :vimotion ; 0x0100000 reading vi motion arg
2.103+ :multikey ; 0x0200000 reading multiple-key command
2.104+ :vicmdonce ; 0x0400000 entered vi command mode at least once
2.105+ :redisplaying ; 0x0800000 updating terminal display
2.106+ :done) ; 0x1000000 done; accepted line
2.107+ "Possible state values for `+readline-state+'.")
2.108+
2.109+(defvar +c-buffer-size+ 256
2.110+ "How many bytes to allocate per Lisp string when converting list of
2.111+Lisp strings into array of C strings.")
2.112+
2.113+(defun decode-version (version)
2.114+ "Transform VERSION into two values representing major and minor numbers of
2.115+Readline library version."
2.116+ (values (ldb (byte 8 8) version)
2.117+ (ldb (byte 8 0) version)))
2.118+
2.119+;; (defun decode-state (state)
2.120+;; "Transform Readline state STATE into list of keywords. See `+states+' for
2.121+;; list of components that can appear in result list."
2.122+;; (mapcan (lambda (index keyword)
2.123+;; (when (logbitp index state)
2.124+;; (list keyword)))
2.125+;; (iota (length +states+))
2.126+;; +states+))
2.127+
2.128+(defmacro produce-callback (function return-type &optional func-arg-list)
2.129+ "Return pointer to callback that calls FUNCTION. RETURN-TYPE specifies
2.130+return type of the function and FUNC-ARG-LIST is list of argument types (it
2.131+can be ommited if FUNCTION doesn't take any arguments)."
2.132+ (let ((gensymed-list (mapcar (lambda (x) (list (gensym) x))
2.133+ func-arg-list)))
2.134+ (std:with-gensyms (temp)
2.135+ `(when ,function
2.136+ (progn
2.137+ (define-alien-callable ,temp ,return-type ,gensymed-list
2.138+ (funcall ,function ,@(mapcar #'car gensymed-list)))
2.139+ (alien-callable-function ',temp))))))
2.140+
2.141+(defun produce-callback* (function return-type &optional func-arg-list)
2.142+ "Variant of PRODUCE-CALLBACK that should hopefully be more portable.
2.143+This avoids using a GENSYM as the name of a callback, and is also funcallable."
2.144+ (let ((gensymed-list (mapcar (lambda (x) (list (gensym) x))
2.145+ func-arg-list)))
2.146+ (std:with-gensyms (temp)
2.147+ (when function
2.148+ (progn
2.149+ (eval `(define-alien-callable ,temp ,return-type ,gensymed-list
2.150+ (funcall ,function ,@(mapcar #'car gensymed-list))))
2.151+ (alien-callable-function temp))))))
2.152+
2.153+;;; cl-readline
2.154+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2.155+
2.156+(defun recent-history-line-satisfies-p (predicate)
2.157+ "Check if the most recent history line satisfies given predicate
2.158+PREDICATE. Return T if there is no history saved."
2.159+ (if (zerop *history-length*)
2.160+ t
2.161+ (with-alien ((s rl-history-entry))
2.162+ (funcall predicate
2.163+ ;; TODO 2024-09-19: does SBCL know how to conver this to a lisp string automatically?
2.164+ (with-alien-slots
2.165+ (line)
2.166+ ;; (alien-funcall "history_get"
2.167+ ;; :int
2.168+ ;; (1- (+ *history-base*
2.169+ ;; *history-length*)))
2.170+ s
2.171+ line)))))
2.172+
2.173+(define-alien-routine "readline" (* t) (prompt c-string))
2.174+(define-alien-routine "add_history" void (line c-string))
2.175+
2.176+(defun rl (&key
2.177+ prompt
2.178+ already-prompted
2.179+ num-chars
2.180+ erase-empty-line
2.181+ add-history
2.182+ novelty-check)
2.183+ "Get a line from user with editing. PROMPT, if supplied, is printed before
2.184+reading of input. Non-NIL value of ALREADY-PROMPTED will tell Readline that
2.185+the application has printed prompt already. However, PROMPT must be supplied
2.186+in this case too, so redisplay functions can update the display properly. If
2.187+NUM-CHARS argument is a positive number, Readline will return after
2.188+accepting that many characters. If ERASE-EMPTY-LINE is not NIL, `readline'
2.189+will completely erase the current line, including any prompt, any time a
2.190+newline is typed as the only character on an otherwise-empty line. The
2.191+cursor is moved to the beginning of the newly-blank line. Supplying
2.192+ADD-HISTORY tells Readline that user's input should be added to
2.193+history. However, blank lines don't get into history anyway. NOVELTY-CHECK,
2.194+if given, must be a predicate that takes two strings: the actual line and
2.195+the most recent history line. Only when the predicate evaluates to non-NIL
2.196+value new line will be added to the history. Return value on success is the
2.197+actual string and NIL on failure."
2.198+ (setf *already-prompted* already-prompted
2.199+ *num-chars-to-read* (or num-chars 0)
2.200+ *erase-empty-line* erase-empty-line)
2.201+ (let* ((prompt (if prompt (string prompt) ""))
2.202+ (ptr (readline prompt)))
2.203+ (unless (null ptr)
2.204+ (unwind-protect
2.205+ (let ((str ptr))
2.206+ (when (and add-history
2.207+ (not (sequence:emptyp str))
2.208+ (or (not novelty-check)
2.209+ (recent-history-line-satisfies-p
2.210+ (std:curry novelty-check str))))
2.211+ (add-history str))
2.212+ str)
2.213+ (free-alien ptr)))))
2.214+
2.215+;; (defun ensure-initialization ()
2.216+;; "Make sure that Readline is initialized. If it's not initialized yet,
2.217+;; initialize it."
2.218+;; (unless (find :initialized *readline-state*)
2.219+;; (initialize)))
2.220+
2.221+;; (defmacro with-possible-redirection (filename append &body body)
2.222+;; "If FILENAME is not NIL, try to create C file named FILENAME,
2.223+;; temporarily reassign `*outstream*' to pointer to this file, perform BODY,
2.224+;; then close the file and assign `*outstream*' the old value. If APPEND is not
2.225+;; NIL, output will be appended to the file. Returns NIL on success and T on
2.226+;; failure."
2.227+;; (std:with-gensyms (temp-outstream file-pointer body-fnc)
2.228+;; `(flet ((,body-fnc ()
2.229+;; ,@body))
2.230+;; (if ,filename
2.231+;; (let ((,temp-outstream *outstream*)
2.232+;; (,file-pointer (foreign-funcall "fopen"
2.233+;; :string ,filename
2.234+;; :string (if ,append "a" "w")
2.235+;; :pointer)))
2.236+;; (if (null-alien ,file-pointer)
2.237+;; t
2.238+;; (unwind-protect
2.239+;; (progn
2.240+;; (setf *outstream* ,file-pointer)
2.241+;; (,body-fnc))
2.242+;; (foreign-funcall "fclose"
2.243+;; :pointer ,file-pointer
2.244+;; :boolean)
2.245+;; (setf *outstream* ,temp-outstream))))
2.246+;; (,body-fnc)))))
3.1--- a/lisp/ffi/zstd/constants.lisp Wed Sep 18 21:48:06 2024 -0400
3.2+++ b/lisp/ffi/zstd/constants.lisp Thu Sep 19 23:23:02 2024 -0400
3.3@@ -21,4 +21,9 @@
3.4 ((* t) dst "void*" "dst")
3.5 (size-t size "size_t" "size")
3.6 (size-t pos "size-t" "pos"))
3.7+ nil t)
3.8+ (:structure zdict-params ("ZDICT_params_t"
3.9+ (int compression-level "int" "compressionLevel")
3.10+ (unsigned notification-level "unsigned" "notificationLevel")
3.11+ (unsigned dict-id "unsigned" "dictID"))
3.12 nil t))
4.1--- a/lisp/ffi/zstd/dict.lisp Wed Sep 18 21:48:06 2024 -0400
4.2+++ b/lisp/ffi/zstd/dict.lisp Thu Sep 19 23:23:02 2024 -0400
4.3@@ -4,6 +4,11 @@
4.4
4.5 ;;; Commentary:
4.6
4.7+;; The CDict can be created once and shared across multiple threads since it's
4.8+;; read-only.
4.9+
4.10+;; Unclear if DDict is also read-only.
4.11+
4.12 ;; From zdict.h:
4.13 #|
4.14 * Zstd dictionary builder
4.15@@ -261,7 +266,7 @@
4.16
4.17 (define-alien-routine "ZSTD_freeDDict" size-t (ddict (* zstd-ddict)))
4.18
4.19-(define-alien-routine "ZSTD_compress_usingDDict" size-t
4.20+(define-alien-routine "ZSTD_decompress_usingDDict" size-t
4.21 (dctx (* zstd-dctx))
4.22 (dst (* t))
4.23 (dst-capacity size-t)
4.24@@ -287,13 +292,26 @@
4.25 (define-alien-routine "ZSTD_estimatedDictSize" size-t (dict-size size-t) (dict-load-method zstd-dict-load-method))
4.26
4.27 (defmacro with-zstd-cdict ((cv &key buffer size (level (zstd-defaultclevel))) &body body)
4.28- (let ((size (or size (length buffer))))
4.29- `(with-alien ((,cv (* zstd-cdict) (zstd-createcdict (cast (octets-to-alien ,buffer) (* t)) ,size ,level)))
4.30- (unwind-protect (progn ,@body)
4.31- (zstd-freecdict ,cv)))))
4.32+ `(with-alien ((,cv (* zstd-cdict) (zstd-createcdict (cast (octets-to-alien ,buffer) (* t))
4.33+ (or ,size (length ,buffer))
4.34+ ,level)))
4.35+ (unwind-protect (progn ,@body)
4.36+ (zstd-freecdict ,cv))))
4.37
4.38 (defmacro with-zstd-ddict ((dv &key buffer size) &body body)
4.39- (let ((size (or size (length buffer))))
4.40- `(with-alien ((,dv (* zstd-ddict) (zstd-createddict (cast (octets-to-alien ,buffer) (* t)) ,size)))
4.41- (unwind-protect (progn ,@body)
4.42- (zstd-freeddict ,dv)))))
4.43+ `(with-alien ((,dv (* zstd-ddict)
4.44+ (zstd-createddict (cast (octets-to-alien ,buffer) (* t)) (or ,size (length ,buffer)))))
4.45+ (unwind-protect (progn ,@body)
4.46+ (zstd-freeddict ,dv))))
4.47+
4.48+;;; zdict.h
4.49+(define-alien-type zstd-cover-params
4.50+ (struct zdict-cover-params
4.51+ (k unsigned)
4.52+ (d unsigned)
4.53+ (steps unsigned)
4.54+ (nb-threads unsigned)
4.55+ (split-point double)
4.56+ (shrink-dict unsigned)
4.57+ (shrink-dict-max-regression unsigned)
4.58+ (zparams zdict-params)))
5.1--- a/lisp/ffi/zstd/tests.lisp Wed Sep 18 21:48:06 2024 -0400
5.2+++ b/lisp/ffi/zstd/tests.lisp Thu Sep 19 23:23:02 2024 -0400
5.3@@ -96,13 +96,29 @@
5.4 (zerop
5.5 (zstd-iserror
5.6 (zstd::zstd-decompress-usingdict
5.7- ds
5.8+ ds
5.9 (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out)
5.10 (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in)
5.11 dict (length test))))))))))
5.12
5.13 (deftest bulk-dictionary ()
5.14- (with-zstd-ddict (dd :buffer #(1 2 3))
5.15- (is (typep dd '(alien (* (struct zstd::zstd-ddict-s))))))
5.16- (with-zstd-cdict (cd :buffer #(4 5 6))
5.17- (is (typep cd '(alien (* (struct zstd::zstd-cdict-s)))))))
5.18+ (let ((test #(1 2 3 4)))
5.19+ (with-alien ((dict (* t))
5.20+ (dst (array (unsigned 8) 100)))
5.21+ (with-zstd-buffers (in out :src (octets-to-alien test) :dst (cast dst (* t)) :dst-size 100)
5.22+ (with-zstd-streams (cs ds)
5.23+ (with-zstd-cdict (cd :buffer test :size (length test))
5.24+ (is (typep cd '(alien (* (struct zstd::zstd-cdict-s)))))
5.25+ (is (zerop
5.26+ (zstd-iserror
5.27+ (zstd::zstd-compress-usingcdict cs (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out)
5.28+ (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in)
5.29+ cd)))))
5.30+ (with-zstd-ddict (dd :buffer test :size (length test))
5.31+ (is (typep dd '(alien (* (struct zstd::zstd-ddict-s)))))
5.32+ (is (zerop
5.33+ (zstd-iserror
5.34+ (zstd::zstd-decompress-usingddict
5.35+ ds (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out)
5.36+ (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in) dd))))))))))
5.37+
6.1--- a/lisp/lib/io/flate.lisp Wed Sep 18 21:48:06 2024 -0400
6.2+++ b/lisp/lib/io/flate.lisp Thu Sep 19 23:23:02 2024 -0400
6.3@@ -14,7 +14,7 @@
6.4
6.5 ;; The compression backends are themselves hand-coded in Common Lisp, making
6.6 ;; them excellent reference material. However, we don't have much use for the
6.7-;; compression backend offered.
6.8+;; compression backends offered.
6.9
6.10 ;; We intend to almost exclusively support Zstd compression and decompression
6.11 ;; using our ZSTD FFI Lisp system, so we'll make a new library - FLATE - which
7.1--- a/lisp/std/alien.lisp Wed Sep 18 21:48:06 2024 -0400
7.2+++ b/lisp/std/alien.lisp Thu Sep 19 23:23:02 2024 -0400
7.3@@ -99,21 +99,26 @@
7.4 (push c-string reversed-result)
7.5 (return (nreverse reversed-result)))))))
7.6
7.7-(defun clone-octets-to-alien (lispa aliena)
7.8- (declare (optimize (speed 3)))
7.9+(defun clone-octets-to-alien (lispa alien)
7.10+ (declare (optimize (speed 3))
7.11+ (simple-vector lispa))
7.12+ ;; (setf aliena (cast aliena (array (unsigned 8))))
7.13 (loop for i from 0 below (length lispa)
7.14- do (setf (deref aliena i)
7.15+ do (setf (deref alien i)
7.16 (aref lispa i)))
7.17- aliena)
7.18+ alien)
7.19
7.20-(defmacro octets-to-alien (lispa)
7.21- (with-gensyms (a)
7.22- `(with-alien ((,a (array (unsigned 8) ,(length lispa))))
7.23- (clone-octets-to-alien ,lispa ,a))))
7.24+(defun octets-to-alien (lispa)
7.25+ (let ((a (make-alien (unsigned 8) (length lispa))))
7.26+ (clone-octets-to-alien lispa a)))
7.27+
7.28+;; TODO 2024-09-19: maybe want to return values, second being the length?
7.29+(defun octets-to-alien-array (lispa)
7.30+ (cast (octets-to-alien lispa) (array (unsigned 8))))
7.31
7.32 (defun clone-octets-from-alien (aliena lispa &optional len)
7.33 (declare (optimize (speed 3))
7.34- (array lispa))
7.35+ (simple-vector lispa))
7.36 (unless len (setf len (length lispa)))
7.37 (loop for i from 0 below len
7.38 do (setf (aref lispa i)
7.39@@ -133,7 +138,6 @@
7.40 (defun bool-to-foreign-int (val)
7.41 (if val 1 0))
7.42
7.43-
7.44 (define-condition invalid-enum-variant (simple-error) ())
7.45 (define-condition invalid-enum-value (simple-error) ())
7.46
7.47@@ -147,7 +151,6 @@
7.48 :format-control "~A is not a value associated with a variant of enum ~A"
7.49 :format-arguments (list var enum)))
7.50
7.51-
7.52 (defmacro define-alien-enum ((name type &key (test 'eql) (default :error)) &rest forms)
7.53 "Define a pseudo-enum type, used to work-around difficulties working with
7.54 SB-ALIEN, groveller, typedef enums, etc.
7.55@@ -184,6 +187,28 @@
7.56 `((when (eql found :error) (invalid-enum-value ,val ',name))))
7.57 (values ,val found)))))))
7.58
7.59+;; from CFFI
7.60+(defmacro with-alien-slots (vars struct &body body)
7.61+ "Create local symbol macros for each var in VARS to reference
7.62+foreign slots in STRUCT. Similar to WITH-SLOTS.
7.63+Each var can be of the form:
7.64+ name name bound to slot of same name
7.65+ (* name) name bound to pointer to slot of same name
7.66+ (name slot-name) name bound to slot-name
7.67+ (name :pointer slot-name) name bound to pointer to slot-name"
7.68+ `(symbol-macrolet
7.69+ ,(loop for var in vars
7.70+ collect
7.71+ (if (listp var)
7.72+ (let ((p1 (first var)) (p2 (second var)) (p3 (third var)))
7.73+ (if (eq (sb-int:keywordicate p1) :*)
7.74+ `(,p2 (addr (slot ,struct ',p2)))
7.75+ (if (eq (sb-int:keywordicate p2) :*)
7.76+ `(,p1 (addr (slot ,struct ',p3)))
7.77+ `(,p1 (slot ,struct ',p2)))))
7.78+ `(,var (slot ,struct ',var))))
7.79+ ,@body))
7.80+
7.81 (defun num-cpus ()
7.82 "Return the number of CPU threads online."
7.83 (alien-funcall (extern-alien "sysconf" (function int int)) sb-unix:sc-nprocessors-onln))
8.1--- a/lisp/std/pkg.lisp Wed Sep 18 21:48:06 2024 -0400
8.2+++ b/lisp/std/pkg.lisp Thu Sep 19 23:23:02 2024 -0400
8.3@@ -155,6 +155,8 @@
8.4 :setfa
8.5 :copy-c-string
8.6 :clone-strings
8.7+ :octets-to-alien-array
8.8+ :with-alien-slots
8.9 :clone-octets-to-alien
8.10 :octets-to-alien
8.11 :clone-octets-from-alien
