home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part01 / compat.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  1.9 KB  |  57 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. (defmacro run-super () '(call-next-method))
  30.  
  31.  
  32. (defun convert-with-first-arg (first-arg use-slot-value)
  33.   (iterate ((opc in first-arg))
  34.     (or (listp opc) (setq opc (list opc)))
  35.     (collect
  36.       ;; Can't use the obvious backquote in Genera!
  37.       (let ((entry ()))
  38.     (when use-slot-value
  39.       (push t entry)
  40.       (push :use-slot-value entry))
  41.     (when (cddr opc)
  42.       (push (caddr opc) entry)
  43.       (push :class entry))
  44.     (when (cadr opc)
  45.       (push (cadr opc) entry)
  46.       (push :prefix entry))
  47.     (cons (car opc) entry)))))
  48.  
  49. (defmacro with (objects-prefixes-and-classes &body body)
  50.   `(with-slots ,(convert-with-first-arg objects-prefixes-and-classes nil)
  51.      . ,body))
  52.  
  53. (defmacro with* (objects-prefixes-and-classes &body body)
  54.   `(with-slots ,(convert-with-first-arg objects-prefixes-and-classes t)
  55.      . ,body))
  56.  
  57.