145 lines
5.2 KiB
Common Lisp
145 lines
5.2 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
|
|
;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
|
|
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
|
|
|
|
;;;. Copyright (c) 1991 by Venue
|
|
|
|
|
|
|
|
(in-package "CLOS")
|
|
|
|
;;; Shadow, Export, Require, Use-package, and Import forms should follow here
|
|
|
|
|
|
|
|
;;; ************************************************************************* This is the 1100
|
|
;;; (Xerox version) of the file portable-low.
|
|
|
|
|
|
(defmacro load-time-eval (form)
|
|
`(il:loadtimeconstant ,form))
|
|
|
|
|
|
;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
|
|
;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper. This
|
|
;;; is safe because there will always be some other pointer to the wrapper to keep it around.
|
|
|
|
|
|
(defstruct (std-instance (:predicate std-instance-p)
|
|
(:conc-name %std-instance-)
|
|
(:constructor %%allocate-instance--class nil)
|
|
(:fast-accessors t)
|
|
(:print-function %print-std-instance))
|
|
(wrapper nil :type il:fullxpointer)
|
|
(slots nil))
|
|
|
|
(defun %print-std-instance (instance &optional stream depth)
|
|
|
|
;; See the IRM, section 25.3.3. Unfortunatly, that documentation is not correct. In
|
|
;; particular, it makes no mention of the third argument.
|
|
(cond ((streamp stream)
|
|
|
|
;; Use the standard CLOS printing method, then return T to tell the printer that we
|
|
;; have done the printing ourselves.
|
|
(print-std-instance instance stream depth)
|
|
t)
|
|
(t
|
|
;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
|
|
;; the string of characters that would be printed, if the object were being printed
|
|
;; for real.
|
|
(list (with-output-to-string (stream)
|
|
(print-std-instance instance stream depth))))))
|
|
|
|
|
|
;;
|
|
|
|
|
|
|
|
;;; FUNCTION-ARGLIST
|
|
|
|
|
|
|
|
;;
|
|
|
|
|
|
(defun function-arglist (x)
|
|
|
|
;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
|
|
;; symbols. How silly.
|
|
(let ((arglist (il:arglist x)))
|
|
(when (symbolp arglist)
|
|
|
|
;; This could be due to trying to extract the arglist of an interpreted function
|
|
;; (though why that should be hard is beyond me). On the other hand, if the
|
|
;; function is compiled, it helps to ask for the "smart" arglist.
|
|
(setq arglist (if (consp (symbol-function x))
|
|
(second (symbol-function x))
|
|
(il:arglist x t))))
|
|
(if (symbolp arglist)
|
|
|
|
;; Probably never get here, but just in case
|
|
(list '&rest 'rest)
|
|
|
|
;; Make sure there are no strings where there should be symbols
|
|
(if (some #'stringp arglist)
|
|
(mapcar #'(lambda (a)
|
|
(if (symbolp a)
|
|
a
|
|
(intern a)))
|
|
arglist)
|
|
arglist))))
|
|
|
|
(defun printing-random-thing-internal (thing stream)
|
|
(let ((*print-base* 8))
|
|
(princ (il:\\hiloc thing)
|
|
stream)
|
|
(princ "," stream)
|
|
(princ (il:\\loloc thing)
|
|
stream)))
|
|
|
|
(defun record-definition (name type &optional parent-name parent-type)
|
|
(declare (ignore type parent-name))
|
|
nil)
|
|
|
|
|
|
;;; FIN uses this too!
|
|
|
|
|
|
(eval-when (compile load eval)
|
|
(il:datatype il:compiled-closure (il:fnheader il:environment))
|
|
(il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
|
|
|
|
(defun compiled-closure-fnheader (compiled-closure)
|
|
(il:fetch (il:compiled-closure il:fnheader)
|
|
il:of compiled-closure))
|
|
|
|
(defun set-compiled-closure-fnheader (compiled-closure nv)
|
|
(il:replace (il:compiled-closure il:fnheader)
|
|
il:of compiled-closure nv))
|
|
|
|
(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
|
|
|
|
|
|
;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
|
|
;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
|
|
;;; course this is completely non-robust, but it will work for now. This is not the place to go
|
|
;;; into a long tyrade about what is wrong with having record package definitions go away when you
|
|
;;; ship the sysout; there isn't enough diskspace.
|
|
|
|
|
|
(defun set-function-name-1 (fn new-name uninterned-name)
|
|
(cond ((typep fn 'il:compiled-closure)
|
|
(il:\\rplptr (compiled-closure-fnheader fn)
|
|
4 new-name)
|
|
(when (and (consp uninterned-name)
|
|
(eq (car uninterned-name)
|
|
'method))
|
|
(let ((debug (si::compiled-function-debugging-info fn)))
|
|
(when debug
|
|
(setf (cdr debug)
|
|
uninterned-name)))))
|
|
(t nil))
|
|
fn)
|