I wanted to share some code and get some thoughts, and say a bit thank
you to the lisp community...

#|
(defsystem "local"
:description "A macro for using bit-fields as bit-vectors."
:version "0.3.1"
:description "bitfield macro"
:components ((:file "bitfields"))
:author "steve g"
:licence "GPL")

I do not know how to use defsystem or asdf. I use makefiles.

Description: A macro for using bit-fields as bit-vectors.
Date: 2021-07-24 09:51:15-05:00
Author: Steve
Version: 0.3.1
License: GPL
Platform: GNU/Linux/Fedora
localplatform: Linux loft 5.12.14-s1-loft
TestedOnSytems: (sbcl franz lispworks)
TestedSystemInfo: ("franz allegro-express 32bit ^1"
"LispWorks(R) Personal Edition ^2"
"Steele Bank Common Lisp non-unicode mode")
---------

This macro is fun to play with. be careful it is being used but not really tested fully. Always check the macro expansion. This macro is so indispensable to me I thought I would share it; like c.l.l used to do. I do not know how to use github or google drive. I just have always used USEnet or ftp. I have no email address because my ISP thinks I am a ter(ro)rist and I simply cannot bring myself to use MySQL. I really need a nice small database - like SAP sybase for linux (hint hint ).

hence the use of USEnet.

I would love to hear comments about this, I wrote it like ~20 years ago, and
it still works for me. I don't remember it all; someone once asked me what the longest loop macro I wrote was; well here it is. I would like to add
conditions to the macro; I just don't know how to access the macro
environment. I would love to know the calling function for better condition handling as these bit vectors get all over the place. I neglected to use a structure or object for simplicity (obviously) and for efficiency I recommend using the type checking option.

* Warning: Not all common lisp implementations can expand a loop macro of this
depth. clisp used to be the notable refusal. I am using SBCL and it can
handle loop macros from Satan himself. Thank you people of the sbcl; I can
program once again!

The macro looks difficult to me now; like I said I am a tad under the weather still. Believe it or not I wrote this in one sitting. I sure do miss those dayz.

What I am looking for is a macro that does basically the same thing but uses integers for field and masks, instead of bitvectors. It would be nice, I would write it myself now but I am still under the weather so to speak.

Well please enjoy and let me know if there is a bug, if you find this interesting, or if you have something similiar. I have seen something similiar on github; this vrsion seems to be somewhat efficient.

(defun-bitflags (line-flags
(:check-type t)
(:accessor nil)
(:conc-name line-)
(:initial-element 0)
(:reset-function reset-line-flags)
(:constructor create-line-flags)
(:predicate-suffix -p)
(:print-function print-line-flags)
(:default-mask (:set modified 1))
(:optimize (speed 3) (space 0)))
"Test define-bitflags"
(modified :initial-element 1)
insertion
(deletion :documentation "This is a bit-flag")
(killed :mask ((:set deletion t) (:toggle insertion))))
|#

