home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / coral-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-09-08  |  2.4 KB  |  67 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. #-(or :ccl-1.3 :cltl2)
  31. (ccl::add-transform 'std-instance-p 
  32.                      :inline 
  33.                      #'(lambda (call)
  34.                          (ccl::verify-arg-count call 1 1)
  35.                          (let ((arg (cadr call)))
  36.                            `(and (eq (ccl::%type-of ,arg) 'structure)
  37.                                  (eq (%svref ,arg 0) 'std-instance)))))
  38.  
  39. (eval-when (eval compile load)
  40.   (proclaim '(inline std-instance-p)))
  41. #-:cltl2
  42. (defun printing-random-thing-internal (thing stream)
  43.   (prin1 (ccl::%ptr-to-int thing) stream))
  44. #+:cltl2
  45. (defun printing-random-thing-internal (thing stream)
  46.   (prin1 (ccl::%address-of thing) stream))
  47.  
  48. (defun set-function-name-1 (function new-name uninterned-name)
  49.   (declare (ignore uninterned-name))
  50.   (cond ((ccl::lfunp function)
  51.          (ccl::lfun-name function new-name)))
  52.   function)
  53.  
  54.  
  55. (defun doctor-dfun-for-the-debugger (gf dfun)
  56.   #+:ccl-1.3
  57.   (let* ((gfspec (and (symbolp (generic-function-name gf))
  58.               (generic-function-name gf)))
  59.      (arglist (generic-function-pretty-arglist gf)))
  60.     (when gfspec
  61.       (setf (get gfspec 'ccl::%lambda-list)
  62.         (if (and arglist (listp arglist))
  63.         (format nil "~{~A~^ ~}" arglist)
  64.         (format nil "~:A" arglist)))))
  65.   dfun)
  66.  
  67.