home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part02 / pcl-patches.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  6.3 KB  |  254 lines
  1.  
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         pcl-patches.l
  5. ; RCS:          $Revision: 1.1 $
  6. ; SCCS:         %A% %G% %U%
  7. ; Description:  Patches to Released PCL so CommonObjects works
  8. ; Author:       James Kempf, HP/DCC
  9. ; Created:      11-Nov-86
  10. ; Modified:     5-Mar-87 08:04:02 (James Kempf)
  11. ; Language:     Lisp
  12. ; Package:      PCL
  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. ;;Need the PCL module
  34.  
  35. (require "pcl")
  36.  
  37. (in-package 'pcl)
  38. (use-package 'lisp)
  39.  
  40. ;;These symbols are needed by CommonObjects
  41.  
  42. (export
  43.   '(
  44.     print-instance
  45.     make-specializable
  46.     rename-class
  47.     call-next-method
  48.     expand-with-make-entries
  49.     method-type-specifiers
  50.     method-arglist
  51.   )
  52. )
  53.  
  54. ;;Note-Every implementation of CL will need to add the
  55. ;;  check for nonatomic type specifiers.
  56.  
  57. #+HP(setq *class-of*
  58.     '(lambda (x) 
  59.        (cond ((%instancep x)
  60.           (%instance-class-of x))
  61.          ;; Ports of PCL should define the rest of class-of
  62.          ;; more meaningfully.  Because of the underspecification
  63.                  ;; of type-of this is the best that I can do.
  64.          ((null x)
  65.                   (class-named 'null))
  66.                  ((stringp x)
  67.                   (class-named 'string))
  68.          ((characterp x)
  69.           (class-named 'character))
  70.          (t
  71.           (or (class-named (atom-type-of (type-of x)) t)
  72.               (error "Can't determine class of ~S." x)
  73.           ))
  74.             )
  75.         )
  76. )
  77.  
  78. #+ExCL(eval-when (load)
  79.   (setq *class-of*
  80.     '(lambda (x) 
  81.        (or (and (%instancep x)
  82.             (%instance-class-of x))           
  83.           ;(%funcallable-instance-p x)
  84.            (and (stringp x) (class-named 'string))
  85.            (class-named (type-of x) t)
  86.            (error "Can't determine class of ~S." x)))
  87.   )
  88.  
  89. )
  90.  
  91. ;;Now arrange things so CLASS-OF gets recompiled when this file gets
  92. ;;  loaded
  93.  
  94. #-KCL(eval-when (load eval)
  95.  
  96.   (recompile-class-of)
  97.  
  98. )
  99.  
  100. ;;atom-type-of-Return principle type. This is the first
  101. ;;  item on the type specifier list, or specifier itself,
  102. ;;  if the specifier is atomic.
  103.  
  104. (defun atom-type-of (x)
  105.  
  106.   (if (listp x)
  107.     (car x)
  108.     x
  109.   )
  110.  
  111. ) ;end atom-type-of
  112.  
  113. ;;
  114. ;;
  115. ;;
  116. ;;
  117. ;; Default print-instance method
  118. ;;
  119. ;;
  120. ;;
  121.  
  122. (defmeth print-instance (instance stream depth) 
  123.   (printing-random-thing (instance stream)    
  124.     (format stream "instance ??")))
  125.  
  126. ;;;New for CO
  127.  
  128.  
  129. ;;rename-class-Find the class object named old-name and rename to
  130. ;;  new-name
  131.  
  132. (defmeth rename-class ((old-name symbol) (new-name symbol))
  133.  
  134.   (rename-class (class-named old-name) new-name)
  135.  
  136. ) ;end rename-class
  137.  
  138.  
  139. ;;rename-class-Change the name of the essential class's name to name
  140.  
  141. (defmeth rename-class ((class essential-class) (name symbol))
  142.  
  143.   (let
  144.     (
  145.       (old-name (class-name class))
  146.     )
  147.  
  148.  
  149.     (setf (class-name class) name)
  150.  
  151.     ;;Needed to be sure the naming hash table is OK
  152.  
  153.     (setf (class-named name) class)
  154.     (setf (class-named old-name) NIL)
  155.     name
  156.   )
  157.  
  158. ) ;end rename-class
  159.  
  160.  
  161. ;;
  162. ;;
  163. ;;
  164. ;; From class-prot.l
  165. ;;
  166. ;;
  167. ;;
  168.  
  169. ;;JAK 2/15/86 Additional bug. OPTIMIZE-GET-SLOT and OPTIMIZE-SETF-OF
  170. ;;  GET-SLOT didn't seem to be getting called. This version calls
  171. ;;  them. NOTE-this has been added to CLASS-PROT.L so that the
  172. ;;  optimization functions get called in the kernel as well.
  173.  
  174. (defun expand-with-slots
  175.        (proto-discriminator proto-method first-arg env body)
  176.   (ignore proto-discriminator)
  177.   (let ((entries (expand-with-make-entries proto-method first-arg))
  178.     (gensyms ()))
  179.     (dolist (arg first-arg)
  180.       (push (list (if (listp arg) (car arg) arg)
  181.           (gensym))
  182.         gensyms))
  183.     `(let ,(mapcar #'reverse gensyms)
  184.        ,(walk-form (cons 'progn body)
  185.       :environment env
  186.       :walk-function
  187.       #'(lambda (form context &aux temp)
  188.           (cond ((and (symbolp form)
  189.               (eq context ':eval)
  190.               (null (variable-lexical-p form))
  191.               (null (variable-special-p form))
  192.               (setq temp (assq form entries)))
  193.              (if (car (cddddr temp))    ;use slot-value?
  194.                          (optimize-get-slot 
  195.                           ;;;;  proto-method     ;;the method object ;rds 3/8 
  196.                            (third temp)        ;;the class object
  197.                `(get-slot ,(cadr (assq (cadr temp) gensyms))
  198.                     ',(slotd-name (cadddr temp)))
  199.                          )
  200.              `(,(slotd-accessor (cadddr temp))
  201.                ,(cadr (assq (cadr temp) gensyms)))))
  202.             ((and (listp form)
  203.               (or (eq (car form) 'setq)
  204.                   (eq (car form) 'setf)))
  205.              (cond ((cdddr form)
  206.                 (cons 'progn
  207.                   (iterate ((pair on (cdr form) by cddr))
  208.                     (collect (list (car form)
  209.                            (car pair)
  210.                            (cadr pair))))))
  211.                ((setq temp (assq (cadr form) entries))
  212.  
  213. ;;JAK 2/14/87 Bug found. The following IF was not included, causing
  214. ;;  the second form to always be returned. This caused forms like
  215. ;;;  (SETF (NIL #:G1234) 5) to be generated, which aren't SETF expandable
  216.  
  217.                  (if (not (slotd-accessor (cadddr temp)))
  218.                    (optimize-setf-of-get-slot
  219.                     ;;; proto-method  ; rds 3/8
  220.                                  (third temp)
  221.                      `(setf-of-get-slot
  222.                        ,(cadr (assq (cadr temp) gensyms))
  223.                        ',(slotd-name (cadddr temp))
  224.                        ,(caddr form))
  225.                 )
  226.  
  227.                    `(setf (,(slotd-accessor (cadddr temp))
  228.                     ,(cadr (assq (cadr temp) gensyms)))
  229.                    ,(caddr form))))
  230.                (t form)))
  231.             (t form)))))))
  232.  
  233. ;;Default methods for optimize-get-slot and optimize-setf-of-get-slot
  234.  
  235. ; rds 3/9 changed arglist to conform to new PCL 
  236. ; (defmeth optimize-get-slot (method class form)
  237. ;  form
  238. ;)
  239. (defmeth optimize-get-slot (class form)
  240.  form
  241.  )
  242.  
  243. ; rds 3/9 changed arglist to conform to new PCL
  244. ;(defmeth optimize-setf-of-get-slot (method class form)
  245. ;  form
  246. ;)
  247. (defmeth optimize-setf-of-get-slot (class form)
  248.  form
  249.  )
  250. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  251.  
  252. (provide "pcl-patches")
  253.  
  254.