(defmacro define-bitflags (name/options &rest bit-fields)
(flet ((make-fn-name (&rest names)
(intern (format nil "~{~@[~a~]~}" names)))
(extract-docstring (field)
(let ((string (cadr (member :documentation field))))
(when string (list string))))
(l-assq (item lst)
(declare (list lst))
"Return ASSOC <item> <lst>. Equality is defined by EQ."
(assoc item lst :test #'eq))
(l-memq (item lst)
(declare (list lst))
(member item lst :test #'eq))
(lst-length=1 (lst)
(declare (list lst))
"Return T or nil if length of the list <lst> is one."
(and (consp lst) (null (cdr lst)))))
(let (field-masks default-masks
print-function print-function-parameters (conc-name t)
constructor-name constructor-parameters type reset-function
type-check optimizations documentation max-field-size
(initial-element 0) (predicate-suffix '-p) (accessor-p t))

(when (stringp (car bit-fields))
;; Snarf the docstring
(setq documentation (list (pop bit-fields))))

(setq bit-fields
;; Ensure each of BIT-FIELDS is a list for easier parsing
(mapcar #'(lambda (field)
(if (consp field) field (list field)))
bit-fields))

(setq field-masks
;; Set to an alist of field names and their bit position in
;; the bit vector. This is used to build a suitable mask in
;; the setf expanders. Also create the type specifier for the
;; bit-vector since we're already traversing the list.
(let ((bit -1))
(prog1 (mapcar
#'(lambda (field)
(cons field (incf bit)))
;; While we're looping through the list of fields
;; check the validity of the keyword arguments.
(mapcar
#'(lambda (bit-field)
(let ((field (car bit-field))
(keys (cdr bit-field)))
(loop for key in keys by #'cddr
do (check-type key (member :documentation
:mask :initial-element)))
field))
bit-fields))
(setq type
`(simple-bit-vector ,(1+ bit))))))

;; Setup some defaults for when NAME/OPTIONS is an atom (which
;; is an indication that no options have been supplied).
(cond ((or (atom name/options)
(and (lst-length=1 name/options)
(setq name/options (car name/options))))
(setq conc-name
(make-fn-name name/options "-"))
(setq constructor-name
(make-fn-name 'make "-" name/options)))
(t
;; NAME/OPTIONS is a list, parse the default options
(dolist (option (cdr name/options))
(ecase (pop option)
(:CONC-NAME
(setq conc-name (car option)))
(:INITIAL-ELEMENT (setq initial-element (car option)))
(:ACCESSOR (setq accessor-p (pop option)))
(:CONSTRUCTOR
(setq constructor-name (pop option))
(setq constructor-parameters option))
(:PRINT-FUNCTION
(setq print-function (pop option))
(setq print-function-parameters (car option)))
(:RESET-FUNCTION (setq reset-function (pop option)))
(:PREDICATE-SUFFIX (setq predicate-suffix (car option)))
(:DEFAULT-MASK (setq default-masks option))
(:CHECK-TYPE (setq type-check (car option)))
(:OPTIMIZE (setq optimizations
(list `(optimize ,@ option))))))))
;; Fill in the needed defaults in case they were not supplied
(when (eq conc-name t)
(setq conc-name (make-fn-name (car name/options) "-")))
(when (null constructor-name)
(setq constructor-name
(make-fn-name 'make "-" (car name/options))))
(if print-function
;; Get length of the largest field name for print-function
(setq max-field-size
(+ (loop for field in field-masks
for field-name = (car field)
maximizing (length (symbol-name field-name)))
8)))

;; Now construct the forms
(loop for field in bit-fields
for counter upfrom 0
for field-name = (pop field)
for fn-name = (make-fn-name conc-name field-name)
for value-var = (make-symbol (format nil "BIT-~:@(~R~)" counter))
;; Accessors
when accessor-p
collect `(defun ,fn-name (flags)
,(if type-check
`(check-type flags ,type)
`(declare ,@ optimizations (type ,type flags)))
,@ (extract-docstring field)
(sbit flags ,counter))
into result
;; Predicates
collect `(defun
,(make-fn-name fn-name predicate-suffix) (flags)
,(if type-check
`(check-type flags ,type)
`(declare ,@ optimizations (type ,type flags)))
(plusp (sbit flags ,counter)))
into result
;; Setf expansions with masks ...
collect `(defsetf ,fn-name (flags) (,value-var)
`(progn ,,.
(let ((masks
;; replace `sublis' with `progn' to debug
(sublis field-masks
(remove-if
#'(lambda (mask)
(eq (cadr mask) field-name))
(append default-masks
(cadr (l-memq :mask field)))))))
(when masks
;; Masks: ((:SET 2 1) (:TOGGLE 1))
(loop for mask in masks
collect
(ecase (pop mask)
(:SET
``(setf (sbit (the ,',type
,flags) ,,(car mask))
,,(cond ((eq (cadr mask) t)
value-var)
(t (check-type (cadr mask) bit)
(cadr mask)))))
(:TOGGLE
``(setf (sbit (the ,',type
,flags) ,,(car mask))
(if (zerop (sbit (the ,',type
,flags) ,,(car mask)))
1 0)))))))
(setf (sbit (the ,',type ,flags) ,,counter)
,,value-var)))
into result
finally
(return
`(progn ,@ result
;; When the print-function was supplied create a
;; function that will pretty print the status of
;; a given bitvector - for easier debugging.
,@ (when print-function
`((defun ,print-function
,(if print-function-parameters
`(&optional (flags ,print-function-parameters)
(stream *standard-output*))
'(flags &optional (stream *standard-output*)))
(check-type flags ,type)
(fresh-line stream)
(write-string
,(concatenate 'string
";; Status of "
(string-downcase (symbol-name
(car name/options)))
":")
stream)
,@(mapcar
#'(lambda (field)
(let ((name (symbol-name (car field)))
(bit-position (cdr field)))
`(format
stream
,(concatenate 'string
"~%;; ~"
(princ-to-string max-field-size)
"<"
(string-downcase name)
":~;~[nil~;t ~]~>")
(sbit flags ,bit-position))))
field-masks))))
;; When the value of reset-function is non-nil
;; create a function that will set an existing
;; bit-vector to it's original state.
,@ (when reset-function
`((defun ,reset-function (flags)
,(if type-check
`(check-type flags ,type)
`(declare ,@ optimizations
(type ,type flags)))
,@ (mapcar
#'(lambda (field)
(let ((field-name (car field))
(value (or (cadr
(l-memq :initial-element
(cdr field)))
initial-element)))
`(setf (sbit (the ,type flags)
,(cdr (l-assq field-name field-masks)))
,value)))
bit-fields)
flags)))
;; Finally the constructor
(defun ,constructor-name
,(or constructor-parameters
`(&key ,@(mapcar
#'(lambda (field)
(list field
(or (cadr (member :initial-element
(assoc field bit-fields)))
initial-element)))
(mapcar #'car bit-fields))))
,. documentation
(the ,type
(make-array ,(1+ counter)
:element-type 'bit
:initial-contents (list ,@(mapcar #'car bit-fields))
)))))))))

#|

Just use macroexpand-1 on the define-bitflags form. The only thing
missing I can think of is the default value.


The following does not work,

(define-bitflags (this)
(bit 3))

It must be like the following, Just use slime-macroexpand-1, or somesuch.

(define-bitflags (cursor-flags)
visible
(invisible :initial-element 1 :mask ((:set visible 0))))



(PROGN
(DEFUN CURSOR-FLAGS-VISIBLE (FLAGS)
(DECLARE (TYPE (SIMPLE-BIT-VECTOR 2) FLAGS))
(SBIT FLAGS 0))
(DEFUN CURSOR-FLAGS-VISIBLE-P (FLAGS)
(DECLARE (TYPE (SIMPLE-BIT-VECTOR 2) FLAGS))
(PLUSP (SBIT FLAGS 0)))
(DEFSETF CURSOR-FLAGS-VISIBLE (FLAGS)
(#:BIT-ZERO)
`(PROGN (SETF (SBIT (THE ,'(SIMPLE-BIT-VECTOR 2) ,FLAGS) ,0) ,#:BIT-ZERO)))
(DEFUN CURSOR-FLAGS-INVISIBLE (FLAGS)
(DECLARE (TYPE (SIMPLE-BIT-VECTOR 2) FLAGS))
(SBIT FLAGS 1))
(DEFUN CURSOR-FLAGS-INVISIBLE-P (FLAGS)
(DECLARE (TYPE (SIMPLE-BIT-VECTOR 2) FLAGS))
(PLUSP (SBIT FLAGS 1)))
(DEFSETF CURSOR-FLAGS-INVISIBLE (FLAGS)
(#:BIT-ONE)
`(PROGN
,`(SETF (SBIT (THE ,'(SIMPLE-BIT-VECTOR 2) ,FLAGS) ,0) ,0)
(SETF (SBIT (THE ,'(SIMPLE-BIT-VECTOR 2) ,FLAGS) ,1) ,#:BIT-ONE)))
(DEFUN MAKE-CURSOR-FLAGS (&KEY (VISIBLE 0) (INVISIBLE 1))
(THE (SIMPLE-BIT-VECTOR 2)
(MAKE-ARRAY 2 :ELEMENT-TYPE 'BIT :INITIAL-CONTENTS
(LIST VISIBLE INVISIBLE)))))


(DEFINE-BITFLAGS (status-flags
(:check-type t)
(:initial-element 0)
(:predicate-suffix -p)
(:reset-function reset-status-flags)
)
"Flags for current screen status. Used while screen is open and acticve."
(modified :documentation "Is the screen modified.")
(cursor-moved :documentation "Is the cursor in a new position.")
(cursor-visible :mask ((:set cursor-moved 1))
:documentation "Is the cursor visible. When changed the <cursor-moved> flag gets auto set.")
(scroll-region-set :documentation "Is the scroll region already set.")
(opened :documentation "Is the current screen opened")
(active :documentation "Is the current screen active or suspended. Used to check before running backgroung threads.")
(save-restriction :documentation "Is screen withing a restriction.")

(DEFINE-BITFLAGS (mode-flags
(:initial-element 0)
(:predicate-suffix -p)
(:check-type nil)
(:conc-name mode-)
(:reset-function reset-mode-flags)
(:constructor make-mode-flags))
"Mode flags for current screen."
altcharset
blink
(bold :mask ((:set dimmed 0)))
(dimmed :mask ((:set bold 0)))
insert
reverse
standout
underline)

yeah I'm getting there ...


------------

^1 Thank you; I like to know how the code runs on 32bits. Your
platform is so darn fast! Thank you.

^2 Thank you to the people of lispworks(r) for letting me
use your platform to test code. Your IDE rocks does, it do a tty?. I
really wanted to thank you on this one. thank you seriously - my
sanity ...

^3 I love you people from the sbcl!

|#

(debugging :documentation "Is the screen in debugging mode; not used."))

Content-Type: application/octet-stream
Content-ID: <84r1fnzsco.fsf@loft.i-did-not-set--mail-host-address--so-tickle-me>
Content-Transfer-Encoding: binary

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)

* steve <84sg03zscs.fsf@loft.i-did-not-set--mail-host-address--so-tickle-me> : Wrote on Sat, 24 Jul 2021 10:41:55 -0400:

[define-bitfields - not yet but will try to use it shortly]

What I am looking for is a macro that does basically the same thing
but uses integers for field and masks, instead of bitvectors. It would
be nice, I would write it myself now but I am still under the weather
so to speak.

Not quite the same thing but recently I came up with a very crude DEFSTRUCT-PACKED which operates on (array (unsigned-byte 8)).

I may have written something better before and forgotten about it but
what to do with a poor memory and being under the weather and all

The syntax is (defstruct-packed name options slot-defs)
options is empty - just to get emacs to indent it properly
slot-defs = (slot-name [ init-val [ type [ count ]]] )

all the slots are C- "integral" values int8 int16 int32 int64 and I
assume efficient functions exist to do IO

load32 (array offset)
store32 (uint32 array offset), etc.

and the accessors will just translate to those functions.

;; structures for the metadata

(defstruct packed-slot-rep
name type initial-element count type-size octet-count offset)

(defstruct packed-struct-rep name slot-table)

(defun parse-packed-slot-def-rep (slot-def)
(let* ((atomp (atom slot-def))
(slot-name (if atomp slot-def (car slot-def)))
(init (if atomp 0 (or (cadr slot-def) 0)))
(type (if atomp 'uint8 (or (caddr slot-def) 'uint8)))
(count (if atomp 1 (or (cadddr slot-def) 1)))
(type-size (ecase type
((uint8) 1)
((uint16) 2)
((uint32) 4)
((uint64) 8)))
(octet-count (* type-size count)))
(make-packed-slot-rep
:name slot-name :type type :initial-element init
:count count :type-size type-size
:octet-count octet-count)))

(defun parse-packed-struct-rep (name slot-defs)
(let* ((rep (make-packed-struct-rep :name name))
(slot-table (mapcar #'parse-packed-slot-def-rep slot-defs))
(offset 0))
(dolist (p slot-table)
(setf (packed-slot-rep-offset p) offset)
(incf offset (packed-slot-rep-octet-count p)))
(setf (packed-struct-rep-slot-table rep) slot-table)
(setf (get name 'struct-rep) rep)))

(defun make-array-for-packed-struct
(packed-struct-name &optional (rep (get packed-struct-name 'struct-rep)))
(let* ((length (reduce #'+ (packed-struct-rep-slot-table rep)
:key 'packed-slot-rep-octet-count))
(array (make-array length :element-type '(unsigned-byte 8))))
(init-array-for-packed-struct array rep)
array))

;; and the macro

(defmacro defstruct-packed (name options &rest slot-defs)
(declare (ignore options))
(let* ((rep (parse-packed-struct-rep name slot-defs))
(slot-table (packed-struct-rep-slot-table rep))
(constructor-name (intern (concatenate 'string "MAKE-"
(symbol-name name))))
(forms nil))
(push `(defun ,constructor-name () (make-array-for-packed-struct ',name))
forms)
(dolist (slot-rep slot-table)
(with-slots ((slot-name name) type-size offset count) slot-rep
(when (= count 1)
(let* ((accessor-name (intern (concatenate 'string (symbol-name name)
"-"
(symbol-name slot-name))))
(p (gensym "P"))
(w (gensym "W")))
(push `(defun ,accessor-name (p)
,(ecase type-size
(1 `(aref p ,offset))
(2 `(load16 p ,offset))
(4 `(load32 p ,offset))
(8 `(load64 p ,offset))))
forms)
(push
(ecase type-size
(1 `(defsetf ,accessor-name (,p) (,w)
`(setf (aref ,,p ,,offset) ,,w)))
(2 `(defsetf ,accessor-name (,p) (,w)
`(store16 ,,p ,,w ,,offset)))
(4 `(defsetf ,accessor-name (,p) (,w)
`(store32 ,,p ,,w ,,offset)))
(8 `(defsetf ,accessor-name (,p) (,w)
`(store64 ,,p ,,w ,,offset))))
forms)))))
`(progn ,@(nreverse forms))))


All very straightforward and crude but since I've lost the chops I can't
figure out how to put the setters into one single backquoted form with
the ecase evaluated INSIDE.

Like you said this sort of thing used to be a breeze a decade ago. In
any case the mind will be renewed in the world to come so programming
there shouldn't be a problem

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)