;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This file contains the higher level support for funcallable instances.
;;;
(in-package 'pcl)
(eval-when (compile load eval)
(mapcar #'eval *fsc-defclass-forms*))
;;; By macroleting the definitions of:
;;; IWMC-CLASS-CLASS-WRAPPER
;;; IWMC-CLASS-STATIC-SLOTS
;;; IWMC-CLASS-DYNAMIC-SLOTS
;;; slot-value-using-class--class-internal ;These are kind of a
;;; put-slot-using-class--class-internal ;hack, solidfy this.
;;;
;;; we can use all the existing code for metaclass class.
;;;
(defmacro with-funcallable-standard-class-as-class ((instance checkp)
&body body)
(once-only (instance)
`(let ((.class. (funcallable-instance-p ,instance)))
,(and checkp
`(or .class.
(error "~S is not an instance with meta-class ~
funcallable-standard-class." ,instance)))
(macrolet ((iwmc-class-class-wrapper (instance)
`(funcallable-instance-wrapper ,instance))
(iwmc-class-static-slots (instance)
`(funcallable-instance-static-slots ,instance))
(iwmc-class-dynamic-slots (instance)
`(funcallable-instance-dynamic-slots ,instance))
(slot-value-using-class--class-internal
(class object slot-name
dont-call-slot-missing-p default)
`(with-slot-internal--class (,class ,object
,slot-name nil)
(:instance (index)
(get-static-slot--class ,object index))
(:dynamic (loc newp) (if (eq newp t)
(setf (car loc) ,default)
(car loc)))
(:class (slotd) (slotd-initform slotd))
(nil () (unless ,dont-call-slot-missing-p
(slot-missing ,object ,slot-name)))
))
(put-slot-using-class--class-internal
(class object slot-name new-value
dont-call-slot-missing-p)
`(with-slot-internal--class (,class ,object
,slot-name
,dont-call-slot-missing-p)
(:instance (index)
(setf (get-static-slot--class ,object
index)
,new-value))
(:dynamic (loc) (setf (car loc) ,new-value))
(:class (slotd) (setf (slotd-initform slotd)
,new-value))
(nil () (unless ,dont-call-slot-missing-p
(slot-missing ,object ,slot-name))))))
,@body))))
;;
;;;;;;
;;
(defmacro slot-value--funcallable-standard-class (class fsc-instance slot-name dont-call-slot-missing-p default)
(once-only (fsc-instance slot-name)
`(with-funcallable-standard-class-as-class (,fsc-instance t)
(slot-value-using-class--class ,class
,fsc-instance
,slot-name
,dont-call-slot-missing-p
,default))))
(defmacro put-slot--funcallable-standard-class (class
fsc-instance
slot-name
new-value
dont-call-slot-missing-p)
(once-only (fsc-instance slot-name)
`(with-funcallable-standard-class-as-class (,fsc-instance t)
;; Cheat a little bit here, its worth it.
,(if (constantp slot-name)
(if (eq (eval slot-name) 'function)
`(progn
(set-funcallable-instance-function ,fsc-instance
,new-value)
(put-slot-using-class--class ,class
,fsc-instance
,slot-name
,new-value
,dont-call-slot-missing-p))
`(put-slot-using-class--class ,class
,fsc-instance
,slot-name
,new-value
,dont-call-slot-missing-p))
`(if (eq ,slot-name 'function)
(progn (set-funcallable-instance-function ,fsc-instance
,new-value)
(put-slot-using-class--class ,class
,fsc-instance
,slot-name
,new-value
,dont-call-slot-missing-p))
(put-slot-using-class--class ,class
,fsc-instance
,slot-name
,new-value
,dont-call-slot-missing-p))))))
(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
(class class))
(declare (ignore fsc))
(null (class-instance-slots class)))
(defmethod slot-value-using-class ((class funcallable-standard-class)
instance
slot-name
&optional dont-call-slot-missing-p
default)
(slot-value--funcallable-standard-class
class instance slot-name dont-call-slot-missing-p default))
(defmethod put-slot-using-class ((class funcallable-standard-class)
instance
slot-name
new-value
&optional dont-call-slot-missing-p)
(put-slot--funcallable-standard-class
class instance slot-name new-value dont-call-slot-missing-p))
(defmethod allocate-instance ((class funcallable-standard-class))
(let ((class-wrapper (class-wrapper class)))
(if class-wrapper ;Are there any instances?
;; If there are instances, the class is OK, just go ahead and
;; make the instance.
(allocate-funcallable-instance class-wrapper
(class-no-of-instance-slots class))
;; Do first allocate-instance-time error-checking, build the class
;; wrapper and call ourselves again to really build the instance.
(progn
;; no first time error checking yet.
(setf (class-wrapper class) (make-class-wrapper class))
(allocate-instance class)))))
(defmethod make-reader-method-function ((class funcallable-standard-class)
slotd)
(declare (ignore class))
(funcall (get-templated-function-constructor 'get-function--fsc-class)
(slotd-name slotd)))
(defmethod make-writer-method-function ((class funcallable-standard-class)
slotd)
(declare (ignore class))
(funcall (get-templated-function-constructor 'set-function--fsc-class)
(slotd-name slotd)))
(define-function-template get-function--fsc-class () '(slot-name)
`(function
(lambda (instance--fsc-class)
(slot-value--funcallable-standard-class (class-of instance--fsc-class)
instance--fsc-class
slot-name
nil
nil))))
(define-function-template set-function--fsc-class () '(slot-name)
`(function
(lambda (instance--fsc-class new-value)
(put-slot--funcallable-standard-class (class-of instance--fsc-class)
instance--fsc-class
slot-name
new-value
nil))))
(eval-when (load)
(pre-make-templated-function-constructor get-function--fsc-class)
(pre-make-templated-function-constructor set-function--fsc-class))
(defmethod make-type-predicate ((class funcallable-standard-class))
(funcall (get-templated-function-constructor 'type-predicate--fsc-class)
class))
(define-function-template type-predicate--fsc-class () '(class)
'(function (lambda (x)
(and (funcallable-instance-p x)
(memq class
(class-precedence-list
(funcallable-instance-class x)))))))
(eval-when (load)
(pre-make-templated-function-constructor type-predicate--fsc-class))
(defmethod all-slots-using-class ((class funcallable-standard-class) object)
(append (iterate ((slotd in (class-instance-slots class)))
(collect (slotd-name slotd))
(collect (slot-value object (slotd-name slotd))))
(funcallable-instance-dynamic-slots object)))