home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part06 / gfun-low.l next >
Encoding:
Text File  |  1987-08-01  |  20.1 KB  |  610 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER) 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. #|  To do:
  28.  
  29. figure out bootstrapping issues
  30.  
  31. fix problems caused by make-iwmc-class-accessor
  32.  
  33. polish up the low levels of iwmc-class, 
  34.  
  35. polish up low levels of this and implement it for the 3600 then Lucid.
  36.  
  37. fix use of get-slot-using-class--class-internal
  38.  
  39. |#
  40.   ;;   
  41. ;;;;;; FUNCALLABLE INSTANCES
  42.   ;;
  43.  
  44. #|
  45.  
  46. In CommonLoops, generic functions are instances whose meta class is
  47. funcallable-standard-class.  Instances with this meta class behave
  48. something like lexical closures in that they have slots, just like
  49. instances with meta class standard-class, and are also funcallable.
  50. When an instance with meta class funcallable-standard-class is
  51. funcalled, the value of its function slot is called.
  52.  
  53. It is possible to implement funcallable instances in pure Common Lisp.
  54. A simple implementation which uses lexical closures as the instances and
  55. a hash table to record that the lexical closures are funcallable
  56. instances is easy to write.  Unfortunately, this implementation adds
  57. such significant overhead:
  58.  
  59.    to generic-function-invocation (1 function call)
  60.    to slot-access (1 function call)
  61.    to class-of a generic-function (1 hash-table lookup)
  62.  
  63. that it is too slo to be practical.
  64.  
  65. Instead, PCL uses a specially tailored implementation for each common
  66. Lisp and makes no attempt to provide a purely portable implementation.
  67. The specially tailored implementations are based on each the lexical
  68. closure's provided by that implementation and tend to be fairly easy to
  69. write.
  70.  
  71. |#
  72.  
  73. (in-package 'pcl)
  74.  
  75. ;;;
  76. ;;; The first part of the file contains the implementation dependent code
  77. ;;; to implement the low-level funcallable instances.  Each implementation
  78. ;;; must provide the following functions and macros:
  79. ;;; 
  80. ;;;    MAKE-FUNCALLABLE-INSTANCE-1 ()
  81. ;;;       should create and return a new funcallable instance
  82. ;;;
  83. ;;;    FUNCALLABLE-INSTANCE-P (x)
  84. ;;;       the obvious predicate
  85. ;;;
  86. ;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION-1 (fin new-value)
  87. ;;;       change the fin so that when it is funcalled, the new-value
  88. ;;;       function is called.  Note that it is legal for new-value
  89. ;;;       to be copied before it is installed in the fin (the Lucid
  90. ;;;       implementation in particular does this).
  91. ;;;
  92. ;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
  93. ;;;       should return the value of the data named data-name in the fin
  94. ;;;       data-name is one of the symbols in the list which is the value
  95. ;;;       of funcallable-instance-data.  Since data-name is almost always
  96. ;;;       a quoted symbol and funcallable-instance-data is a constant, it
  97. ;;;       is possible (and worthwhile) to optimize the computation of
  98. ;;;       data-name's offset in the data part of the fin.
  99. ;;;       
  100.  
  101. (defconstant funcallable-instance-data
  102.          '(class wrapper static-slots dynamic-slots)
  103.   "These are the 'data-slots' which funcallable instances have so that
  104.    the meta-class funcallable-standard-class can store class, and static
  105.    and dynamic slots in them.")
  106.  
  107. #+Lucid
  108. (progn
  109.   
  110. (defconstant funcallable-instance-procedure-size 50)
  111. (defconstant funcallable-instance-flag-bit #B1000000000000000)
  112. (defvar *funcallable-instance-trampolines* ()
  113.   "This is a list of all the procedure sizes which were too big to be stored
  114.    directly in a funcallable instance.  For each of these procedures, a
  115.    trampoline procedure had to be used.  This is for metering information
  116.    only.")
  117.  
  118. (defun make-funcallable-instance-1 ()
  119.   (let ((new-fin (lucid::new-procedure funcallable-instance-procedure-size)))
  120.     ;; Have to set the procedure function to something for two reasons.
  121.     ;;   1. someone might try to funcall it.
  122.     ;;   2. the flag bit that says the procedure is a funcallable
  123.     ;;      instance is set by set-funcallable-instance-function.
  124.     (set-funcallable-instance-function
  125.       new-fin
  126.       #'(lambda (&rest ignore)
  127.       (declare (ignore ignore))
  128.       (error "Attempt to funcall a funcallable-instance without first~%~
  129.                   setting its funcallable-instance-function.")))
  130.     new-fin))
  131.  
  132. (defmacro funcallable-instance-p (x)
  133.   (once-only (x)
  134.     `(and (lucid::procedurep ,x)
  135.       (logand (lucid::procedure-ref ,x lucid::procedure-flags)
  136.           funcallable-instance-flag-bit))))
  137.  
  138. (defun set-funcallable-instance-function-1 (fin new-value)
  139.   (unless (funcallable-instance-p fin)
  140.     (error "~S is not a funcallable-instance"))
  141.   (cond ((not (functionp new-value))
  142.      (error "~S is not a function."))
  143.     ((not (lucid::procedurep new-value))
  144.      ;; new-value is an interpreted function.  Install a
  145.      ;; trampoline to call the interpreted function.
  146.      (set-funcallable-instance-function fin
  147.                         (make-trampoline new-value)))
  148.     (t
  149.      (let ((new-procedure-size (lucid::procedure-length new-value))
  150.            (max-procedure-size (- funcallable-instance-procedure-size
  151.                       (length funcallable-instance-data))))
  152.        (if (< new-procedure-size max-procedure-size)
  153.            ;; The new procedure fits in the funcallable-instance.
  154.            ;; Just copy the new procedure into the fin procedure,
  155.            ;; also be sure to update the procedure-flags of the
  156.            ;; fin to keep it a fin.
  157.            (progn 
  158.          (dotimes (i max-procedure-size)
  159.            (setf (lucid::procedure-ref fin i)
  160.              (lucid::procedure-ref new-value i)))
  161.          (setf (lucid::procedure-ref fin lucid::procedure-flags)
  162.                (logand funcallable-instance-flag-bit
  163.                    (lucid::procedure-ref
  164.                  fin lucid::procedure-flags)))
  165.          new-value)
  166.            ;; The new procedure doesn't fit in the funcallable instance
  167.            ;; Instead, install a trampoline procedure which will call
  168.            ;; the new procecdure.  First make note of the fact that we
  169.            ;; had to trampoline so that we can see if its worth upping
  170.            ;; the value of funcallable-instance-procedure-size.
  171.            (progn
  172.          (push new-procedure-size *funcallable-instance-trampolines*)
  173.          (set-funcallable-instance-function
  174.            fin
  175.            (make-trampoline new-value))))))))
  176.  
  177.  
  178. (defmacro funcallable-instance-data-1 (instance data)
  179.   `(lucid::procedure-ref ,instance
  180.              (- funcallable-instance-procedure-size
  181.                 (position ,data funcallable-instance-data))))
  182.   
  183. );dicuL+#
  184.  
  185. ;;;
  186. ;;; All of these Lisps (Xerox Symbolics ExCL KCL and VAXLisp) have the
  187. ;;; following in Common:
  188. ;;; 
  189. ;;;    - they represent their compiled closures as a pair of
  190. ;;;      environment and compiled function
  191. ;;;    - they represent the environment using a list or a vector
  192. ;;;    - I don't (YET) know how to add a bit to the damn things to
  193. ;;;      say that they are funcallable-instances and so I have to
  194. ;;;      use the last entry in the closure environment to do that.
  195. ;;;      This is a lose because that is much slower, I have to CDR
  196. ;;;      down to the last element of the environment.
  197. ;;;      
  198. #+(OR Xerox Symbolics ExCL KCL (and DEC VAX))
  199. (progn
  200.  
  201. (defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
  202.  
  203. (defconstant funcallable-instance-closure-size 15)
  204.  
  205. (defmacro lexical-closure-p (lc)
  206.   #+Xerox         `(typep ,lc 'il:compiled-closure)
  207.   #+Symbolics     `(si:lexical-closure-p ,lc)
  208.   #+ExCL          `()
  209.   #+KCL           `()
  210.   #+(and DEC VAX) (once-only (lc)
  211.             `(and (listp ,lc)
  212.               (eq (car ,lc) 'system::%compiled-closure%))))
  213.  
  214. (defmacro lexical-closure-env (lc)
  215.   #+Xerox         `()
  216.   #+Symbolics     `(si:lexical-closure-environment ,lc)
  217.   #+ExCL          `()
  218.   #+KCL           `()
  219.   #+(and DEC VAX) `(caadr ,lc))
  220.  
  221. (defmacro lexical-closure-env-size (env)
  222.   #+Xerox         `()
  223.   #+Symbolics     `(length ,env)
  224.   #+ExCL          `()
  225.   #+KCL           `()
  226.   #+(and DEC VAX) `(array-dimension ,env 0))  
  227.  
  228. (defmacro lexical-closure-env-ref (env index check) check
  229.   #+Xerox         `()
  230.   #+Symbolics     `(let ((env ,env))
  231.              (dotimes (i ,index)
  232.                (setq env (cdr env)))
  233.              (car env))
  234.   #+ExCL          `()
  235.   #+KCL           `()
  236.   #+(and DEC VAX) (once-only (env)
  237.             `(and ,(or checkp
  238.                    `(= (array-dimension ,env 0)
  239.                    funcallable-instance-closure-size))
  240.               (svref ,env 0))))
  241.  
  242. (defmacro lexical-closure-env-set (env index new checkp) checkp
  243.   #+Xerox         `()
  244.   #+Symbolics     `(let ((env ,env))
  245.              (dotimes (i ,index)
  246.                (setq env (cdr env)))
  247.              (setf (car env) ,new))
  248.   #+ExCL          `()
  249.   #+KCL           `()
  250.   #+(and DEC VAX) (once-only (env)
  251.             `(and ,(or checkp
  252.                    `(= (array-dimension ,env 0)
  253.                    funcallable-instance-closure-size))
  254.               (setf (svref ,env ,index) ,new))))
  255.  
  256. (defmacro lexical-closure-code (lc)
  257.   #+Xerox         `()
  258.   #+Symbolics     `(si:lexical-closure-function ,lc)
  259.   #+ExCL          `()
  260.   #+KCL           `()
  261.   #+(and DEC VAX) `(caddr ,lc))
  262.  
  263. (defmacro compiled-function-code (cf)  
  264.   #+Xerox         `()
  265.   #+Symbolics     cf
  266.   #+ExCL          `()
  267.   #+KCL           `()
  268.   #+(and DEC VAX) `())
  269.  
  270. (eval-when (load eval)
  271.   (let ((dummies ()))
  272.     (dotimes (i funcallable-instance-closure-size)
  273.       (push (gentemp "Dummy Closure Variable ") dummies))
  274.     (compile 'make-funcallable-instance-1    ;For the time being, this use
  275.          `(lambda ()            ;of compile at load time is
  276.         (let (new-fin ,@dummies)    ;simpler than using #.
  277.           (setq new-fin #'(lambda ()
  278.                     ,@(mapcar #'(lambda (d)
  279.                           `(setq ,d (dummy-fn ,d)))
  280.                           dummies)))
  281.           (lexical-closure-env-set
  282.             (lexical-closure-env new-fin)
  283.             (1- funcallable-instance-closure-size)
  284.             *funcallable-instance-marker*
  285.             t)
  286.           new-fin)))))
  287.  
  288. (defmacro funcallable-instance-p (x)
  289.   (once-only (x)
  290.     `(and (lexical-closure-p ,x)
  291.       (let ((env (lexical-closure-env ,x)))
  292.         (and (eq (lexical-closure-env-ref
  293.                env (1- funcallable-instance-closure-size) t)
  294.              *funcallable-instance-marker*))))))
  295.  
  296. (defun set-funcallable-instance-function-1 (fin new-value)
  297.   (cond ((lexical-closure-p new-value)
  298.      (let* ((fin-env (lexical-closure-env fin))
  299.         (new-env (lexical-closure-env new-value))
  300.         (new-env-size (lexical-closure-env-size new-env))
  301.         (fin-env-size (- funcallable-instance-closure-size
  302.                  (length funcallable-instance-data))))
  303.        (cond ((<= new-env-size fin-env-size)
  304.           (dotimes (i new-env-size)
  305.             (lexical-closure-env-set
  306.               fin-env i (lexical-closure-env-ref new-env i nil) nil))
  307.           (setf (lexical-closure-code fin)
  308.             (lexical-closure-code new-value)))
  309.          (t            
  310.           (set-funcallable-instance-function-1
  311.             fin (make-trampoline new-value))))))
  312.     (t
  313.      #+Symbolics
  314.      (set-funcallable-instance-function-1 fin
  315.                           (make-trampoline new-value))
  316.      #-Symbolics
  317.      (setf (lexical-closure-code fin)
  318.            (compiled-function-code new-value)))))
  319.     
  320. (defmacro funcallable-instance-data-1 (fin data)
  321.   `(lexical-closure-env-ref
  322.      (lexical-closure-env ,fin)
  323.      (- funcallable-instance-closure-size
  324.     (position ,data funcallable-instance-data)
  325.     2)
  326.      nil))
  327.  
  328. (defsetf funcallable-instance-data-1 (fin data) (new-value)
  329.   `(lexical-closure-env-set
  330.      (lexical-closure-env ,fin)
  331.      (- funcallable-instance-closure-size
  332.     (position ,data funcallable-instance-data)
  333.     2)
  334.      ,new-value
  335.      nil))
  336.  
  337. );
  338.  
  339.  
  340. (defun make-trampoline (function)
  341.   #'(lambda (&rest args)
  342.       (apply function args)))
  343.  
  344. (defun set-funcallable-instance-function (fin new-value)
  345.   (cond ((not (funcallable-instance-p fin))
  346.      (error "~S is not a funcallable-instance"))
  347.     ((not (functionp new-value))
  348.      (error "~S is not a function."))
  349.     ((compiled-function-p new-value)
  350.      (set-funcallable-instance-function-1 fin new-value))
  351.     (t
  352.      (set-funcallable-instance-function-1 fin
  353.                           (make-trampoline new-value)))))
  354.  
  355.  
  356. (eval-when (eval load)
  357.   (setq *class-of*
  358.     '(lambda (x) 
  359.        (or (and (%instancep x)
  360.             (%instance-class-of x))
  361.            (and (funcallable-instance-p x)
  362.             (funcallable-instance-class x))
  363.            (class-named (type-of x) t))))
  364.  
  365.   (recompile-class-of))
  366.  
  367.  
  368. (defmacro funcallable-instance-class (fin)
  369.   `(funcallable-instance-data-1 ,fin 'class))
  370.  
  371. (defmacro funcallable-instance-wrapper (fin)
  372.   `(funcallable-instance-data-1 ,fin 'wrapper))
  373.  
  374. (defmacro funcallable-instance-static-slots (fin)
  375.   `(funcallable-instance-data-1 ,fin 'static-slots))
  376.  
  377. (defmacro funcallable-instance-dynamic-slots (fin)
  378.   `(funcallable-instance-data-1 ,fin 'dynamic-slots))
  379.  
  380. (defun make-funcallable-instance (class wrapper number-of-static-slots)
  381.   (let ((fin (make-funcallable-instance-1))
  382.     (static-slots (make-memory-block number-of-static-slots))
  383.     (dynamic-slots ()))
  384.     (setf (funcallable-instance-class fin) class
  385.       (funcallable-instance-wrapper fin) wrapper
  386.       (funcallable-instance-static-slots fin) static-slots
  387.       (funcallable-instance-dynamic-slots fin) dynamic-slots)
  388.     fin))
  389.  
  390.  
  391. ;;; By macroleting the definitions of:
  392. ;;;   IWMC-CLASS-CLASS-WRAPPER
  393. ;;;   IWMC-CLASS-STATIC-SLOTS
  394. ;;;   IWMC-CLASS-DYNAMIC-SLOTS
  395. ;;;   get-slot-using-class--class-internal   ;These are kind of a
  396. ;;;   put-slot-using-class--class-internal   ;hack, solidfy this.
  397. ;;;
  398. ;;; we can use all the existing code for metaclass class.
  399. ;;; 
  400. (defmacro with-funcallable-class-as-class ((instance checkp)
  401.                        &body body)
  402.   (once-only (instance)
  403.     `(let ((.class. (funcallable-instance-p ,instance)))
  404.        ,(and checkp
  405.          `(or .class.
  406.           (error "~S is not an instance with meta-class ~
  407.                           funcallable-class." ,instance)))
  408.        (macrolet ((iwmc-class-class-wrapper (instance)
  409.             `(funcallable-instance-wrapper ,instance))
  410.           (iwmc-class-static-slots (instance)
  411.             `(funcallable-instance-static-slots ,instance))
  412.           (iwmc-class-dynamic-slots (instance)
  413.             `(funcallable-instance-dynamic-slots ,instance))
  414.           (get-slot-using-class--class-internal
  415.             (class object slot-name
  416.                dont-call-slot-missing-p default)
  417.             `(with-slot-internal--class (,class ,object
  418.                          ,slot-name nil)
  419.                (:instance (index)
  420.             (get-static-slot--class ,object index))
  421.                (:dynamic (loc newp) (if (eq newp t)
  422.                         (setf (car loc) ,default)
  423.                         (car loc)))
  424.                (:class (slotd) (slotd-default slotd))
  425.                (nil () (unless ,dont-call-slot-missing-p
  426.                  (slot-missing ,object ,slot-name)))))
  427.           (put-slot-using-class--class-internal
  428.             (class object slot-name new-value
  429.                dont-call-slot-missing-p)
  430.             `(with-slot-internal--class (,class ,object
  431.                          ,slot-name
  432.                          ,dont-call-slot-missing-p)
  433.                (:instance (index)
  434.             (setf (get-static-slot--class ,object
  435.                               index)
  436.                   ,new-value))
  437.                (:dynamic (loc) (setf (car loc) ,new-value))
  438.                (:class (slotd) (setf (slotd-default slotd)
  439.                          ,new-value))
  440.                (nil () (unless ,dont-call-slot-missing-p
  441.                  (slot-missing ,object ,slot-name))))))
  442.      ,@body))))
  443.  
  444.   ;;   
  445. ;;;;;; 
  446.   ;;   
  447.  
  448.  
  449. (defmacro get-slot--funcallable-class (fnc-instance slot-name)
  450.   (once-only (fnc-instance slot-name)
  451.     `(with-funcallable-class-as-class (,fnc-instance t)
  452.        (get-slot--class ,fnc-instance ,slot-name))))
  453.  
  454. (defmacro put-slot--funcallable-class (fnc-instance slot-name new-value)
  455.   (once-only (fnc-instance slot-name)
  456.     `(with-funcallable-class-as-class (,fnc-instance t)
  457.        ;; Cheat a little bit here, its worth it.
  458.        ,(if (constantp slot-name)
  459.         (if (eq (eval slot-name) 'function)
  460.         `(progn (set-funcallable-instance-function ,fnc-instance
  461.                                ,new-value)
  462.             (put-slot--class ,fnc-instance ,slot-name ,new-value))
  463.         `(put-slot--class ,fnc-instance ,slot-name ,new-value))
  464.         `(if (eq ,slot-name 'function)
  465.          (progn (set-funcallable-instance-function ,fnc-instance
  466.                                ,new-value)
  467.             (put-slot--class ,fnc-instance ,slot-name ,new-value))
  468.          (put-slot--class ,fnc-instance ,slot-name ,new-value))))))
  469.  
  470.   ;;   
  471. ;;;;;; 
  472.   ;;   
  473.  
  474. (defclass funcallable-class (class)
  475.   ())
  476.  
  477. (defmeth check-super-metaclass-compatibility ((fnc-class funcallable-class)
  478.                           (class class))
  479.   (ignore fnc-class)
  480.   (null (class-slots class)))
  481.  
  482.  
  483. (defmeth get-slot-using-class ((ignore funcallable-class)
  484.                    instance
  485.                    slot-name)
  486.   (get-slot--funcallable-class instance slot-name))
  487.  
  488. (defmeth put-slot-using-class ((ignore funcallable-class)
  489.                    instance
  490.                    slot-name
  491.                    new-value)
  492.   (put-slot--funcallable-class instance slot-name new-value))
  493.  
  494. (defmeth make-instance ((class funcallable-class))
  495.   (let ((class-wrapper (class-wrapper class)))
  496.     (if class-wrapper                ;Are there any instances?
  497.         ;; If there are instances, the class is OK, just go ahead and
  498.         ;; make the instance.
  499.     (make-funcallable-instance class
  500.                    class-wrapper
  501.                    (class-no-of-instance-slots class))
  502.         ;; Do first make-instance-time error-checking, build the class
  503.         ;; wrapper and call ourselves again to really build the instance.
  504.         (progn
  505.           ;; no first time error checking yet.
  506.           (setf (class-wrapper class) (make-class-wrapper class))
  507.           (make-instance class)))))
  508.  
  509. (eval-when (compile load eval)
  510.  
  511. (define-function-template iwmc-funcallable-class-accessor () '(slot-name)
  512.   `(function (lambda (iwmc-class)
  513.            (get-slot--funcallable-class iwmc-class slot-name))))
  514.  
  515. (define-function-template iwmc-funcallable-class-accessor-setf (read-only-p)
  516.                                    '(slot-name)
  517.   (if read-only-p
  518.       `(function
  519.          (lambda (iwmc-class new-value)
  520.        (error "~S is a read only slot." slot-name)))
  521.       `(function
  522.          (lambda (iwmc-class new-value)
  523.        (put-slot--funcallable-class iwmc-class slot-name new-value)))))
  524. )
  525.  
  526. (eval-when (load)
  527.   (pre-make-templated-function-constructor iwmc-class-accessor)
  528.   (pre-make-templated-function-constructor iwmc-class-accessor-setf nil)
  529.   (pre-make-templated-function-constructor iwmc-class-accessor-setf t))
  530.  
  531. (defmethod make-iwmc-class-accessor ((ignore funcallable-class) slotd)
  532.   (funcall
  533.     (get-templated-function-constructor 'iwmc-funcallable-class-accessor)
  534.     (slotd-name slotd)))
  535.  
  536. (defmethod make-iwmc-class-accessor-setf ((ignore funcallable-class) slotd)
  537.   (funcall
  538.     (get-templated-function-constructor 'iwmc-funcallable-class-accessor-setf
  539.                     (slotd-read-only slotd))
  540.     (slotd-name slotd)))
  541.  
  542.  
  543.   ;;   
  544. ;;;;;; 
  545.   ;;   
  546.  
  547. #|
  548.  
  549. (defclass generic-function (discriminator)
  550.   ((function #'(lambda (&rest ignore) ignore (error "foo")))
  551.    (name ())     
  552.    (methods ())
  553.    (discriminating-function ())
  554.    (cache ())
  555.    (dispatch-order ())
  556.    (method-combination-type ())
  557.    (method-combination-parameters ())
  558.    (methods-combine-p ()))
  559.   (:metaclass funcallable-class))
  560.  
  561. (defmeth install-discriminating-function ((gfun generic-function)
  562.                       where
  563.                       function
  564.                       &optional inhibit-compile-p)
  565.   (check-type where symbol "a symbol other than NIL")
  566.   (check-type function function "a funcallable object")
  567.   
  568.   (when (and (listp function)
  569.          (eq (car function) 'lambda)
  570.          (null inhibit-compile-p))
  571.     (setq function (compile nil function)))
  572.  
  573.   (setf (get-slot gfun 'function) function))
  574.  
  575. (defun convert-to-generic-functions ()
  576.   (let ((discriminators ()))
  577.     (do-symbols (s (find-package 'pcl))
  578.       (when (discriminator-named s) (push s discriminators)))
  579.  
  580.  
  581.     ))
  582.  
  583. (defun convert-generic-function (name)
  584.   (let ((discriminator (discriminator-named name))
  585.     (gfun (make 'generic-function)))
  586.     (setf (funcallable-instance-static-slots gfun)
  587.       (iwmc-class-static-slots discriminator))
  588.     (setf (funcallable-instance-dynamic-slots gfun)
  589.       (iwmc-class-dynamic-slots discriminator))
  590.     (install-discriminating-function gfun
  591.                      ()
  592.                      (symbol-function name))
  593.     (set name gfun)))
  594.  
  595.  
  596. (defclass bar ()
  597.   ((function nil)
  598.    (a 1)
  599.    (b 2))
  600.   (:metaclass funcallable-class))
  601.  
  602. (defclass foo ()
  603.   ((a nil)
  604.    (b nil)
  605.    (c nil))
  606.   (:metaclass funcallable-class))
  607.  
  608. |#
  609.  
  610.