home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part02 / dfun-templ.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  7.2 KB  |  206 lines
  1. ;;;-*-Mode:LISP; Package: PCL; 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. (in-package 'pcl)
  28.  
  29.  
  30. ;;; 
  31. ;;; A caching discriminating function looks like:
  32. ;;;   (lambda (arg-1 arg-2 arg-3 &rest rest-args)
  33. ;;;     (prog* ((class-1 (class-of arg-1))
  34. ;;;             (class-2 (class-of arg-2))
  35. ;;;             method-function)
  36. ;;;        (and (cached-method method-function CACHE MASK class-1 class-2)
  37. ;;;             (go hit))
  38. ;;;      miss
  39. ;;;        (setq method-function
  40. ;;;              (cache-method DISCRIMINATOR
  41. ;;;                            (lookup-method-function DISCRIMINATOR
  42. ;;;                                                    class-1
  43. ;;;                                                    class-2)))
  44. ;;;      hit
  45. ;;;        (if method-function
  46. ;;;            (return (apply method-function arg-1 arg-2 arg-3 rest-args))
  47. ;;;            (return (no-matching-method DISCRIMINATOR)))))
  48. ;;;
  49. ;;; The upper-cased variables are the ones which are lexically bound.
  50.  
  51. ;;; There is a great deal of room to play here.  This open codes the
  52. ;;; test to see if the instance is iwmc-class-p.  Only if it isn't is
  53. ;;; there a function call to class-of.  This is done because we only have
  54. ;;; a default implementation of make-discriminating-function, we don't
  55. ;;; have one which is specific to discriminator-class DISCRIMINATOR and
  56. ;;; meta-class CLASS.
  57. ;;;
  58. ;;; Of course a real implementation of CommonLoops wouldn't even do a
  59. ;;; real function call to get to the discriminating function.
  60.  
  61. (eval-when (compile load eval)
  62.  
  63. (defun default-make-class-of-form-fn (arg)
  64.   `(if (iwmc-class-p ,arg)
  65.        (class-of--class ,arg)
  66.        (class-of ,arg)))
  67.  
  68. (defvar *make-class-of-form-fn* #'default-make-class-of-form-fn)
  69.  
  70. (define-function-template caching-discriminating-function
  71.                           (required restp
  72.                     specialized-positions
  73.                     lookup-function)
  74.                           '(.DISCRIMINATOR. .CACHE. .MASK.)
  75.   (let* ((args (iterate ((i from 0 below required))
  76.                  (collect (make-symbol (format nil "Disc-Fn-Arg ~D" i)))))
  77.          (class-bindings
  78.            (iterate ((i from 0 below required)
  79.                      (ignore in specialized-positions))
  80.              (if (member i specialized-positions)
  81.                  (collect
  82.            (list (make-symbol (format nil "Class of ARG ~D" i))
  83.              (funcall *make-class-of-form-fn* (nth i args))))
  84.                  (collect nil))))
  85.          (classes (remove nil (mapcar #'car class-bindings)))
  86.          (method-function-var (make-symbol "Method Function"))
  87.          (rest-arg-var (and restp (make-symbol "Disc-Fn-&Rest-Arg"))))
  88.     `(function
  89.        (lambda (,@args ,@(and rest-arg-var (list '&rest rest-arg-var)))
  90.          (prog (,@(remove nil class-bindings) ,method-function-var)
  91.        (and (cached-method ,method-function-var .CACHE. .MASK. ,@classes)
  92.         (go hit))
  93.       ;miss
  94.        (setq ,method-function-var
  95.          (cache-method .CACHE.
  96.                    .MASK.
  97.                    (,lookup-function .DISCRIMINATOR.
  98.                          ,@(mapcar #'car
  99.                                class-bindings))
  100.                    ,@classes))
  101.        hit
  102.        (if ,method-function-var
  103.            (return ,(if restp
  104.                 `(apply ,method-function-var
  105.                     ,@args
  106.                     ,rest-arg-var)
  107.                 `(funcall ,method-function-var ,@args)))
  108.            (no-matching-method .DISCRIMINATOR.)))))))
  109. )
  110.  
  111. (eval-when (compile)
  112. (defmacro pre-make-caching-discriminating-functions (specs)
  113.   `(progn . ,(iterate ((spec in specs))
  114.            (collect `(pre-make-templated-function-constructor
  115.                caching-discriminating-function
  116.                ,@spec))))))
  117.  
  118. (eval-when (load)
  119.   (pre-make-caching-discriminating-functions
  120.     ((2 NIL (0 1) LOOKUP-MULTI-METHOD)
  121.      (4 NIL (0) LOOKUP-CLASSICAL-METHOD)
  122.      (5 NIL (0) LOOKUP-CLASSICAL-METHOD)
  123.      (1 T (0) LOOKUP-CLASSICAL-METHOD)
  124.      (3 NIL (0 1) LOOKUP-MULTI-METHOD)
  125.      (4 T (0) LOOKUP-CLASSICAL-METHOD)
  126.      (3 T (0) LOOKUP-CLASSICAL-METHOD)
  127.      (3 NIL (0) LOOKUP-CLASSICAL-METHOD)
  128.      (1 NIL (0) LOOKUP-CLASSICAL-METHOD)
  129.      (2 NIL (0) LOOKUP-CLASSICAL-METHOD))))
  130.  
  131.   ;;   
  132. ;;;;;; 
  133.   ;;
  134.  
  135. (eval-when (compile load eval)
  136.  
  137. (define-function-template checking-discriminating-function
  138.     (required restp defaultp checks)
  139.     `(discriminator method-function default-function
  140.             ,@(make-checking-discriminating-function-1 checks))
  141.   (let* ((arglist (make-discriminating-function-arglist required restp)))
  142.     `(function
  143.        (lambda ,arglist
  144.      (declare (optimize (speed 3) (safety 0)))
  145.      discriminator default-function ;ignorable
  146.          (if (and ,@(iterate ((check in
  147.                      (make-checking-discriminating-function-1
  148.                        checks))
  149.                               (arg in arglist))
  150.                       (when (neq check 'ignore)
  151.             (collect
  152.               `(memq ,check
  153.                  (let ((.class. (class-of ,arg)))
  154.                    (get-slot--class .class.
  155.                             'class-precedence-list)))))))
  156.              ,(if restp
  157.                   `(apply method-function ,@(remove '&rest arglist))
  158.                   `(funcall method-function ,@arglist))
  159.              ,(if defaultp
  160.                   (if restp
  161.                       `(apply default-function ,@(remove '&rest arglist))
  162.                       `(funcall default-function ,@arglist))
  163.                   `(no-matching-method discriminator)))))))
  164.  
  165. (defun make-checking-discriminating-function-1 (check-positions)
  166.   (iterate ((pos in check-positions))
  167.     (collect (if (null pos) 'ignore (intern (format nil "Check ~D" pos))))))
  168.  
  169. )
  170.  
  171. (eval-when (compile)
  172. (defmacro pre-make-checking-discriminating-functions (specs)
  173.   `(progn . ,(iterate ((spec in specs))
  174.            (collect `(pre-make-templated-function-constructor
  175.                checking-discriminating-function
  176.                ,@spec))))))
  177.  
  178. (eval-when (load)
  179.   (pre-make-checking-discriminating-functions ((3 NIL NIL (0 1))
  180.                            (7 NIL NIL (0 1))
  181.                            (5 NIL NIL (0 1))
  182.                            (3 NIL NIL (0 NIL 2))
  183.                            (6 NIL NIL (0))
  184.                            (5 NIL NIL (0))
  185.                            (4 T NIL (0))
  186.                            (3 T NIL (0))
  187.                            (1 T NIL (0))
  188.                            (4 NIL NIL (0))
  189.                            (3 NIL NIL (0))
  190.                            (3 NIL T (0 1))
  191.                            (2 NIL T (0))
  192.                            (5 NIL T (0 1))
  193.                            (1 T T (0))
  194.                            (1 NIL T (0))
  195.                            (2 NIL T (0 1))
  196.                            (3 NIL T (0))
  197.                            (2 T T (0))
  198.                            (6 NIL T (0 1))
  199.                            (3 NIL T (0 NIL 2))
  200.                            (4 NIL T (0 1))
  201.                            (4 NIL T (0))
  202.                            (5 NIL T (0))
  203.                            (1 NIL NIL (0))
  204.                            (2 NIL NIL (0)))))
  205.  
  206.