From 994eed863ee3cef4b90cbf9089723730d1ee0180 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Sun, 12 Jul 2026 17:35:08 -0700 Subject: [PATCH 1/2] Fixes/improvements to IFFI allocation --- src/iffi/alloc.lisp | 68 +++++++++++++++++++++++++++++++----------- src/iffi/packages.lisp | 1 + 2 files changed, 51 insertions(+), 18 deletions(-) diff --git a/src/iffi/alloc.lisp b/src/iffi/alloc.lisp index 0b1ffee..cc93723 100644 --- a/src/iffi/alloc.lisp +++ b/src/iffi/alloc.lisp @@ -52,16 +52,16 @@ ;;; INSTANCE ;;; (defun make-intricate-instance (name &rest args) - (let* ((record (find-intricate-record name)) - (ptr (intricate-alloc name))) + (let* ((record (find-intricate-record name))) (unless record (error "Record with name ~A not found" name)) - (if-let ((ctor (constructor-of record))) - (handler-case - (apply (constructor-of record) `(:pointer ,name) ptr args) - (serious-condition (condi) (intricate-free ptr) (error condi))) - (error "Constructor not found for record ~A" name)) - ptr)) + (let ((ptr (intricate-alloc name))) + (if-let ((ctor (constructor-of record))) + (handler-case + (apply (constructor-of record) `(:pointer ,name) ptr args) + (serious-condition (condi) (intricate-free ptr) (error condi))) + (error "Constructor not found for record ~A" name)) + ptr))) (define-compiler-macro make-intricate-instance (&whole whole name &rest args) @@ -73,15 +73,20 @@ ((not record) (warn "Record with name ~A not found" quoted-name)) ((not ctor) (warn "Constructor not found for record ~A" quoted-name)))) (if ctor - (with-gensyms (ptr condi) - `(let ((,ptr (intricate-alloc ',quoted-name))) - (handler-case - ;; FIXME: here we actually a break funcall protocol a bit - ;; because if during args evaluation condition is raised it is - ;; going to be consumed here with stack being unwound - (,ctor '(:pointer ,quoted-name) ,ptr ,@args) - (serious-condition (,condi) (intricate-free ,ptr) (error ,condi))) - ,ptr)) + (with-gensyms (ptr) + (let ((arg-bindings (mapcar (lambda (arg) + (if (and (consp arg) (not (eq (car arg) 'quote))) + (list :bind (gensym "ARG-") arg) + (list :nobind arg))) + args))) + ;; Evaluate the argument expressions first, to prevent a leak + ;; if one takes a nonlocal exit. + `(let (,@(mapcar #'cdr (remove-if-not (lambda (b) (eq (car b) :bind)) + arg-bindings)) + (,ptr (intricate-alloc ',quoted-name))) + (,ctor '(:pointer ,quoted-name) ,ptr + ,@(mapcar #'cadr arg-bindings)) + ,ptr))) whole))) @@ -120,4 +125,31 @@ `((with-intricate-instance ,(first declarations) ,@(expand-with-intricate-instances (rest declarations) body))) `(,@body)))) - (first (expand-with-intricate-instances declarations body)))) + `(progn ,@(expand-with-intricate-instances declarations body)))) + + +(defun initialize-intricate-instance (name ptr &rest args) + "Initializes an instance of type `name' at `ptr' by calling a constructor. +Use very carefully -- the allocation at `ptr' must be large enough to hold +an instance of type `name'." + (let* ((record (find-intricate-record name))) + (unless record + (error "Record with name ~A not found" name)) + (if-let ((ctor (constructor-of record))) + (handler-case + (apply (constructor-of record) `(:pointer ,name) ptr args) + (serious-condition (condi) (intricate-free ptr) (error condi))) + (error "Constructor not found for record ~A" name)) + ptr)) + +(define-compiler-macro initialize-intricate-instance (&whole whole name ptr &rest args) + (let* ((quoted-name (find-quoted name)) + (record (find-intricate-record quoted-name)) + (ctor (and record (constructor-of record)))) + (when quoted-name + (cond + ((not record) (warn "Record with name ~A not found" quoted-name)) + ((not ctor) (warn "Constructor not found for record ~A" quoted-name)))) + (if ctor + `(,ctor '(:pointer ,quoted-name) ,ptr ,@args) + whole))) diff --git a/src/iffi/packages.lisp b/src/iffi/packages.lisp index d5ab676..c8b4e4d 100644 --- a/src/iffi/packages.lisp +++ b/src/iffi/packages.lisp @@ -27,6 +27,7 @@ #:with-intricate-slots #:make-intricate-instance + #:initialize-intricate-instance #:destroy-intricate-instance #:with-intricate-instance #:with-intricate-instances From 089baa764eee0300e5a449eca4dd56332edfa225 Mon Sep 17 00:00:00 2001 From: "Scott L. Burson" Date: Thu, 13 Aug 2026 18:08:07 -0700 Subject: [PATCH 2/2] Untabify branch --- src/iffi/alloc.lisp | 34 +++++++++++++++++----------------- src/iffi/packages.lisp | 2 +- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/iffi/alloc.lisp b/src/iffi/alloc.lisp index cc93723..1b2a68d 100644 --- a/src/iffi/alloc.lisp +++ b/src/iffi/alloc.lisp @@ -57,10 +57,10 @@ (error "Record with name ~A not found" name)) (let ((ptr (intricate-alloc name))) (if-let ((ctor (constructor-of record))) - (handler-case + (handler-case (apply (constructor-of record) `(:pointer ,name) ptr args) (serious-condition (condi) (intricate-free ptr) (error condi))) - (error "Constructor not found for record ~A" name)) + (error "Constructor not found for record ~A" name)) ptr))) @@ -73,20 +73,20 @@ ((not record) (warn "Record with name ~A not found" quoted-name)) ((not ctor) (warn "Constructor not found for record ~A" quoted-name)))) (if ctor - (with-gensyms (ptr) - (let ((arg-bindings (mapcar (lambda (arg) - (if (and (consp arg) (not (eq (car arg) 'quote))) - (list :bind (gensym "ARG-") arg) - (list :nobind arg))) - args))) - ;; Evaluate the argument expressions first, to prevent a leak - ;; if one takes a nonlocal exit. - `(let (,@(mapcar #'cdr (remove-if-not (lambda (b) (eq (car b) :bind)) - arg-bindings)) - (,ptr (intricate-alloc ',quoted-name))) - (,ctor '(:pointer ,quoted-name) ,ptr - ,@(mapcar #'cadr arg-bindings)) - ,ptr))) + (with-gensyms (ptr) + (let ((arg-bindings (mapcar (lambda (arg) + (if (and (consp arg) (not (eq (car arg) 'quote))) + (list :bind (gensym "ARG-") arg) + (list :nobind arg))) + args))) + ;; Evaluate the argument expressions first, to prevent a leak + ;; if one takes a nonlocal exit. + `(let (,@(mapcar #'cdr (remove-if-not (lambda (b) (eq (car b) :bind)) + arg-bindings)) + (,ptr (intricate-alloc ',quoted-name))) + (,ctor '(:pointer ,quoted-name) ,ptr + ,@(mapcar #'cadr arg-bindings)) + ,ptr))) whole))) @@ -151,5 +151,5 @@ an instance of type `name'." ((not record) (warn "Record with name ~A not found" quoted-name)) ((not ctor) (warn "Constructor not found for record ~A" quoted-name)))) (if ctor - `(,ctor '(:pointer ,quoted-name) ,ptr ,@args) + `(,ctor '(:pointer ,quoted-name) ,ptr ,@args) whole))) diff --git a/src/iffi/packages.lisp b/src/iffi/packages.lisp index c8b4e4d..f3d79f7 100644 --- a/src/iffi/packages.lisp +++ b/src/iffi/packages.lisp @@ -27,7 +27,7 @@ #:with-intricate-slots #:make-intricate-instance - #:initialize-intricate-instance + #:initialize-intricate-instance #:destroy-intricate-instance #:with-intricate-instance #:with-intricate-instances