# HG changeset patch # User Richard Westhaver # Date 1726802582 14400 # Node ID 804b5ee20a466803c0eecf2903243e587f539e26 # Parent 937a6f35404771168e61a2ad38d213689cc6c945 zstd completed (besides zdict), working on readline diff -r 937a6f354047 -r 804b5ee20a46 lisp/ffi/readline/pkg.lisp --- a/lisp/ffi/readline/pkg.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/ffi/readline/pkg.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -2,6 +2,8 @@ ;;; Commentary: +;; https://github.com/vindarel/cl-readline + ;;; Code: (defpackage :readline (:use :cl :sb-alien :std/alien) @@ -10,61 +12,3 @@ (in-package :readline) (define-alien-loader "readline" t "/usr/lib/") - -(macrolet ((def-rl-var (name var type) - `(define-alien-variable (,name ,var) ,type))) - (def-rl-var "rl_line_buffer" *line-buffer* c-string) - (def-rl-var "rl_point" *point* int) - (def-rl-var "rl_end" *end* int) - (def-rl-var "rl_mark" *mark* int) - (def-rl-var "rl_done" *point* boolean) - (def-rl-var "rl_num_chars_to_read" *num-chars-to-read* int) - (def-rl-var "rl_pending_input" *pending-input* int) - (def-rl-var "rl_dispatching" *point* boolean) - (def-rl-var "rl_erase_empty_line" *point* boolean) - (def-rl-var "rl_prompt" *prompt* c-string) - (def-rl-var "rl_display_prompt" *display-prompt* c-string) - (def-rl-var "rl_already_prompted" *already-prompted* boolean) - (def-rl-var "rl_library_version" *library-version* c-string) - ;; (def-rl-var "rl_readline_version" *readline-version* version) - (def-rl-var "rl_gnu_readline_p" *gnu-readline-p* boolean) - (def-rl-var "rl_terminal_name" *terminal-name* c-string) - (def-rl-var "rl_readline_name" *readline-name* c-string) - (def-rl-var "rl_instream" *instream* (* t)) - (def-rl-var "rl_outstream" *outstream* (* t)) - (def-rl-var "rl_prefer_env_winsize" *prefer-env-winsize* boolean) - (def-rl-var "rl_last_func" *last-func* (* t)) - (def-rl-var "rl_startup_hook" *startup-hook* (* t)) - (def-rl-var "rl_pre_input_hook" *pre-input-hook* (* t)) - (def-rl-var "rl_event_hook" *event-hook* (* t)) - (def-rl-var "rl_getc_function" *getc-function* (* t)) - (def-rl-var "rl_signal_event_hook" *signal-event-hook* (* t)) - (def-rl-var "rl_input-available_hook" *input-available-hook* (* t)) - (def-rl-var "rl_redisplay_function" *redisplay-function* (* t)) - (def-rl-var "rl_prep_term_function" *prep-term-function* (* t)) - (def-rl-var "rl_deprep_term_function" *deprep-term-function* (* t)) - (def-rl-var "rl_executing_keymap" *executing-keymap* (* t)) - (def-rl-var "rl_binding_keymap" *binding-keymap* (* t)) - (def-rl-var "rl_executing_macro" *executing-macro* c-string) - (def-rl-var "rl_executing_key" *executing-key* char) - (def-rl-var "rl_executing_keyseq" *executing-keyseq* c-string) - (def-rl-var "rl_key_sequence_length" *key-sequence-length* int) - ;; (def-rl-var "rl_readline_state" *readline-state* int) - (def-rl-var "rl_explicit_arg" *explicit-arg* boolean) - (def-rl-var "rl_numeric_arg" *numeric-arg* int) - ;; (def-rl-var "rl_editing_mode" *editing-mode* int) - (def-rl-var "rl_catch_sigwinch" *catch-sigwinch* boolean) - (def-rl-var "rl_change_environment" *change-environment* boolean) - (def-rl-var "rl_attempted_completion_function" *attempted-completion-function* (* t)) - (def-rl-var "rl_completion_display_matches_hook" *completion-display-matches-hook* (* t)) - (def-rl-var "rl_basic_word_break_characters" *basic-word-break-characters* c-string) - (def-rl-var "rl_completer_word_break_character" *completer-word-break-characters* c-string) - (def-rl-var "rl_completion_query_items" *completer-query-items* int) - (def-rl-var "rl_completion_append_character" *completion-append-character* char) - (def-rl-var "rl_ignore_completion_duplicates" *ignore-completion-duplicates* boolean) - (def-rl-var "rl_attempted_completion_over" *attempted-completion-over* boolean) - (def-rl-var "rl_sort_completion_matches" *sort-completion-matches* boolean) - ;; (def-rl-var "rl_completion_type" *completion-type* completion-type) - (def-rl-var "rl_inhibit_completion" *inhibit-completion* boolean) - (def-rl-var "history_base" *history-base* int) - (def-rl-var "history_length" *history-length* int)) diff -r 937a6f354047 -r 804b5ee20a46 lisp/ffi/readline/readline.lisp --- a/lisp/ffi/readline/readline.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/ffi/readline/readline.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -1,7 +1,242 @@ ;;; readline/readline.lisp --- Readline Alien Routines -;; also consider https://github.com/antirez/linenoise +;; This implementation is based on Vindarel's cl-readline: https://github.com/vindarel/cl-readline ;;; Code: (in-package :readline) +(define-alien-enum (rl-completion-type int :test eq) + :standard-completion 9 + :display-and-perform 33 + :insert-all 42 + :list-all 63 + :not-list-cmn-prefix 64) + +(define-alien-type rl-history-entry (struct rl-history-entry + (line (* t)) + (time (* t)) + (data (* t)))) +(macrolet ((def-rl-var (name var type) + `(define-alien-variable (,name ,var) ,type))) + (def-rl-var "rl_line_buffer" *line-buffer* c-string) + (def-rl-var "rl_point" *point* int) + (def-rl-var "rl_end" *end* int) + (def-rl-var "rl_mark" *mark* int) + (def-rl-var "rl_done" *point* boolean) + (def-rl-var "rl_num_chars_to_read" *num-chars-to-read* int) + (def-rl-var "rl_pending_input" *pending-input* int) + (def-rl-var "rl_dispatching" *point* boolean) + (def-rl-var "rl_erase_empty_line" *erase-empty-line* boolean) + (def-rl-var "rl_prompt" *prompt* c-string) + (def-rl-var "rl_display_prompt" *display-prompt* c-string) + (def-rl-var "rl_already_prompted" *already-prompted* boolean) + (def-rl-var "rl_library_version" *library-version* c-string) + (def-rl-var "rl_readline_version" *readline-version* int) + (def-rl-var "rl_gnu_readline_p" *gnu-readline-p* boolean) + (def-rl-var "rl_terminal_name" *terminal-name* c-string) + (def-rl-var "rl_readline_name" *readline-name* c-string) + (def-rl-var "rl_instream" *instream* (* t)) + (def-rl-var "rl_outstream" *outstream* (* t)) + (def-rl-var "rl_prefer_env_winsize" *prefer-env-winsize* boolean) + (def-rl-var "rl_last_func" *last-func* (* t)) + (def-rl-var "rl_startup_hook" *startup-hook* (* t)) + (def-rl-var "rl_pre_input_hook" *pre-input-hook* (* t)) + (def-rl-var "rl_event_hook" *event-hook* (* t)) + (def-rl-var "rl_getc_function" *getc-function* (* t)) + (def-rl-var "rl_signal_event_hook" *signal-event-hook* (* t)) + (def-rl-var "rl_input-available_hook" *input-available-hook* (* t)) + (def-rl-var "rl_redisplay_function" *redisplay-function* (* t)) + (def-rl-var "rl_prep_term_function" *prep-term-function* (* t)) + (def-rl-var "rl_deprep_term_function" *deprep-term-function* (* t)) + (def-rl-var "rl_executing_keymap" *executing-keymap* (* t)) + (def-rl-var "rl_binding_keymap" *binding-keymap* (* t)) + (def-rl-var "rl_executing_macro" *executing-macro* c-string) + (def-rl-var "rl_executing_key" *executing-key* char) + (def-rl-var "rl_executing_keyseq" *executing-keyseq* c-string) + (def-rl-var "rl_key_sequence_length" *key-sequence-length* int) + (def-rl-var "rl_readline_state" *readline-state* int) + (def-rl-var "rl_explicit_arg" *explicit-arg* boolean) + (def-rl-var "rl_numeric_arg" *numeric-arg* int) + (def-rl-var "rl_editing_mode" *editing-mode* int) + (def-rl-var "rl_catch_sigwinch" *catch-sigwinch* boolean) + (def-rl-var "rl_change_environment" *change-environment* boolean) + (def-rl-var "rl_attempted_completion_function" *attempted-completion-function* (* t)) + (def-rl-var "rl_completion_display_matches_hook" *completion-display-matches-hook* (* t)) + (def-rl-var "rl_basic_word_break_characters" *basic-word-break-characters* c-string) + (def-rl-var "rl_completer_word_break_character" *completer-word-break-characters* c-string) + (def-rl-var "rl_completion_query_items" *completer-query-items* int) + (def-rl-var "rl_completion_append_character" *completion-append-character* char) + (def-rl-var "rl_ignore_completion_duplicates" *ignore-completion-duplicates* boolean) + (def-rl-var "rl_attempted_completion_over" *attempted-completion-over* boolean) + (def-rl-var "rl_sort_completion_matches" *sort-completion-matches* boolean) + (def-rl-var "rl_completion_type" *completion-type* rl-completion-type) + (def-rl-var "rl_inhibit_completion" *inhibit-completion* boolean) + (def-rl-var "history_base" *history-base* int) + (def-rl-var "history_length" *history-length* int)) + +(defvar *states* + '(:initializing ; 0x0000001 initializing + :initialized ; 0x0000002 initialization done + :termprepped ; 0x0000004 terminal is prepped + :readcmd ; 0x0000008 reading a command key + :metanext ; 0x0000010 reading input after ESC + :dispatching ; 0x0000020 dispatching to a command + :moreinput ; 0x0000040 reading more input in a command function + :isearch ; 0x0000080 doing incremental search + :nsearch ; 0x0000100 doing non-incremental search + :search ; 0x0000200 doing a history search + :numericarg ; 0x0000400 reading numeric argument + :macroinput ; 0x0000800 getting input from a macro + :macrodef ; 0x0001000 defining keyboard macro + :overwrite ; 0x0002000 overwrite mode + :completing ; 0x0004000 doing completion + :sighandler ; 0x0008000 in readline sighandler + :undoing ; 0x0010000 doing an undo + :inputpending ; 0x0020000 rl_execute_next called + :ttycsaved ; 0x0040000 tty special chars saved + :callback ; 0x0080000 using the callback interface + :vimotion ; 0x0100000 reading vi motion arg + :multikey ; 0x0200000 reading multiple-key command + :vicmdonce ; 0x0400000 entered vi command mode at least once + :redisplaying ; 0x0800000 updating terminal display + :done) ; 0x1000000 done; accepted line + "Possible state values for `+readline-state+'.") + +(defvar +c-buffer-size+ 256 + "How many bytes to allocate per Lisp string when converting list of +Lisp strings into array of C strings.") + +(defun decode-version (version) + "Transform VERSION into two values representing major and minor numbers of +Readline library version." + (values (ldb (byte 8 8) version) + (ldb (byte 8 0) version))) + +;; (defun decode-state (state) +;; "Transform Readline state STATE into list of keywords. See `+states+' for +;; list of components that can appear in result list." +;; (mapcan (lambda (index keyword) +;; (when (logbitp index state) +;; (list keyword))) +;; (iota (length +states+)) +;; +states+)) + +(defmacro produce-callback (function return-type &optional func-arg-list) + "Return pointer to callback that calls FUNCTION. RETURN-TYPE specifies +return type of the function and FUNC-ARG-LIST is list of argument types (it +can be ommited if FUNCTION doesn't take any arguments)." + (let ((gensymed-list (mapcar (lambda (x) (list (gensym) x)) + func-arg-list))) + (std:with-gensyms (temp) + `(when ,function + (progn + (define-alien-callable ,temp ,return-type ,gensymed-list + (funcall ,function ,@(mapcar #'car gensymed-list))) + (alien-callable-function ',temp)))))) + +(defun produce-callback* (function return-type &optional func-arg-list) + "Variant of PRODUCE-CALLBACK that should hopefully be more portable. +This avoids using a GENSYM as the name of a callback, and is also funcallable." + (let ((gensymed-list (mapcar (lambda (x) (list (gensym) x)) + func-arg-list))) + (std:with-gensyms (temp) + (when function + (progn + (eval `(define-alien-callable ,temp ,return-type ,gensymed-list + (funcall ,function ,@(mapcar #'car gensymed-list)))) + (alien-callable-function temp)))))) + +;;; cl-readline +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun recent-history-line-satisfies-p (predicate) + "Check if the most recent history line satisfies given predicate +PREDICATE. Return T if there is no history saved." + (if (zerop *history-length*) + t + (with-alien ((s rl-history-entry)) + (funcall predicate + ;; TODO 2024-09-19: does SBCL know how to conver this to a lisp string automatically? + (with-alien-slots + (line) + ;; (alien-funcall "history_get" + ;; :int + ;; (1- (+ *history-base* + ;; *history-length*))) + s + line))))) + +(define-alien-routine "readline" (* t) (prompt c-string)) +(define-alien-routine "add_history" void (line c-string)) + +(defun rl (&key + prompt + already-prompted + num-chars + erase-empty-line + add-history + novelty-check) + "Get a line from user with editing. PROMPT, if supplied, is printed before +reading of input. Non-NIL value of ALREADY-PROMPTED will tell Readline that +the application has printed prompt already. However, PROMPT must be supplied +in this case too, so redisplay functions can update the display properly. If +NUM-CHARS argument is a positive number, Readline will return after +accepting that many characters. If ERASE-EMPTY-LINE is not NIL, `readline' +will completely erase the current line, including any prompt, any time a +newline is typed as the only character on an otherwise-empty line. The +cursor is moved to the beginning of the newly-blank line. Supplying +ADD-HISTORY tells Readline that user's input should be added to +history. However, blank lines don't get into history anyway. NOVELTY-CHECK, +if given, must be a predicate that takes two strings: the actual line and +the most recent history line. Only when the predicate evaluates to non-NIL +value new line will be added to the history. Return value on success is the +actual string and NIL on failure." + (setf *already-prompted* already-prompted + *num-chars-to-read* (or num-chars 0) + *erase-empty-line* erase-empty-line) + (let* ((prompt (if prompt (string prompt) "")) + (ptr (readline prompt))) + (unless (null ptr) + (unwind-protect + (let ((str ptr)) + (when (and add-history + (not (sequence:emptyp str)) + (or (not novelty-check) + (recent-history-line-satisfies-p + (std:curry novelty-check str)))) + (add-history str)) + str) + (free-alien ptr))))) + +;; (defun ensure-initialization () +;; "Make sure that Readline is initialized. If it's not initialized yet, +;; initialize it." +;; (unless (find :initialized *readline-state*) +;; (initialize))) + +;; (defmacro with-possible-redirection (filename append &body body) +;; "If FILENAME is not NIL, try to create C file named FILENAME, +;; temporarily reassign `*outstream*' to pointer to this file, perform BODY, +;; then close the file and assign `*outstream*' the old value. If APPEND is not +;; NIL, output will be appended to the file. Returns NIL on success and T on +;; failure." +;; (std:with-gensyms (temp-outstream file-pointer body-fnc) +;; `(flet ((,body-fnc () +;; ,@body)) +;; (if ,filename +;; (let ((,temp-outstream *outstream*) +;; (,file-pointer (foreign-funcall "fopen" +;; :string ,filename +;; :string (if ,append "a" "w") +;; :pointer))) +;; (if (null-alien ,file-pointer) +;; t +;; (unwind-protect +;; (progn +;; (setf *outstream* ,file-pointer) +;; (,body-fnc)) +;; (foreign-funcall "fclose" +;; :pointer ,file-pointer +;; :boolean) +;; (setf *outstream* ,temp-outstream)))) +;; (,body-fnc))))) diff -r 937a6f354047 -r 804b5ee20a46 lisp/ffi/zstd/constants.lisp --- a/lisp/ffi/zstd/constants.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/ffi/zstd/constants.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -21,4 +21,9 @@ ((* t) dst "void*" "dst") (size-t size "size_t" "size") (size-t pos "size-t" "pos")) + nil t) + (:structure zdict-params ("ZDICT_params_t" + (int compression-level "int" "compressionLevel") + (unsigned notification-level "unsigned" "notificationLevel") + (unsigned dict-id "unsigned" "dictID")) nil t)) diff -r 937a6f354047 -r 804b5ee20a46 lisp/ffi/zstd/dict.lisp --- a/lisp/ffi/zstd/dict.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/ffi/zstd/dict.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -4,6 +4,11 @@ ;;; Commentary: +;; The CDict can be created once and shared across multiple threads since it's +;; read-only. + +;; Unclear if DDict is also read-only. + ;; From zdict.h: #| * Zstd dictionary builder @@ -261,7 +266,7 @@ (define-alien-routine "ZSTD_freeDDict" size-t (ddict (* zstd-ddict))) -(define-alien-routine "ZSTD_compress_usingDDict" size-t +(define-alien-routine "ZSTD_decompress_usingDDict" size-t (dctx (* zstd-dctx)) (dst (* t)) (dst-capacity size-t) @@ -287,13 +292,26 @@ (define-alien-routine "ZSTD_estimatedDictSize" size-t (dict-size size-t) (dict-load-method zstd-dict-load-method)) (defmacro with-zstd-cdict ((cv &key buffer size (level (zstd-defaultclevel))) &body body) - (let ((size (or size (length buffer)))) - `(with-alien ((,cv (* zstd-cdict) (zstd-createcdict (cast (octets-to-alien ,buffer) (* t)) ,size ,level))) - (unwind-protect (progn ,@body) - (zstd-freecdict ,cv))))) + `(with-alien ((,cv (* zstd-cdict) (zstd-createcdict (cast (octets-to-alien ,buffer) (* t)) + (or ,size (length ,buffer)) + ,level))) + (unwind-protect (progn ,@body) + (zstd-freecdict ,cv)))) (defmacro with-zstd-ddict ((dv &key buffer size) &body body) - (let ((size (or size (length buffer)))) - `(with-alien ((,dv (* zstd-ddict) (zstd-createddict (cast (octets-to-alien ,buffer) (* t)) ,size))) - (unwind-protect (progn ,@body) - (zstd-freeddict ,dv))))) + `(with-alien ((,dv (* zstd-ddict) + (zstd-createddict (cast (octets-to-alien ,buffer) (* t)) (or ,size (length ,buffer))))) + (unwind-protect (progn ,@body) + (zstd-freeddict ,dv)))) + +;;; zdict.h +(define-alien-type zstd-cover-params + (struct zdict-cover-params + (k unsigned) + (d unsigned) + (steps unsigned) + (nb-threads unsigned) + (split-point double) + (shrink-dict unsigned) + (shrink-dict-max-regression unsigned) + (zparams zdict-params))) diff -r 937a6f354047 -r 804b5ee20a46 lisp/ffi/zstd/tests.lisp --- a/lisp/ffi/zstd/tests.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/ffi/zstd/tests.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -96,13 +96,29 @@ (zerop (zstd-iserror (zstd::zstd-decompress-usingdict - ds + ds (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out) (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in) dict (length test)))))))))) (deftest bulk-dictionary () - (with-zstd-ddict (dd :buffer #(1 2 3)) - (is (typep dd '(alien (* (struct zstd::zstd-ddict-s)))))) - (with-zstd-cdict (cd :buffer #(4 5 6)) - (is (typep cd '(alien (* (struct zstd::zstd-cdict-s))))))) + (let ((test #(1 2 3 4))) + (with-alien ((dict (* t)) + (dst (array (unsigned 8) 100))) + (with-zstd-buffers (in out :src (octets-to-alien test) :dst (cast dst (* t)) :dst-size 100) + (with-zstd-streams (cs ds) + (with-zstd-cdict (cd :buffer test :size (length test)) + (is (typep cd '(alien (* (struct zstd::zstd-cdict-s))))) + (is (zerop + (zstd-iserror + (zstd::zstd-compress-usingcdict cs (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out) + (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in) + cd))))) + (with-zstd-ddict (dd :buffer test :size (length test)) + (is (typep dd '(alien (* (struct zstd::zstd-ddict-s))))) + (is (zerop + (zstd-iserror + (zstd::zstd-decompress-usingddict + ds (zstd::zstd-outbuffer-dst out) (zstd::zstd-outbuffer-size out) + (zstd::zstd-inbuffer-src in) (zstd::zstd-inbuffer-size in) dd)))))))))) + diff -r 937a6f354047 -r 804b5ee20a46 lisp/lib/io/flate.lisp --- a/lisp/lib/io/flate.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/lib/io/flate.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -14,7 +14,7 @@ ;; The compression backends are themselves hand-coded in Common Lisp, making ;; them excellent reference material. However, we don't have much use for the -;; compression backend offered. +;; compression backends offered. ;; We intend to almost exclusively support Zstd compression and decompression ;; using our ZSTD FFI Lisp system, so we'll make a new library - FLATE - which diff -r 937a6f354047 -r 804b5ee20a46 lisp/std/alien.lisp --- a/lisp/std/alien.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/std/alien.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -99,21 +99,26 @@ (push c-string reversed-result) (return (nreverse reversed-result))))))) -(defun clone-octets-to-alien (lispa aliena) - (declare (optimize (speed 3))) +(defun clone-octets-to-alien (lispa alien) + (declare (optimize (speed 3)) + (simple-vector lispa)) + ;; (setf aliena (cast aliena (array (unsigned 8)))) (loop for i from 0 below (length lispa) - do (setf (deref aliena i) + do (setf (deref alien i) (aref lispa i))) - aliena) + alien) -(defmacro octets-to-alien (lispa) - (with-gensyms (a) - `(with-alien ((,a (array (unsigned 8) ,(length lispa)))) - (clone-octets-to-alien ,lispa ,a)))) +(defun octets-to-alien (lispa) + (let ((a (make-alien (unsigned 8) (length lispa)))) + (clone-octets-to-alien lispa a))) + +;; TODO 2024-09-19: maybe want to return values, second being the length? +(defun octets-to-alien-array (lispa) + (cast (octets-to-alien lispa) (array (unsigned 8)))) (defun clone-octets-from-alien (aliena lispa &optional len) (declare (optimize (speed 3)) - (array lispa)) + (simple-vector lispa)) (unless len (setf len (length lispa))) (loop for i from 0 below len do (setf (aref lispa i) @@ -133,7 +138,6 @@ (defun bool-to-foreign-int (val) (if val 1 0)) - (define-condition invalid-enum-variant (simple-error) ()) (define-condition invalid-enum-value (simple-error) ()) @@ -147,7 +151,6 @@ :format-control "~A is not a value associated with a variant of enum ~A" :format-arguments (list var enum))) - (defmacro define-alien-enum ((name type &key (test 'eql) (default :error)) &rest forms) "Define a pseudo-enum type, used to work-around difficulties working with SB-ALIEN, groveller, typedef enums, etc. @@ -184,6 +187,28 @@ `((when (eql found :error) (invalid-enum-value ,val ',name)))) (values ,val found))))))) +;; from CFFI +(defmacro with-alien-slots (vars struct &body body) + "Create local symbol macros for each var in VARS to reference +foreign slots in STRUCT. Similar to WITH-SLOTS. +Each var can be of the form: + name name bound to slot of same name + (* name) name bound to pointer to slot of same name + (name slot-name) name bound to slot-name + (name :pointer slot-name) name bound to pointer to slot-name" + `(symbol-macrolet + ,(loop for var in vars + collect + (if (listp var) + (let ((p1 (first var)) (p2 (second var)) (p3 (third var))) + (if (eq (sb-int:keywordicate p1) :*) + `(,p2 (addr (slot ,struct ',p2))) + (if (eq (sb-int:keywordicate p2) :*) + `(,p1 (addr (slot ,struct ',p3))) + `(,p1 (slot ,struct ',p2))))) + `(,var (slot ,struct ',var)))) + ,@body)) + (defun num-cpus () "Return the number of CPU threads online." (alien-funcall (extern-alien "sysconf" (function int int)) sb-unix:sc-nprocessors-onln)) diff -r 937a6f354047 -r 804b5ee20a46 lisp/std/pkg.lisp --- a/lisp/std/pkg.lisp Wed Sep 18 21:48:06 2024 -0400 +++ b/lisp/std/pkg.lisp Thu Sep 19 23:23:02 2024 -0400 @@ -155,6 +155,8 @@ :setfa :copy-c-string :clone-strings + :octets-to-alien-array + :with-alien-slots :clone-octets-to-alien :octets-to-alien :clone-octets-from-alien