home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part01 / trapd.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  2.3 KB  |  65 lines
  1. ;;; -*- Mode:LISP; Package:(PCL LISP 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. ;;; Trapped discriminators.
  27. ;;;
  28. ;;; These allow someone to declare that for a given selector, the methods
  29. ;;; should actually be defined on some other selector, the so-called trap-
  30. ;;; selector.
  31. ;;;
  32. ;;; An example of its use is:
  33. ;;;   (make-primitive-specializable 'car 'car-trap)
  34. ;;;
  35.  
  36. (in-package 'pcl)
  37.  
  38. (ndefstruct (trapped-discriminator-mixin
  39.           (:class class)
  40.           (:include discriminator)
  41.           (:conc-name trapped-discriminator-))
  42.   (trap-discriminator ()))
  43.  
  44. (defmeth trapped-discriminator-selector ((self trapped-discriminator-mixin))
  45.   (let ((td (trapped-discriminator-trap-discriminator self)))
  46.     (and td (discriminator-name td))))    
  47.  
  48. (defmeth add-method-internal ((self trapped-discriminator-mixin)
  49.                   (method basic-method))
  50.   (with (self) (add-method-internal trap-discriminator method)))
  51.  
  52. (ndefstruct (trapped-discriminator
  53.           (:class class)
  54.           (:include (trapped-discriminator-mixin discriminator))))
  55.  
  56. (defun make-primitive-specializable (name trap-selector &rest options)
  57.   (let ((trap-discriminator
  58.       (apply #'make-specializable trap-selector arglist)))
  59.     (setf (discriminator-named name)
  60.       (make 'trapped-discriminator
  61.         :name name
  62.         :trap-discriminator trap-discriminator))))
  63.  
  64.  
  65.