src/pcl/env.lisp

   1 ;;;; basic environmental stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27 \f
  28 ;;;; MAKE-LOAD-FORM
  29
  30 ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
  31 ;; shiny new generic function.
  32 (fmakunbound 'make-load-form)
  33 (defgeneric make-load-form (object &optional environment))
  34
  35 (defun !install-cross-compiled-methods (gf-name &key except)
  36   (assert (generic-function-p (fdefinition gf-name)))
  37   (dolist (method (cdr (assoc gf-name *!deferred-methods* :test #'equal)))
  38     (destructuring-bind (qualifiers specializers fmf lambda-list source-loc)
  39         method
  40       (unless (member (first specializers) except)
  41         (let ((arg-info
  42                 (if (equal gf-name '(setf documentation))
  43                     '(:arg-info (3))
  44                     (case gf-name
  45                       (print-object
  46                        '(:arg-info (2)))
  47                       ((make-load-form close)
  48                        '(:arg-info (1 . t)))
  49                       ((documentation)
  50                        '(:arg-info (2)))
  51                       (t
  52                        '(:arg-info (1)))))))
  53           (load-defmethod
  54            'standard-method gf-name
  55            qualifiers (mapcar (lambda (x)
  56                                 (if (typep x '(cons (eql eql) (cons t null)))
  57                                     (intern-eql-specializer (constant-form-value (second x)))
  58                                     (find-class x)))
  59                               specializers)
  60            lambda-list
  61            `(:function
  62              ,(let ((mf (%make-method-function fmf)))
  63                 (setf (%funcallable-instance-fun mf)
  64                       (method-function-from-fast-function fmf arg-info))
  65                 mf)
  66              plist ,arg-info simple-next-method-call t)
  67            source-loc))))))
  68 (!install-cross-compiled-methods 'make-load-form
  69                                  :except '(layout sb-alien-internals:alien-type))
  70
  71 (defmethod make-load-form ((class class) &optional env)
  72   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
  73   ;; doesn't matter while all our environments are the same...
  74   (declare (ignore env))
  75   (let ((name (class-name class)))
  76     (if (and name (eq (find-class name nil) class))
  77         `(find-class ',name)
  78         (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
  79                class))))
  80
  81 (defmethod make-load-form ((object layout) &optional env)
  82   (declare (ignore env))
  83   (let ((pname (classoid-proper-name (layout-classoid object))))
  84     (unless pname
  85       (error "can't dump wrapper for anonymous class:~%  ~S"
  86              (layout-classoid object)))
  87     `(classoid-layout (find-classoid ',pname))))
  88
  89 (defmethod make-load-form ((object sb-alien-internals:alien-type) &optional env)
  90   (or (sb-alien::make-type-load-form object)
  91       (make-load-form-saving-slots object :environment env)))
  92
  93 ;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled.
  94 (defun dont-know-how-to-dump (object)
  95   (error "~@<don't know how to dump ~S (default ~S method called).~>"
  96          object 'make-load-form))
  97
  98 (macrolet ((define-default-make-load-form-method (class)
  99              `(defmethod make-load-form ((object ,class) &optional env)
 100                 (declare (ignore env))
 101                 (dont-know-how-to-dump object))))
 102   (define-default-make-load-form-method structure-object)
 103   (define-default-make-load-form-method standard-object)
 104   (define-default-make-load-form-method condition))