home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part02 / co-macros.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  6.9 KB  |  241 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;
  3. ; File:         co-macros.l
  4. ; RCS:          $Revision: 1.1 $
  5. ; SCCS:         %A% %G% %U%
  6. ; Description:  Macros used by Interface For CommonObjects
  7. ;               with co parser in CL.
  8. ; Author:       James Kempf, HP/DCC
  9. ; Created:      31-Jul-86
  10. ; Modified:     11-Mar-87 22:22:44 (James Kempf)
  11. ; Language:     Lisp
  12. ; Package:      COMMON-OBJECTS
  13. ; Status:       Distribution
  14. ;
  15. ; (c) Copyright 1987, HP Labs, all rights reserved.
  16. ;
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;
  19. ; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
  20. ;
  21. ; Use and copying of this software and preparation of derivative works based
  22. ; upon this software are permitted.  Any distribution of this software or
  23. ; derivative works must comply with all applicable United States export
  24. ; control laws.
  25. ; 
  26. ; This software is made available AS IS, and Hewlett-Packard Corporation makes
  27. ; no warranty about the software, its performance or its conformity to any
  28. ; specification.
  29. ;
  30. ; Suggestions, comments and requests for improvement may be mailed to
  31. ; aiws@hplabs.HP.COM
  32.  
  33. ;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
  34. ;;;
  35. ;;; *************************************************************************
  36. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  37. ;;;
  38. ;;; Use and copying of this software and preparation of derivative works
  39. ;;; based upon this software are permitted.  Any distribution of this
  40. ;;; software or derivative works must comply with all applicable United
  41. ;;; States export control laws.
  42. ;;; 
  43. ;;; This software is made available AS IS, and Xerox Corporation makes no
  44. ;;; warranty about the software, its performance or its conformity to any
  45. ;;; specification.
  46. ;;; 
  47. ;;; Any person obtaining a copy of this software is requested to send their
  48. ;;; name and post office or electronic mail address to:
  49. ;;;   CommonLoops Coordinator
  50. ;;;   Xerox Artifical Intelligence Systems
  51. ;;;   2400 Hanover St.
  52. ;;;   Palo Alto, CA 94303
  53. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  54. ;;;
  55. ;;; Suggestions, comments and requests for improvements are also welcome.
  56. ;;; *************************************************************************
  57.  
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ;  Preliminaries
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61.  
  62. ;;;The CommonObjects interface is in the COMMON-OBJECTS package. We need
  63. ;;;  both PCL and the CommonObjects parser, which is in the 
  64. ;;   COMMON-OBJECTS-PARSER package. Note that PCL is assumed to be
  65. ;;   loaded.
  66.  
  67. (provide "co-macros")
  68.  
  69. (in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
  70.  
  71. ;;Export these symbols. They are the only ones which clients should see.
  72.  
  73. (export
  74.   '(
  75.     make-instance
  76.     define-type
  77.     define-method
  78.     call-method
  79.     apply-method
  80.     assignedp
  81.     undefine-type
  82.     rename-type
  83.     undef Artifical Intelligence Systems
  84. ;;;   2400 Hanovration-p
  85.     send?
  86.     instance
  87.     import-specialized-functions
  88.   )
  89. )
  90.  
  91. ;;Need PCL and patches
  92.  
  93. (require "pcl")
  94. (require "pcl-patches")
  95.  
  96. ;;Need the parser
  97.  
  98. (require "co-parse")
  99.  
  100. ;;Use the parser's package
  101.  
  102. (use-package 'co-parser)
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;  Constant Definition
  106. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  107.  
  108. ;;;Need this flag to indicate that an instance variable is uninitialized.
  109.  
  110. (defconstant $UNINITIALIZED-VARIABLE-FLAG 'LISP::*UNDEFINED*)
  111.  
  112. ;;Offsets of important things in instances.
  113. ;;Location of class object.
  114.  
  115. (defconstant $CLASS-OBJECT-INDEX 0)
  116.  
  117. ;;Location of pointer to self.
  118.  
  119. (defconstant $SELF-INDEX 1)
  120.  
  121. ;;Starting index of parents.
  122.  
  123. (defconstant $START-OF-PARENTS 2)
  124.  
  125. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  126. ;  Special Variable Definition
  127. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  128.  
  129. ;;*special-functions-list*-Holds a list of uninterned symbols for TYPE-OF,
  130. ;;  TYPEP, EQL, EQUAL, and EQUALP. These symbols have their function cells
  131. ;;  bound to special functions which use CommonObjects messaging if the
  132. ;;  argument is a CommonObjects object.
  133.  
  134. (defvar *special-functions-list*
  135.   (list
  136.     (cons ':type-of (make-symbol "TYPE-OF"))
  137.     (cons ':typep (make-symbol "TYPEP"))
  138.     (cons ':eql (make-symbol "EQL"))
  139.     (cons ':equal (make-symbol "EQUAL"))
  140.     (cons ':equalp (make-symbol "EQUALP"))
  141.   )
  142. )
  143.  
  144. ;;*universal-methods*-List of universal methods
  145.  
  146. (defvar *universal-methods*
  147.   '(
  148.     :init
  149.     :initialize
  150.     :print
  151.     :describe
  152.     :eql
  153.     :equal
  154.     :equalp
  155.     :typep
  156.     :copy
  157.     :copy-instance
  158.     :copy-state 
  159.   )
  160. )
  161.  
  162. ;;*universal-method-selectors*-List of selectors for universal
  163. ;;  methods
  164.  
  165. (defvar *universal-method-selectors* NIL)
  166.  
  167. ;;*keyword-standin-package*-Package for interning methods as functions.
  168. ;;  CommonObjects "encourages" the use of keywords as method names,
  169. ;;  but not all CL's allow keyword symbol function cells to be
  170. ;;  occupied.
  171.  
  172. (eval-when (compile load eval)
  173.   (defvar *keyword-standin-package* 
  174.     (or (find-package 'keyword-standin) (make-package 'keyword-standin))
  175.   )
  176. )
  177.  
  178. ;;;Unuse the lisp package in the keyword-standin package, to
  179. ;;;  avoid conflicts with named functions.
  180.  
  181. (unuse-package 'lisp *keyword-standin-package*)
  182.  
  183. ;;*special-method-symbols*-List of special method symbols which 
  184. ;;  shouldn't go into the keyword-standin package, paired with
  185. ;;  their method names.
  186.  
  187. (defvar *special-method-symbols* 
  188.   (list
  189.       (cons ':print 'print-instance)
  190.   )
  191. )
  192.  
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194. ; 
  195. ;    Support for Using Keywords as Method Names
  196. ;
  197. ;  These macros and functions translate keyword method names into
  198. ;  names in a package. Some Common Lisps do allow keyword symbols
  199. ;  to have an associated function, others don't. Rather than
  200. ;  differentiating, a single package, KEYWORD-STANDIN, is used
  201. ;  for method symbols which are keywords.
  202. ;
  203. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  204.  
  205. ;;special-keyword-p-Return T if the keyword is a special method
  206. ;;  symbol.
  207.  
  208. (defmacro special-keyword-p (keyword)
  209.   `(assoc ,keyword *special-method-symbols* :test #'eq)
  210.  
  211. ) ;end special-keyword-p
  212.  
  213. ;;keyword-standin-special-Return the special symbol for this
  214. ;;  keyword.
  215.  
  216. (defmacro keyword-standin-special (keyword)
  217.   `(cdr (assoc ,keyword *special-method-symbols* :test #'eq))
  218.  
  219. ) ;end keyword-standin-special
  220.  
  221. ;;special-method-p-Return T if the symbol is a special method
  222. ;;  symbol.
  223.  
  224. (defmacro special-method-p (symbol)
  225.   `(rassoc ,symbol *special-method-symbols* :test #'eq)
  226.  
  227. ) ;end special-method-p
  228.  
  229. ;;unkeyword-standin-special-Return the keyword for this
  230. ;;  special method
  231.  
  232. (defmacro unkeyword-standin-special (symbol)
  233.   `(car (rassoc ,symbol *special-method-symbols* :test #'eq))
  234.  
  235. ) ;end unkeyword-standin-special
  236.  
  237. ;;keyword-standin-Get a standin symbol for a keyword
  238.  
  239. ;;; end of co-macros.l ;;;;;
  240.  
  241.