From 3bf465263c3407a4ad48e2efe9cfe1ae3fd37941 Mon Sep 17 00:00:00 2001
From: Mikael Djurfeldt <djurfeldt@nada.kth.se>
Date: Sun, 20 Apr 2003 17:33:08 +0000
Subject: [PATCH] * goops.scm (compute-getters-n-setters): Allow for primitive
 procedure thunks.  (Thanks to Neil W. Van Dyke.)

---
 NEWS          |  7 +++++++
 oop/ChangeLog |  5 +++++
 oop/goops.scm | 17 ++++++++++-------
 3 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/NEWS b/NEWS
index 719f1873a..10228e383 100644
--- a/NEWS
+++ b/NEWS
@@ -56,6 +56,13 @@ got confused if handed method code created in a null environment
 (environment = empty list).  It now stands every environment
 imaginable (think about it!).
 
+** GOOPS init-thunks can now be primitive procedures
+
+Previously, attempts to provide something else than a closure as value
+for the #:init-thunk slot option would yield a segmentation fault.
+Now, it's possible to supply a primitive procedure as init-thunk.
+Non-allowed values result in an error.
+
 ** Garbage collection frequency improved for large malloc heaps
 
 The decision when to run the GC is now done in a way that avoids GCs
diff --git a/oop/ChangeLog b/oop/ChangeLog
index 07b756642..455bf607a 100644
--- a/oop/ChangeLog
+++ b/oop/ChangeLog
@@ -1,3 +1,8 @@
+2003-04-20  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* goops.scm (compute-getters-n-setters): Allow for primitive
+	procedure thunks.  (Thanks to Neil W. Van Dyke.)
+
 2003-04-19  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 
 	* goops/dispatch.scm (cache-hashval): Corrected termination
diff --git a/oop/goops.scm b/oop/goops.scm
index 4d02eddc9..acd24984c 100644
--- a/oop/goops.scm
+++ b/oop/goops.scm
@@ -508,7 +508,7 @@
 (define method
   (letrec ((specializers
 	    (lambda (ls)
-	      (cond ((null? ls) '('()))
+	      (cond ((null? ls) (list (list 'quote '())))
 		    ((pair? ls) (cons (if (pair? (car ls))
 					  (cadar ls)
 					  '<top>)
@@ -1042,17 +1042,20 @@
 (define standard-set (standard-accessor-method make-set standard-set-methods))
 
 ;;; compute-getters-n-setters
-;;; 
+;;;
+(define (make-thunk thunk)
+  (lambda () (thunk)))
+
 (define (compute-getters-n-setters class slots env)
 
   (define (compute-slot-init-function name s)
     (or (let ((thunk (slot-definition-init-thunk s)))
 	  (and thunk
-	       (if (not (and (closure? thunk)
-			     (thunk? thunk)))
-		   (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
-				name class thunk))
-	       thunk))
+	       (cond ((not (thunk? thunk))
+		      (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+				   name class thunk))
+		     ((closure? thunk) thunk)
+		     (else (make-thunk thunk)))))
 	(let ((init (slot-definition-init-value s)))
 	  (and (not (unbound? init))
 	       (lambda () init)))))