From 6790df02ec69d3cdd3bc341426b9f5fc2c5552fe Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 13 Mar 1993 12:17:38 +0000
Subject: [PATCH] First cut at funcallable-structure support. 
 %funcallable-instance interpreter stubs.  Initialize
 STRUCTURE-CLASS-CONSTRUCTOR.  Changed ALTERNATE-METACLASS to be inherited by
 structures that include it.  Update arg syntax of REGISTER-LAYOUT and use
 :DEFSTRUCT-LAYOUT option so that we can incompatibly redefine forward
 referenced (but not defined) structures.  Fix structure redefinition warning
 formatting.

---
 code/defstruct.lisp | 211 ++++++++++++++++++++++++++++++--------------
 1 file changed, 145 insertions(+), 66 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 5fd20dced..a1a016508 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.39 1993/03/01 20:07:52 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.40 1993/03/13 12:17:38 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -22,7 +22,11 @@
 	  %compiler-defstruct %%compiler-defstruct
 	  %make-instance
 	  %instance-length %instance-ref %instance-set %instance-layout
-	  %set-instance-layout 
+	  %set-instance-layout
+	  %make-funcallable-instance %funcallable-instance-info
+	  %set-funcallable-instance-info
+	  funcallable-instance-function funcallable-structure
+	  funcallable-instance-p
 	  %raw-ref-single %raw-set-single
 	  %raw-ref-double %raw-set-double
 	  defstruct-description dd-name dd-default-constructor dd-copier
@@ -73,10 +77,28 @@
 (defun %set-instance-layout (instance new-value)
   (%set-instance-layout instance new-value))
 
+(defun funcallable-instance-p (x) (funcallable-instance-p x))
+
+(defun %funcallable-instance-info (fin i)
+  (%funcallable-instance-info fin i))
+
+(defun %set-funcallable-instance-info (fin i new-value)
+  (%set-funcallable-instance-info fin i new-value))
+
+(defun funcallable-instance-function (fin)
+  (%funcallable-instance-lexenv fin))
+
+(defun (setf funcallable-instance-function) (new-value fin)
+  (setf (%funcallable-instance-function fin)
+	(%closure-function new-value))
+  (setf (%funcallable-instance-lexenv fin) new-value))
+
 (defsetf %instance-ref %instance-set)
 (defsetf %raw-ref-single %raw-set-single)
 (defsetf %raw-ref-double %raw-set-double)
 (defsetf %instance-layout %set-instance-layout)
+(defsetf %funcallable-instance-info %set-funcallable-instance-info)
+
 
 ;;; This version of Defstruct is implemented using Defstruct, and is free of
 ;;; Maclisp compatability nonsense.  For bootstrapping, you're on your own.
@@ -130,10 +152,11 @@
   (length 0 :type index)
   ;;
   ;; General kind of implementation.
-  (type 'structure :type (member structure vector list))
+  (type 'structure :type (member structure vector list
+				 funcallable-structure))
   ;;
   ;; The next three slots are for :TYPE'd structures (which aren't classes,
-  ;; i.e. dd-type /= structure.)
+  ;; CLASS-STRUCTURE-P = NIL)
   ;;
   ;; Vector element type.
   (element-type 't)
@@ -144,8 +167,8 @@
   ;; Any INITIAL-OFFSET option on this direct type.
   (offset nil :type (or index null))
   ;;
-  ;; The next five slots are only meaningful in real default structures (i.e.
-  ;; dd-type = structure), since they are recognizably typed objects (classes.)
+  ;; The next four slots are only meaningful in real default structures (TYPE =
+  ;; STRUCTURE).
   ;;
   ;; The argument to the PRINT-FUNCTION option, or NIL if none.  If we see an
   ;; explicit (:PRINT-FUNCTION) option, then this is DEFAULT-STRUCTURE-PRINT.
@@ -160,7 +183,8 @@
   (raw-index nil :type (or index null))
   (raw-length 0 :type index)
   ;;
-  ;; Value of the :PURE option, or :UNSPECIFIED.
+  ;; Value of the :PURE option, or :UNSPECIFIED.  Only meaningful if
+  ;; CLASS-STRUCTURE-P = T.
   (pure :unspecified :type (member t nil :unspecified)))
 
 ;;; DEFSTRUCT-SLOT-DESCRIPTION  holds compile-time information about structure
