home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part03 / fixup.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  12.5 KB  |  358 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
  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. (in-package 'pcl)
  28.  
  29. (eval-when (compile load eval)
  30.   (setq *real-methods-exist-p* nil)
  31.   (setf (symbol-function 'expand-defmeth)
  32.     (symbol-function 'real-expand-defmeth)))
  33.  
  34. (eval-when (load)
  35.   (clrhash *discriminator-name-hash-table*)
  36.   (fix-early-defmeths)
  37.  ;; This now happens at the end of loading HIGH to make it
  38.  ;; possible to compile and load pcl in the same environment.
  39.  ;(setq *error-when-defining-method-on-existing-function* t)
  40.   )
  41.  
  42. (eval-when (compile load eval)
  43.   (setq *real-methods-exist-p* t))
  44.  
  45.   ;;   
  46. ;;;;;; Pending defmeths which I couldn't do before.
  47.   ;;
  48.  
  49.  
  50. (eval-when (load eval)
  51.   (setf (discriminator-named 'print-instance) ())
  52.   (make-specializable 'print-instance :arglist '(instance stream depth)))
  53.  
  54. (defmeth print-instance ((instance object) stream depth)
  55.   (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
  56.     (format stream "#S(~S" (class-name (class-of instance)))
  57.     (iterate ((slot-or-value in (all-slots instance))
  58.           (slotp = t (not slotp)))
  59.       (when (numberp length)
  60.     (cond ((<= length 0) (format stream " ...") (return ()))
  61.           (t (decf length))))
  62.       (princ " " stream)
  63.       (let ((*print-level* (cond ((null *print-level*) ())
  64.                  (slotp 1)
  65.                  (t (- *print-level* depth)))))
  66.     (if (and *print-level* (<= *print-level* 0))
  67.         (princ "#" stream)
  68.         (prin1 slot-or-value stream))))
  69.     (princ ")" stream)))
  70.  
  71. (defmeth print-instance ((class essential-class) stream depth)
  72.   (named-object-print-function class stream depth))
  73.  
  74.  
  75. (defmethod print-instance ((method essential-method) stream depth)
  76.   (ignore depth)
  77.   (printing-random-thing (method stream)
  78.     (let ((discriminator (method-discriminator method))
  79.       (class-name (capitalize-words (class-name (class-of method)))))
  80.       (format stream "~A ~S ~:S"
  81.           class-name
  82.           (and discriminator (discriminator-name discriminator))
  83.           (method-type-specifiers method)))))
  84.  
  85. (defmethod print-instance ((method basic-method) stream depth)
  86.   (ignore depth)
  87.   (printing-random-thing (method stream)
  88.     (let ((discriminator (method-discriminator method))
  89.       (class-name (capitalize-words (class-name (class-of method)))))
  90.       (format stream "~A ~S ~:S"
  91.           class-name
  92.           (and discriminator (discriminator-name discriminator))
  93.           (unparse-type-specifiers method)))))
  94.  
  95. (defmethod print-instance ((discriminator essential-discriminator) stream depth)
  96.   (named-object-print-function discriminator stream depth))
  97.  
  98. (defmethod print-instance ((discriminator basic-discriminator) stream depth)
  99.   (named-object-print-function
  100.     discriminator stream depth (list (method-combination-type discriminator))))
  101.  
  102. (eval-when (load)
  103.  
  104. (define-meta-class essential-class (lambda (x) (%instance-ref x 0)))
  105.  
  106. (defmeth class-slots ((class essential-class))
  107.   (ignore class)
  108.   ())
  109.  
  110. (defmeth make-instance ((class essential-class))
  111.   (let ((primitive-instance
  112.       (%make-instance (class-named 'esfiers method)))))
  113.  
  114. (defmethod print-instance ((mss))))))
  115.     (setf (%instance-ref primitive-instance 0) class)
  116.     primitive-instance))
  117.  
  118. (defmeth get-slot-using-class ((class essential-class) object slot-name)
  119.   (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
  120.     (if pos
  121.     (%instance-ref object (1+ pos))
  122.     (slot-missing ;class
  123.       object slot-name))))
  124.  
  125. (defmeth put-slot-using-class ((class essential-class)
  126.                    object
  127.                    slot-name
  128.                    new-value)
  129.   (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
  130.     (if pos
  131.     (setf (%instance-ref object (1+ pos)) new-value)
  132.     (slot-missing ;class
  133.               object slot-name))))
  134.  
  135. (defmeth optimize-get-slot (class form)
  136.   (declare (ignore class))
  137.   form)
  138.  
  139. (defmeth optimize-setf-of-get-slot (class form)
  140.   (declare (ignore class))
  141.   form)
  142.  
  143. (defmeth make-slotd ((class essential-class) &rest keywords-and-options)
  144.   (ignore class)
  145.   (apply #'make-slotd--essential-class keywords-and-options))
  146.  
  147. (defmeth add-named-class ((proto-class essential-class) name
  148.               local-supers
  149.               local-slot-slotds
  150.               extra)
  151.   ;; First find out if there is already a class with this name.
  152.   ;; If there is, call class-for-redefinition to get the class
  153.   ;; object to use for the new definition.  If there is no exisiting
  154.   ;; class we just make a new instance.
  155.   (let* ((existing (class-named name t))
  156.      (class (if existing
  157.             (class-for-redefinition existing proto-class name 
  158.                         local-supers local-slot-slotds
  159.                         extra)
  160.             (make (class-of proto-class)))))
  161.  
  162.     (setq local-supers
  163.       (mapcar
  164.         #'(lambda (ls)
  165.         (or (class-named ls t)
  166.             (error "~S was specified as the name of a local-super~%~
  167.                             for the class named ~S.  But there is no class~%~
  168.                             class named ~S." ls name ls)))
  169.         local-supers))
  170.     
  171.     (setf (class-name class) name)
  172. ;   (setf (class-ds-options class) extra)    ;This is NOT part of the
  173. ;                        ;standard protocol.
  174.    
  175.     (add-class class local-supers local-slot-slotds extra)
  176.     
  177.     (setf (class-named name) class)
  178.     name))
  179.  
  180. (defmeth supers-changed ((class essential-class)
  181.              old-local-supers
  182.              old-local-slots
  183.              extra
  184.              top-p)
  185.   (ignore old-local-supers old-local-slots top-p)
  186.   (let ((cpl (compute-class-precedence-list class)))
  187.     (setf (class-class-precedence-list class) cpl)
  188. ;   (update-slots--class class cpl)                 ;This is NOT part of
  189. ;                                 ;the essential-class
  190. ;                                 ;protocol.
  191.     (dolist (sub-class (class-direct-subclasses class))
  192.       (supers-changed sub-class
  193.               (class-local-supers sub-class)
  194.               (class-local-slots sub-class)
  195.               extra
  196.               nil))
  197. ;   (when top-p                                          ;This is NOT part of
  198. ;     (update-method-inheritance class old-local-supers));the essential-class
  199. ;                                      ;protocol.
  200.     ))
  201.  
  202. (defmeth slots-changed ((class essential-class)
  203.             old-local-slots
  204.             extra
  205.             top-p)
  206.   (ignore top-p old-local-slots)
  207.   ;; When this is called, class should have its local-supers and
  208.   ;; local-slots slots filled in properly.
  209. ; (update-slots--class class (class-class-precedence-list class))
  210.   (dolist (sub-class (class-direct-subclasses class))
  211.     (slots-changed sub-class (class-local-slots sub-class) extra nil)))
  212.  
  213. (defmeth method-equal (method argument-specifiers options)
  214.   (ignore options)
  215.   (equal argument-specifiers (method-type-specifiers method)))
  216.  
  217. (defmeth methods-combine-p ((d essential-discriminator))
  218.   (ignore d)
  219.   nil)
  220.  
  221. )
  222.  
  223.   ;;   
  224. ;;;;;; 
  225.   ;;
  226.  
  227. (define-method-body-macro call-next-method ()
  228.   :global :error
  229.   :method (expand-call-next-method
  230.         (macroexpand-time-method macroexpand-time-environment)
  231.         nil
  232.         macroexpand-time-environment))
  233.  
  234. (defmethod expand-call-next-method ((mex-method method) args mti)
  235.   (ignore args)
  236.   (let* ((arglist (and mex-method (method-arglist mex-method)))
  237.      (uid (macroexpand-time-method-uid mti))
  238.      (load-method-1-args (macroexpand-time-load-method-1-args mti))
  239.      (load-time-eval-form `(load-time-eval
  240.                  (if (boundp ',uid)
  241.                      ,uid
  242.                      (setq ,uid
  243.                        (apply #'load-method-1
  244.                           ',load-method-1-args)))))
  245.      (applyp nil))
  246.     (multiple-value-setq (arglist applyp) (make-call-arguments arglist))
  247.     (cond ((null (method-type-specifiers mex-method))
  248.        (warn "Using call-next-method in a default method.~%~
  249.                   At run time this will generate an error.")
  250.        '(error "Using call-next-method in a default method."))
  251.       (applyp
  252.        `(apply
  253.           #'call-next-method-internal ,load-time-eval-form . ,arglist))
  254.       (t
  255.        `(call-next-method-internal ,load-time-eval-form . ,arglist)))))
  256.  
  257. (defun call-next-method-internal (current-method &rest args)
  258.   (let* ((discriminator (method-discriminator current-method))
  259.      (type-specifiers (method-type-specifiers current-method))
  260.      (most-specific nil)
  261.      (most-specific-type-specifiers ())
  262.      (dispatch-order (get-slot--class discriminator 'dispatch-order)))
  263.     (iterate ((method in (discriminator-methods discriminator)))
  264.       (let ((method-type-specifiers (method-type-specifiers method))
  265.             (temp ()))
  266.         (and (every #'(lambda (arg type-spec)
  267.             (or (eq type-spec 't)
  268.                 (memq type-spec
  269.                   (get-slot--class
  270.                     (class-of arg) 'class-precedence-list))))
  271.                     args method-type-specifiers)
  272.              (eql 1 (setq temp (compare-type-specifier-lists
  273.                  type-specifiers
  274.                  method-type-specifiers
  275.                  ()
  276.                  args
  277.                  ()
  278.                  dispatch-order)))
  279.              (or (null most-specific)
  280.                  (eql 1 (setq temp (compare-type-specifier-lists
  281.                                      method-type-specifiers
  282.                                      most-specific-type-specifiers
  283.                                      ()
  284.                                      args
  285.                                      ()
  286.                      dispatch-order))))
  287.              (setq most-specific method
  288.                    most-specific-type-specifiers method-type-specifiers))))
  289.     (if (or most-specific
  290.             (setq most-specific (discriminator-default-method
  291.                   discriminator)))
  292.         (apply (method-function most-specific) args)
  293.         (error "no super method found"))))
  294.  
  295. ;;;
  296. ;;; This is kind of bozoid because it always copies the lambda-list even
  297. ;;; when it doesn't need to.  It also doesn't remember things it could
  298. ;;; remember, causing it to call memq more than it should.  Fix this one
  299. ;;; day when there is nothing else to do.
  300. ;;; 
  301. (defun make-call-arguments (lambda-list &aux applyp)
  302.   (setq lambda-list (reverse lambda-list))
  303.   (when (memq '&aux lambda-list)
  304.     (setq lambda-list (cdr (memq '&aux lambda-list))))
  305.   (setq lambda-list (nreverse lambda-list))
  306.   (let ((optional (memq '&optional lambda-list)))
  307.     (when optional
  308.       ;; The &optional keyword appears in the lambda list.
  309.       ;; Get rid of it, by moving the rest of the lambda list
  310.       ;; up, then go through the optional arguments, replacing
  311.       ;; them with the real symbol.
  312.       (setf (car optional) (cadr optional)
  313.         (cdr optional) (cddr optional))
  314.       (iterate ((loc on optional))
  315.     (when (memq (car loc) lambda-list-keywords)
  316.       (unless (memq (car loc) '(&rest &key &allow-other-keys))
  317.         (error
  318.           "The non-standard lambda list keyword ~S appeared in the~%~
  319.                lambda list of a method in which CALL-NEXT-METHOD is used.~%~
  320.                PCL can only deal with standard lambda list keywords."))
  321.       (when (listp (car loc)) (setf (car loc) (caar loc)))))))
  322.   (let ((rest (memq '&rest lambda-list)))
  323.     (cond ((not (null rest))
  324.        ;; &rest appears in the lambda list. This means we
  325.        ;; have to do an apply. We ignore the rest of the
  326.        ;; lambda list, just grab the &rest var and set applyp.
  327.        (setf (car rest) (if (listp (cadr rest))
  328.                 (caadr rest)
  329.                 (cadr rest))
  330.          (cdr rest) ())
  331.        (setq applyp t))
  332.       (t
  333.        (let ((key (memq '&key lambda-list)))
  334.          (when key
  335.            ;; &key appears in the lambda list.  Remove &key from the
  336.            ;; lambda list then replace all the keywords with pairs of
  337.            ;; the actual keyword followed by the value variable.
  338.            ;; Have to parse the hairy triple case of &key.
  339.            (let ((key-args
  340.                (iterate ((arg in (cdr key)))
  341.              (until (eq arg '&allow-other-keys))
  342.              (cond ((symbolp arg)
  343.                 (collect (make-keyword arg))
  344.                 (collect arg))
  345.                    ((cddr arg)
  346.                 (collect (caddr arg))
  347.                 (collect (car arg)))
  348.                    (t
  349.                 (collect (make-keyword (car arg)))
  350.                 (collect (car arg)))))))
  351.          (if key-args
  352.              (setf (car key) (car key-args)
  353.                (cdr key) (cdr key-args))
  354.              (setf (cdr key) nil
  355.                lambda-list (remove '&key lambda-list)))))))))
  356.   (values lambda-list applyp))
  357.  
  358.