LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032831. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "FSC" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388119. :AUTHOR "REL3" :LENGTH-IN-BYTES 7866. :LENGTH-IN-BLOCKS 8. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ;;;-*-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);;; By macroleting the definitions of:;;;   IWMC-CLASS-CLASS-WRAPPER;;;   IWMC-CLASS-STATIC-SLOTS;;;   IWMC-CLASS-DYNAMIC-SLOTS;;;   get-slot-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))  (get-slot-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 get-slot--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)       (get-slot-using-class--class ,class    ,fsc-instance    ,slot-name    ,dont-call-slot-missing-p    ,default))))(defmacro put-slot--funcallable-standard-class (classfsc-instanceslot-namenew-valuedont-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))))))(defclass funcallable-standard-class (class)  ())(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)(class class))  (declare (ignore fsc))  (null (class-instance-slots class)))(defmethod get-slot-using-class ((class funcallable-standard-class) instance slot-name &optional dont-call-slot-missing-p   default)  (get-slot--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 make-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.(make-funcallable-instance class-wrapper   (class-no-of-instance-slots class))        ;; Do first make-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))          (make-instance class)))))(defmethod make-get-function ((class funcallable-standard-class) slotd)  (declare (ignore class))  (funcall (get-templated-function-constructor 'get-function--fsc-class)   (slotd-name slotd)))(defmethod make-set-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)       (get-slot--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 (new-value instance--fsc-class)       (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 do-type-predicate-definition   ((class funcallable-standard-class) name)  (setf (symbol-function (type-predicate-name name))(funcall  (get-templated-function-constructor 'type-predicate--fsc-class)  name)))(define-function-template type-predicate--fsc-class () '(class-name)  '(function (lambda (x)       (and (funcallable-instance-p x)    (memq (class-named class-name)  (class-precedence-list    (funcallable-instance-class x)))))))(eval-when (load)  (pre-make-templated-function-constructor type-predicate--fsc-class))and-time-method-uid mti)) (load-method-1-args (macroexpand-time-load-method-1-args mti)) (load-time-eval-form `(load-time-eval (if (boundp ',uid)     ,uid     (setq ,uid   (apply #'load-method-1  ',load-method-1-args))))) (applyp nil))    (multiple-value-setq (arglist applyp) (make-call-arg