@@ -191,12 +215,24 @@
   (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
 
 
+;;; CLASS-STRUCTURE-P  --  Internal
+;;;
+;;;    Return true if Defstruct is a structure with a class.
+;;;
+(defun class-structure-p (defstruct)
+  (member (dd-type defstruct) '(structure funcallable-structure)))
+
+
+;;; COMPILER-LAYOUT-OR-LOSE  --  Internal
+;;;
+;;;    Return the compiler layout for Name.  Must be a structure-like class.
+;;;
 (defun compiler-layout-or-lose (name)
   (let ((res (info type compiler-layout name)))
     (cond ((not res)
 	   (error "Class not yet defined or was undefined: ~S" name))
-	  ((not (typep (layout-class res) 'structure-class))
-	   (error "Class is not a STRUCTURE-CLASS: ~S" name))
+	  ((not (typep (layout-info res) 'defstruct-description))
+	   (error "Class is not a structure class: ~S" name))
 	  (t res))))
 
 
@@ -231,16 +267,20 @@
 		    ,(if (symbolp pf)
 			 `',pf
 			 `#',pf)))))
-	,@(let ((mlff (dd-make-load-form-fun defstruct)))
-	    (when mlff
-	      `((setf (structure-class-make-load-form-fun (find-class ',name))
-		      ,(if (symbolp mlff)
-			   `',mlff
-			   `#',mlff)))))
-	,@(let ((pure (dd-pure defstruct)))
-	    (when (eq pure 't)
-	      `((setf (layout-pure (class-layout (find-class ',name)))
-		      t)))))))
+      ,@(let ((mlff (dd-make-load-form-fun defstruct)))
+	  (when mlff
+	    `((setf (structure-class-make-load-form-fun (find-class ',name))
+		    ,(if (symbolp mlff)
+			 `',mlff
+			 `#',mlff)))))
+      ,@(let ((pure (dd-pure defstruct)))
+	  (when (eq pure 't)
+	    `((setf (layout-pure (class-layout (find-class ',name)))
+		    t))))
+      ,@(let ((def-con (dd-default-constructor defstruct)))
+	  (when (and def-con (not (dd-alternate-metaclass defstruct)))
+	    `((setf (structure-class-constructor (find-class ',name))
+		    #',def-con)))))))
 
 
 ;;; DEFSTRUCT  --  Public
@@ -283,13 +323,14 @@
       (setf (dd-doc defstruct) (pop slot-descriptions)))
     (dolist (slot slot-descriptions)
       (allocate-1-slot defstruct (parse-1-dsd defstruct slot)))
-    (if (eq (dd-type defstruct) 'structure)
+    (if (class-structure-p defstruct)
 	(let ((inherits (inherits-for-structure defstruct)))
 	  `(progn
 	     (%defstruct ',defstruct ',inherits)
 	     (eval-when (compile eval)
 	       (%compiler-only-defstruct ',defstruct ',inherits))
-	     (%compiler-defstruct ',defstruct)
+	     ,@(when (eq (dd-type defstruct) 'structure)
+		 `((%compiler-defstruct ',defstruct)))
 	     ,@(define-raw-accessors defstruct)
 	     ,@(define-constructors defstruct)
 	     ,@(define-class-methods defstruct)
@@ -344,7 +385,9 @@
 	 (setf (dd-print-function defstruct) fun)))
       (:type
        (destructuring-bind (type) args
-	 (cond ((member type '(list vector))
+	 (cond ((eq type 'funcallable-structure)
+		(setf (dd-type defstruct) type))
+	       ((member type '(list vector))
 		(setf (dd-element-type defstruct) 't)
 		(setf (dd-type defstruct) type))
 	       ((and (consp type) (eq (first type) 'vector))
@@ -386,7 +429,7 @@
 	       (error "Unrecognized DEFSTRUCT option: ~S" option))))
 
       (cond
-       ((eq (dd-type defstruct) 'structure)
+       ((class-structure-p defstruct)
 	(when (dd-offset defstruct)
 	  (error "Can't specify :OFFSET unless :TYPE is specified."))
 	(unless (dd-include defstruct)
@@ -517,7 +560,7 @@
 		      (dd-include defstruct)
     (let* ((type (dd-type defstruct))
 	   (included-structure
-	    (if (eq type 'structure)
+	    (if (class-structure-p defstruct)
 		(layout-info (compiler-layout-or-lose included-name))
 		(typed-structure-info-or-lose included-name))))
       (unless (and (eq type (dd-type included-structure))
@@ -527,13 +570,17 @@
 	       (dd-name defstruct) included-name))
       
       (incf (dd-length defstruct) (dd-length included-structure))
-      (when (eq (dd-type defstruct) 'structure)
+      (when (class-structure-p defstruct)
 	(unless (dd-print-function defstruct)
 	  (setf (dd-print-function defstruct)
 		(dd-print-function included-structure)))
 	(unless (dd-make-load-form-fun defstruct)
 	  (setf (dd-make-load-form-fun defstruct)
 		(dd-make-load-form-fun included-structure)))
+	(let ((mc (rest (dd-alternate-metaclass included-structure))))
+	  (when (and mc (not (dd-alternate-metaclass defstruct)))
+	    (setf (dd-alternate-metaclass defstruct)
+		  (cons included-name mc))))
 	(when (eq (dd-pure defstruct) :unspecified)
 	  (setf (dd-pure defstruct) (dd-pure included-structure)))
 	(setf (dd-raw-index defstruct) (dd-raw-index included-structure))
@@ -597,7 +644,7 @@
 ;;; arglist.  Vars and Types are used for argument type declarations.  Values
 ;;; are the values for the slots (in order.)
 ;;;
-;;; This is split three ways because:
+;;; This is split four ways because:
 ;;; 1] list & vector structures need "name" symbols stuck in at various weird
 ;;;    places, whereas STRUCTURE structures have a LAYOUT slot.
 ;;; 2] We really want to use LIST to make list structures, instead of
@@ -605,6 +652,7 @@
 ;;; 3] STRUCTURE structures can have raw slots that must also be allocated and
 ;;;    indirectly referenced.  We use SLOT-ACCESSOR-FORM to compute how to set
 ;;;    the slots, which deals with raw slots.
+;;; 4] funcallable structures are weird.
 ;;;
 (defun create-vector-constructor
        (defstruct cons-name arglist vars types values) 
@@ -662,6 +710,24 @@
 		   (dd-slots defstruct)
 		   values)
 	 ,temp))))
+;;;
+(defun create-fin-constructor
+       (defstruct cons-name arglist vars types values) 
+  (let ((temp (gensym)))
+    `(defun ,cons-name ,arglist
+       (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+			  vars types))
+       (let ((,temp (truly-the
+		     ,(dd-name defstruct)
+		     (%make-funcallable-instance
+		      ,(dd-length defstruct)
+		      (%get-compiler-layout ,(dd-name defstruct))))))
+	 ,@(mapcar #'(lambda (dsd value)
+		       `(setf (%funcallable-instance-info
+			       ,temp ,(dsd-index dsd))
+			      ,value))
+		   (dd-slots defstruct) values)
+	 ,temp))))
 
 
 ;;; CREATE-KEYWORD-CONSTRUCTOR   --  Internal
@@ -776,6 +842,7 @@
 	(defaults ())
 	(creator (ecase (dd-type defstruct)
 		   (structure #'create-structure-constructor)
+		   (funcallable-structure #'create-fin-constructor)
 		   (vector #'create-vector-constructor)
 		   (list #'create-list-constructor))))
     (dolist (constructor (dd-constructors defstruct))
@@ -829,7 +896,10 @@
        (single-float '%raw-ref-single)
        (double-float '%raw-ref-double)
        (unsigned-byte 'aref)
-       ((t) '%instance-ref))
+       ((t)
+	(if (eq (dd-type defstruct) 'funcallable-structure)
+	    '%funcallable-instance-info
+	    '%instance-ref)))
      (if (eq rtype 'double-float)
 	 (ash (dsd-index slot) -1)
 	 (dsd-index slot))
@@ -844,7 +914,8 @@
 ;;; DEFINE-RAW-ACCESSORS  --  Internal
 ;;;
 ;;;    Define readers and writers for raw slots as inline functions.  We use
-;;; the special RAW-REF operations to store floats in the raw data vector.
+;;; the special RAW-REF operations to store floats in the raw data vector.  We
+;;; also define FIN accessors here.
 ;;;
 (defun define-raw-accessors (defstruct)
   (let ((name (dd-name defstruct)))
@@ -868,8 +939,15 @@
 		 `(defun (setf ,aname) (new-value object)
 		    (setf (,accessor ,data ,offset) new-value)
 		    new-value)))))))
-    (res))))
-	  
+
+      (when (eq (dd-type defstruct) 'funcallable-structure)
+	(let ((pred (dd-predicate defstruct)))
+	  (when pred
+	    (res `(declaim (inline ,pred)))
+	    (res `(defun ,pred (x) (typep x ',name))))))
+
+      (res))))
+
 
 ;;;; Typed (non-class) structures:
 
@@ -1009,7 +1087,7 @@
 		       (ensure-structure-class info inherits "current" "new")
     (cond ((not old-layout)
 	   (unless (eq (class-layout class) layout)
-	     (register-layout layout nil nil)))
+	     (register-layout layout)))
 	  (t
 	   (let ((old-info (layout-info old-layout)))    
 	     (when (defstruct-description-p old-info)
@@ -1020,36 +1098,37 @@
 	   (%redefine-defstruct class old-layout layout)))
 
     (setf (find-class (dd-name info)) class)
+
+    (unless (eq (dd-type info) 'funcallable-structure)
+      (dolist (slot (dd-slots info))
+	(let ((dsd slot))
+	  (when (and (dsd-accessor slot)
+		     (eq (dsd-raw-type slot) 't))
+	    (setf (symbol-function (dsd-accessor slot))
+		  (structure-slot-accessor layout dsd))
+	    
+	    (unless (dsd-read-only slot)
+	      (setf (fdefinition `(setf ,(dsd-accessor slot)))
+		    (structure-slot-setter layout dsd))))))
       
-    (dolist (slot (dd-slots info))
-      (let ((dsd slot))
-	(when (and (dsd-accessor slot)
-		   (eq (dsd-raw-type slot) 't))
-	  (setf (symbol-function (dsd-accessor slot))
-		(structure-slot-accessor layout dsd))
-	  
-	  (unless (dsd-read-only slot)
-	    (setf (fdefinition `(setf ,(dsd-accessor slot)))
-		  (structure-slot-setter layout dsd))))))
-    
-    (when (dd-predicate info)
-      (setf (symbol-function (dd-predicate info))
-	    #'(lambda (object)
-		(declare (optimize (speed 3) (safety 0)))
-		(typep-to-layout object layout))))
-    
-    (when (dd-copier info)
-      (setf (symbol-function (dd-copier info))
-	    #'(lambda (structure)
-		(declare (optimize (speed 3) (safety 0)))
-		(unless (typep-to-layout structure layout)
-		  (error "Structure for copier is not a ~S:~% ~S"
-			 (class-name (layout-class layout))
-			 structure))
-		(copy-structure structure)))))
+      (when (dd-predicate info)
+	(setf (symbol-function (dd-predicate info))
+	      #'(lambda (object)
+		  (declare (optimize (speed 3) (safety 0)))
+		  (typep-to-layout object layout))))
+      
+      (when (dd-copier info)
+	(setf (symbol-function (dd-copier info))
+	      #'(lambda (structure)
+		  (declare (optimize (speed 3) (safety 0)))
+		  (unless (typep-to-layout structure layout)
+		    (error "Structure for copier is not a ~S:~% ~S"
+			   (class-name (layout-class layout))
+			   structure))
+		  (copy-structure structure)))))
   
   (when (dd-doc info)
-    (setf (documentation (dd-name info) 'type) (dd-doc info)))
+    (setf (documentation (dd-name info) 'type) (dd-doc info))))
 
   (undefined-value))
 
@@ -1151,8 +1230,8 @@
 	(warn 
 	 "Incompatibly redefining slots of structure class ~S~@
 	  Make sure any uses of affected accessors are recompiled:~@
-	  ~@[  These slots were moved to new positions:~%    ~S~%~]
-	  ~@[  These slots have new incompatible types:~%    ~S~%~]
+	  ~@[  These slots were moved to new positions:~%    ~S~%~]~
+	  ~@[  These slots have new incompatible types:~%    ~S~%~]~
 	  ~@[  These slots were deleted:~%    ~S~%~]"
 	 name moved retyped deleted)
 	t))))
@@ -1165,8 +1244,7 @@
 ;;; proceed options.
 ;;;
 (defun %redefine-defstruct (class old-layout new-layout)
-  (declare (type class class) (type layout new-layout)
-	   (ignore old-layout))
+  (declare (type class class) (type layout old-layout new-layout))
   (let ((name (class-proper-name class)))
     (restart-case
 	(error "Redefining class ~S incompatibly with the current ~
@@ -1175,13 +1253,14 @@
       (continue ()
 	:report "Invalidate current definition."
 	(warn "Previously loaded ~S accessors will no longer work." name)
-	(register-layout new-layout t nil))
+	(register-layout new-layout))
       (clobber-it ()
 	:report "Smash current layout, preserving old code."
 	(warn "Any old ~S instances will be in a bad way.~@
 	       I hope you know what you're doing..."
 	      name)
-	(register-layout new-layout nil t))))
+	(register-layout new-layout :invalidate nil
+			 :destruct-layout old-layout))))
 
   (undefined-value))
 
@@ -1277,7 +1356,7 @@
 		  (class-name class) (subs))))))
      (t
       (unless (eq (class-layout class) layout)
-	(register-layout layout nil nil))
+	(register-layout layout :invalidate nil))
       (setf (find-class (dd-name info)) class)))
     
     (setf (info type compiler-layout (dd-name info)) layout))
@@ -1307,7 +1386,7 @@
 	(setf (info function inlinep pred) :inline)
 	(setf (info function inline-expansion pred)
 	      `(lambda (x) (typep x ',name)))))
-    
+
     (dolist (slot (dd-slots info))
       (let* ((fun (dsd-accessor slot))
 	     (setf-fun `(setf ,fun)))
-- 
GitLab