mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

FFI: Fix `set-pointer-finalizer!' to leave the type cell unchanged.

Browse source 
This is a followup to 690a0112e5 ("Remove
the "has finalizer?" bit from pointer objects.")

* libguile/foreign.c (scm_set_pointer_finalizer_x): Leave the type cell
  unchanged.  Before, `equal?' would break on pointers on which
  `set-pointer-finalizer!' had been called.

* test-suite/tests/foreign.test ("make-pointer")["equal? modulo
  finalizer (set-pointer-finalizer!)"]: New test.
This commit is contained in:
Ludovic Courtès 2012-01-23 23:51:33 +01:00
parent c64d07d822
commit 5765c5a82c
2 changed files with 7 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/foreign.c
View file

@ -319,8 +319,6 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
c_finalizer = SCM_POINTER_VALUE (finalizer); c_finalizer = SCM_POINTER_VALUE (finalizer);
SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer), GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
pointer_finalizer_trampoline, pointer_finalizer_trampoline,
c_finalizer, c_finalizer,

8
test-suite/tests/foreign.test
View file

@ -1,6 +1,6 @@
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
;;;; ;;;;
;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -71,6 +71,12 @@
(equal? (make-pointer 123) (equal? (make-pointer 123)
(make-pointer 123 finalizer)))) (make-pointer 123 finalizer))))
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
(let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
(ptr (make-pointer 123)))
(set-pointer-finalizer! ptr finalizer)
(equal? (make-pointer 123) ptr)))
(pass-if "not equal?" (pass-if "not equal?"
(not (equal? (make-pointer 123) (make-pointer 456))))) (not (equal? (make-pointer 123) (make-pointer 456)))))