← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to pcl/impl/coral/coral-low.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
pcl/impl/coral/coral-low.lisp
 
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
#-:ccl-1.3
 
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
 
 
42
(defun printing-random-thing-internal (thing stream)
 
43
  (prin1 (ccl::%ptr-to-int thing) stream))
 
44
 
 
45
(defun set-function-name-1 (function new-name uninterned-name)
 
46
  (declare (ignore uninterned-name))
 
47
  (cond ((ccl::lfunp function)
 
48
         (ccl::lfun-name function new-name)))
 
49
  function)
 
50
 
 
51
 
 
52
(defun doctor-dfun-for-the-debugger (gf dfun)
 
53
  #+:ccl-1.3
 
54
  (let* ((gfspec (and (symbolp (generic-function-name gf))
 
55
                      (generic-function-name gf)))
 
56
         (arglist (generic-function-pretty-arglist gf)))
 
57
    (when gfspec
 
58
      (setf (get gfspec 'ccl::%lambda-list)
 
59
            (if (and arglist (listp arglist))
 
60
                (format nil "~{~A~^ ~}" arglist)
 
61
                (format nil "~:A" arglist)))))
 
62
  dfun)
 
63