/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Diff of /src/pcl/fin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10.2.2 by pw, Sat Mar 23 18:51:18 2002 UTC revision 1.23 by rtoy, Fri Mar 19 15:19:03 2010 UTC
# Line 23  Line 23 
23  ;;;  ;;;
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
 ;;;  
26    
27  (ext:file-comment  (file-comment
28    "$Header$")    "$Header$")
29  ;;;  ;;;
30    
# Line 71  explicitly marked saying who wrote it. Line 70  explicitly marked saying who wrote it.
70  |#  |#
71    
72  (in-package :pcl)  (in-package :pcl)
73    (intl:textdomain "cmucl")
74    
75  ;;;  ;;;
76  ;;; The first part of the file contains the implementation dependent code to  ;;; The first part of the file contains the implementation dependent code to
# Line 110  explicitly marked saying who wrote it. Line 110  explicitly marked saying who wrote it.
110  ;;;       This must be SETF'able.  ;;;       This must be SETF'able.
111  ;;;  ;;;
112    
 (eval-when (compile load eval)  
 (defconstant funcallable-instance-data  
              '(wrapper slots)  
   "These are the 'data-slots' which funcallable instances have so that  
    the meta-class funcallable-standard-class can store class, and static  
    slots in them.")  
 )  
   
 (defmacro funcallable-instance-data-position (data)  
   (if (and (consp data)  
            (eq (car data) 'quote))  
       (or (position (cadr data) funcallable-instance-data :test #'eq)  
           (progn  
             (warn "Unknown funcallable-instance data: ~S." (cadr data))  
             `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))  
       `(position ,data funcallable-instance-data :test #'eq)))  
   
113  (declaim (notinline called-fin-without-function))  (declaim (notinline called-fin-without-function))
114  (defun called-fin-without-function (&rest args)  (defun called-fin-without-function (&rest args)
115    (declare (ignore args))    (declare (ignore args))
116    (error "Attempt to funcall a funcallable-instance without first~%~    (error _"~@<Attempt to funcall a funcallable instance without first ~
117            setting its funcallable-instance-function."))            setting its function.~@:>"))
118    
119    
120  ;;;; Implementation of funcallable instances for CMU Common Lisp:  ;;;; Implementation of funcallable instances for CMU Common Lisp:
# Line 150  explicitly marked saying who wrote it. Line 133  explicitly marked saying who wrote it.
133    (pcl-funcallable-instance-slots nil)    (pcl-funcallable-instance-slots nil)
134    ;;    ;;
135    ;; The debug-name for this function.    ;; The debug-name for this function.
136    (funcallable-instance-name nil))    (funcallable-instance-name nil)
137      ;;
138      ;; Hash code.
139      (hash-code (get-instance-hash-code) :type fixnum))
140    
141  ;;; Note: returns true for non-pcl funcallable structures.  ;;; Note: returns true for non-pcl funcallable structures.
142  (import 'kernel:funcallable-instance-p)  (import 'kernel:funcallable-instance-p)
# Line 165  explicitly marked saying who wrote it. Line 151  explicitly marked saying who wrote it.
151    (assert (funcallable-instance-p fin))    (assert (funcallable-instance-p fin))
152    (setf (kernel:funcallable-instance-function fin) new-value))    (setf (kernel:funcallable-instance-function fin) new-value))
153    
   
 ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface  
 ;;;  
 ;;;    This "works" on non-PCL FINs, which allows us to weaken  
 ;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs.  This is also  
 ;;; necessary for bootstrapping to work, since the layouts for early GFs are  
 ;;; not initially initialized.  
 ;;;  
 (defmacro funcallable-instance-data-1 (fin slot)  
   (ecase (eval slot)  
     (wrapper `(kernel:%funcallable-instance-layout ,fin))  
     (slots `(kernel:%funcallable-instance-info ,fin 0))))  
   
 (defmacro pcl-funcallable-instance-wrapper (x)  
   `(kernel:%funcallable-instance-layout ,x))  
   
   
 ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.  
 ;;;  
 ;;;  
   
 (defmacro fsc-instance-p (fin)  
   `(funcallable-instance-p ,fin))  
   
 (defmacro fsc-instance-class (fin)  
   `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))  
   
 (defmacro fsc-instance-wrapper (fin)  
   `(funcallable-instance-data-1 ,fin 'wrapper))  
   
 (defmacro fsc-instance-slots (fin)  
   `(funcallable-instance-data-1 ,fin 'slots))  

Legend:
Removed from v.1.10.2.2  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5