Changeset 168


Ignore:
Timestamp:
Dec 31, 2003, 3:11:15 AM (21 years ago)
Author:
Gary Byers
Message:

Fix an EQL-SPECIALIZER botch. Lots of stuff to support foreign
classes/foreign objects.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/level-1/l1-clos-boot.lisp

    r151 r168  
    824824        (dolist (msp (%method-specializers m2) t)
    825825          (let ((spec (%pop specs)))
    826             (unless (if (typep msp 'eql-specializer)
    827                       (and (typep spec 'eql-specializer)
    828                            (eql (eql-specializer-object msp)
    829                                 (eql-specializer-object spec)))
    830                       (eq msp spec))
     826            (unless (eq msp spec)
    831827              (return nil))))))))
    832828
    … …  
    910906              (index 0))
    911907         (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
    912          (if (listp class)                   ; eql specializer
    913            (setq class (class-of (second class))))
     908         (if (typep class 'eql-specializer)                   ; eql specializer
     909           (setq class (class-of (eql-specializer-object class))))
    914910         (while (%i< index size)
    915911           (let* ((wrapper (%gf-dispatch-table-ref dt index))
    … …  
    12511247(defun compute-cpl (class)
    12521248  (flet ((%real-class-cpl (class)
    1253            (or (%class.cpl class)
     1249           (or (%class-cpl class)
    12541250               (compute-cpl class))))
    12551251    (let* ((predecessors (list (list class))) candidates cpl)
    1256       (dolist (sup (%class.local-supers class))
     1252      (dolist (sup (%class-direct-superclasses class))
    12571253        (when (symbolp sup) (report-bad-arg sup 'class))
    12581254        (dolist (sup (%real-class-cpl sup))
    12591255          (unless (assq sup predecessors) (push (list sup) predecessors))))
    12601256      (labels ((compute-predecessors (class table)
    1261                  (dolist (sup (%class.local-supers class) table)
     1257                 (dolist (sup (%class-direct-superclasses class) table)
    12621258                   (compute-predecessors sup table)
    12631259                   ;(push class (cdr (assq sup table)))
    … …  
    12731269            (setq candidates (nremove c candidates))
    12741270            (setq cpl (%rplacd c cpl))
    1275             (dolist (sup (%class.local-supers (%car c)))
     1271            (dolist (sup (%class-direct-superclasses (%car c)))
    12761272              (when (setq c (assq sup predecessors)) (push c candidates)))
    12771273            (return))))
    … …  
    13291325        (setq sup (%car supers))
    13301326        (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers)))))
    1331         (unless (or (eq sup *t-class*) (std-class-p sup))
     1327        #+nil (unless (or (eq sup *t-class*) (std-class-p sup))
    13321328          (error "~a is not of type ~a" sup 'std-class))))
    13331329    (setf (%class.local-supers class) supers)
    … …  
    13671363    (let* ((wrapper (instance.class-wrapper thing)))
    13681364      (if (uvectorp wrapper)  ;; ???? - probably ok
    1369         wrapper))))
     1365        wrapper))
     1366    (if (typep thing 'macptr)
     1367      (foreign-instance-class-wrapper thing))))
    13701368
    13711369
    … …  
    14431441  (make-standard-class 'forward-referenced-class *class-class*))
    14441442
    1445 ;; Has to be a standard class because code currently depends on T being the
    1446 ;; only non-standard class in the CPL of a standard class.
    1447 (defvar *function-class* (make-standard-class 'function *t-class*))
     1443(defvar *function-class* (make-built-in-class 'function))
    14481444
    14491445;Right now, all functions are compiled.
    … …  
    15341530(defvar *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector)))
    15351531
    1536 (make-built-in-class 'macptr)
     1532(defvar *macptr-class* (make-built-in-class 'macptr))
     1533(defvar *foreign-standard-object-class*
     1534  (make-standard-class 'foreign-standard-object
     1535                       *standard-object-class* *macptr-class*))
     1536
     1537(defvar *foreign-class-class*
     1538  (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*))
     1539
    15371540(make-built-in-class 'population)
    15381541(make-built-in-class 'pool)
    … …  
    17051708
    17061709
     1710(def-accessors (foreign-object-domain) %svref
     1711  nil                                   ; foreign-object-domain
     1712  foreign-object-domain-index           ; 1..n
     1713  foreign-object-domain-name            ;
     1714  foreign-object-domain-recognize       ; function: is object one of ours ?
     1715  foreign-object-domain-class-of        ; function: returns class of object
     1716  foreign-object-domain-classp          ; function: true if object is a class
     1717  foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class
     1718  foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class
     1719  foreign-object-domain-slots-vector    ; returns slots vector of object or nil
     1720  )
     1721
     1722(defun make-foreign-object-domain (&key index name recognize class-of classp
     1723                                        instance-class-wrapper
     1724                                        class-own-wrapper
     1725                                        slots-vector)
     1726  (%istruct 'foreign-object-domain index name recognize class-of classp
     1727            instance-class-wrapper class-own-wrapper slots-vector))
     1728
     1729(let* ((n-foreign-object-domains 0)
     1730       (foreign-object-domains (make-array 10))
     1731       (foreign-object-domain-lock (make-lock)))
     1732  (defun register-foreign-object-domain (name
     1733                                         &key
     1734                                         recognize
     1735                                         class-of
     1736                                         classp
     1737                                         instance-class-wrapper
     1738                                         class-own-wrapper
     1739                                         slots-vector)
     1740    (with-lock-grabbed (foreign-object-domain-lock)
     1741      (dotimes (i n-foreign-object-domains)
     1742        (let* ((already (svref foreign-object-domains i)))
     1743          (when (eq name (foreign-object-domain-name already))
     1744            (setf (foreign-object-domain-recognize already) recognize
     1745                  (foreign-object-domain-class-of already) class-of
     1746                  (foreign-object-domain-classp already) classp
     1747                  (foreign-object-domain-instance-class-wrapper already)
     1748                  instance-class-wrapper
     1749                  (foreign-object-domain-class-own-wrapper already)
     1750                  class-own-wrapper
     1751                  (foreign-object-domain-slots-vector already) slots-vector)
     1752            (return-from register-foreign-object-domain i))))
     1753      (let* ((i n-foreign-object-domains)
     1754             (new (make-foreign-object-domain :index i
     1755                                              :name name
     1756                                              :recognize recognize
     1757                                              :class-of class-of
     1758                                              :classp classp
     1759                                              :instance-class-wrapper
     1760                                              instance-class-wrapper
     1761                                              :class-own-wrapper
     1762                                              class-own-wrapper
     1763                                              :slots-vector
     1764                                              slots-vector)))
     1765        (incf n-foreign-object-domains)
     1766        (if (= i (length foreign-object-domains))
     1767          (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2))))
     1768        (setf (svref foreign-object-domains i) new)
     1769        i)))
     1770  (defun foreign-class-of (p)
     1771    (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p))
     1772  (defun foreign-classp (p)
     1773    (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p))
     1774  (defun foreign-instance-class-wrapper (p)
     1775    (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
     1776  (defun foreign-class-own-wrapper (p)
     1777    (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
     1778  (defun foreign-slots-vector (p)
     1779    (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p))
     1780  (defun classify-foreign-pointer (p)
     1781    (do* ((i (1- n-foreign-object-domains) (1- i)))
     1782         ((zerop i) (error "this can't happen"))
     1783      (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p)
     1784        (%set-macptr-domain p i)
     1785        (return p)))))
     1786
     1787(defun constantly (x)
     1788  #'(lambda (&rest ignore)
     1789      (declare (dynamic-extent ignore)
     1790               (ignore ignore))
     1791      x))
     1792
     1793(register-foreign-object-domain :unclassified
     1794                                :recognize #'(lambda (p)
     1795                                               (declare (ignore p))
     1796                                               (error "Shouldn't happen"))
     1797                                :class-of #'(lambda (p)
     1798                                              (foreign-class-of
     1799                                               (classify-foreign-pointer p)))
     1800                                :classp #'(lambda (p)
     1801                                            (foreign-classp
     1802                                             (classify-foreign-pointer p)))
     1803                                :instance-class-wrapper
     1804                                #'(lambda (p)
     1805                                    (foreign-instance-class-wrapper
     1806                                     (classify-foreign-pointer p)))
     1807                                :class-own-wrapper
     1808                                #'(lambda (p)
     1809                                    (foreign-class-own-wrapper
     1810                                     (classify-foreign-pointer p)))
     1811                                :slots-vector
     1812                                #'(lambda (p)
     1813                                    (foreign-slots-vector
     1814                                     (classify-foreign-pointer p))))
     1815
     1816;;; "Raw" macptrs, that aren't recognized as "standard foreign objects"
     1817;;; in some other domain, should always be recognized as such (and this
     1818;;; pretty much has to be domain #1.)
     1819
     1820(register-foreign-object-domain :raw
     1821                                :recognize #'true
     1822                                :class-of (constantly *macptr-class*)
     1823                                :classp #'false
     1824                                :instance-class-wrapper
     1825                                (constantly (%class.own-wrapper *macptr-class*))
     1826                                :class-own-wrapper #'false
     1827                                :slots-vector #'false)
     1828
    17071829
    17081830(defparameter *class-table*
    … …  
    17251847      (map-subtag ppc32::subtag-double-float double-float)
    17261848      (map-subtag ppc32::subtag-single-float short-float)
    1727       (map-subtag ppc32::subtag-macptr macptr)
    17281849      (map-subtag ppc32::subtag-dead-macptr ivector)
    17291850      (map-subtag ppc32::subtag-code-vector code-vector)
    … …  
    17571878    (setf (%svref v ppc32::subtag-arrayH) *array-class*)
    17581879    ; These need to be special-cased:
     1880    (setf (%svref v ppc32::subtag-macptr) #'foreign-class-of)
    17591881    (setf (%svref v ppc32::subtag-character)
    17601882          #'(lambda (c) (let* ((code (%char-code c)))
    … …  
    18381960; Can't use typep at bootstrapping time.
    18391961(defun classp (x)
    1840   (let ((wrapper (standard-object-p x)))
    1841     (and wrapper
    1842          (let ((super (%wrapper-class wrapper)))
    1843            (memq *class-class* (%inited-class-cpl super t))))))
     1962  (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
     1963      (let ((wrapper (standard-object-p x)))
     1964        (or
     1965         (and wrapper
     1966              (let ((super (%wrapper-class wrapper)))
     1967                (memq *class-class* (%inited-class-cpl super t))))))))
    18441968
    18451969(set-type-predicate 'class 'classp)
    … …  
    19532077            (unless (setq s (pop ss))
    19542078              (err))
    1955             (unless (if (typep s 'eql-specializer)
    1956                       (and (typep spec 'eql-specializer)
    1957                            (eql (eql-specializer-object s)
    1958                                 (eql-specializer-object spec)))
    1959                       (eq s spec))
     2079            (unless (eq s spec)
    19602080              (return))))))))
    19612081
    … …  
    20772197  (find name slots :key #'%slot-definition-name))
    20782198
    2079 (defun %std-slot-value-using-class (instance slotd)
     2199(declaim (inline %std-slot-vector-value))
     2200
     2201(defun %std-slot-vector-value (slot-vector slotd)
    20802202  (let* ((loc (standard-effective-slot-definition.location slotd)))
    2081     (typecase loc
    2082       (fixnum
    2083        (standard-instance-instance-location-access instance loc))
    2084       (cons
    2085        (let* ((val (%cdr loc)))
    2086          (if (eq val (%slot-unbound-marker))
    2087            (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
     2203    (symbol-macrolet ((instance (slot-vector.instance slot-vector)))
     2204      (typecase loc
     2205        (fixnum
     2206         (%slot-ref slot-vector loc))
     2207        (cons
     2208         (let* ((val (%cdr loc)))
     2209           (if (eq val (%slot-unbound-marker))
     2210             (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
    20882211           val)))
    20892212      (t
    20902213       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2091               slotd loc (slot-definition-allocation slotd))))))
     2214              slotd loc (slot-definition-allocation slotd)))))))
     2215
    20922216
    20932217(defmethod slot-value-using-class ((class standard-class)
    20942218                                   instance
    20952219                                   (slotd standard-effective-slot-definition))
    2096   (%std-slot-value-using-class instance slotd))
     2220  (%std-slot-vector-value (instance.slots instance) slotd))
    20972221
    20982222(defun %maybe-std-slot-value-using-class (class instance slotd)
    … …  
    21022226               (instance.class-wrapper slotd))
    21032227           (eq *standard-class-wrapper* (instance.class-wrapper class)))
    2104     (%std-slot-value-using-class instance slotd)
     2228    (%std-slot-vector-value (instance.slots instance) slotd)
    21052229    (slot-value-using-class class instance slotd)))
    21062230
    2107  
    2108 
    2109 (defun %std-setf-slot-value-using-class (instance slotd new)
     2231
     2232(declaim (inline  %set-std-slot-vector-value))
     2233
     2234(defun %set-std-slot-vector-value (slot-vector slotd  new)
    21102235  (let* ((loc (standard-effective-slot-definition.location slotd))
    21112236         (type (standard-effective-slot-definition.type slotd))
    … …  
    21162241    (typecase loc
    21172242      (fixnum
    2118        (setf
    2119         (standard-instance-instance-location-access instance loc) new))
     2243       (setf (%svref slot-vector loc) new))
    21202244      (cons
    21212245       (setf (%cdr loc) new))
    … …  
    21242248              slotd loc (slot-definition-allocation slotd))))))
    21252249 
     2250 
    21262251(defmethod (setf slot-value-using-class)
    21272252    (new
    … …  
    21292254     instance
    21302255     (slotd standard-effective-slot-definition))
    2131   (%std-setf-slot-value-using-class instance slotd new))
     2256  (%set-std-slot-vector-value (instance.slots instance) slotd new))
    21322257
    21332258
    … …  
    21382263               (instance.class-wrapper slotd))
    21392264           (eq *standard-class-wrapper* (instance.class-wrapper class)))
    2140     (%std-setf-slot-value-using-class instance slotd new)
     2265    (%set-std-slot-vector-value (instance.slots instance) slotd new)
    21412266    (setf (slot-value-using-class class instance slotd) new)))
    21422267
    … …  
    21442269                                   instance
    21452270                                   (slotd standard-effective-slot-definition))
    2146   (let* ((loc (standard-effective-slot-definition.location slotd)))
    2147       (typecase loc
    2148         (fixnum
    2149          (standard-generic-function-instance-location-access instance loc))
    2150         (cons
    2151          (let* ((val (%cdr loc)))
    2152            (if (eq val (%slot-unbound-marker))
    2153              (slot-unbound class instance (standard-effective-slot-definition.name slotd))
    2154              val)))
    2155         (t
    2156          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2157                 slotd loc (slot-definition-allocation slotd))))))
     2271  (%std-slot-vector-value (gf.slots instance) slotd))
    21582272
    21592273(defmethod (setf slot-value-using-class)
    … …  
    21622276     instance
    21632277     (slotd standard-effective-slot-definition))
    2164   (let* ((loc (standard-effective-slot-definition.location slotd))
    2165            (type (standard-effective-slot-definition.type slotd)))
    2166       (if (and type (not (eq type t)))
    2167         (unless (or (eq new (%slot-unbound-marker)) (typep new type))
    2168           (setq new (require-type new type))))
    2169       (typecase loc
    2170         (fixnum
    2171          (setf
    2172           (standard-generic-function-instance-location-access instance loc) new))
    2173         (cons
    2174          (setf (%cdr loc) new))
    2175         (t
    2176          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2177                 slotd loc (slot-definition-allocation slotd))))))
    2178 
    2179 
     2278  (%set-std-slot-vector-value (gf.slots instance) slotd new))
    21802279
    21812280(defun slot-value (instance slot-name)
    … …  
    22212320        (slot-missing class instance name 'slot-makunbound))))
    22222321
    2223 
     2322(defun %std-slot-vector-boundp (slot-vector slotd)
     2323  (let* ((loc (standard-effective-slot-definition.location slotd)))
     2324    (typecase loc
     2325      (fixnum
     2326       (not (eq (%svref slot-vector loc) (%slot-unbound-marker))))
     2327      (cons
     2328       (not (eq (%cdr loc) (%slot-unbound-marker))))
     2329      (t
     2330       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
     2331                slotd loc (slot-definition-allocation slotd))))))
    22242332
    22252333(defmethod slot-boundp-using-class ((class standard-class)
    22262334                                    instance
    22272335                                    (slotd standard-effective-slot-definition))
    2228   (if (eql 0 (%wrapper-instance-slots (instance.class-wrapper instance)))
    2229     (progn
    2230       (update-obsolete-instance instance)
    2231       (slot-boundp instance (standard-effective-slot-definition.name slotd)))
    2232     (let* ((loc (standard-effective-slot-definition.location slotd)))
    2233       (typecase loc
    2234         (fixnum
    2235          (not (eq (%standard-instance-instance-location-access instance loc)
    2236                   (%slot-unbound-marker))))
    2237         (cons
    2238          (not (eq (%cdr loc) (%slot-unbound-marker))))
    2239         (t
    2240          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2241                 slotd loc (slot-definition-allocation slotd)))))))
     2336  (%std-slot-vector-boundp (instance.slots instance) slotd))
    22422337
    22432338(defmethod slot-boundp-using-class ((class funcallable-standard-class)
    22442339                                    instance
    22452340                                    (slotd standard-effective-slot-definition))
    2246   (if (eql 0 (%wrapper-instance-slots (gf.instance.class-wrapper instance)))
    2247     (progn
    2248       (update-obsolete-instance instance)
    2249       (slot-boundp instance (standard-effective-slot-definition.name slotd)))
    2250     (let* ((loc (standard-effective-slot-definition.location slotd)))
    2251       (typecase loc
    2252         (fixnum
    2253          (not (eq (%standard-generic-function-instance-location-access instance loc)
    2254                   (%slot-unbound-marker))))
    2255         (cons
    2256          (not (eq (%cdr loc) (%slot-unbound-marker))))
    2257         (t
    2258          (error "Slot definition ~s has invalid location ~s (allocation ~s)."
    2259                 slotd loc (slot-definition-allocation slotd)))))))
     2341  (%std-slot-vector-boundp (gf.slots instance) slotd))
    22602342
    22612343
    … …  
    22802362
    22812363(defun slot-id-value (instance slot-id)
    2282   (let* ((wrapper (if (eq (typecode instance) ppc32::subtag-instance)
    2283                     (instance.class-wrapper instance)
     2364  (let* ((wrapper (or (standard-object-p instance)
    22842365                    (%class.own-wrapper (class-of instance)))))
    22852366    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
    22862367
    22872368(defun set-slot-id-value (instance slot-id value)
    2288   (let* ((wrapper (if (eq (typecode instance) ppc32::subtag-instance)
    2289                     (instance.class-wrapper instance)
     2369  (let* ((wrapper (or (standard-object-p instance)
    22902370                    (%class.own-wrapper (class-of instance)))))
    22912371    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
    … …  
    24782558             (let* ((old-size (uvsize old-instance-slots))
    24792559                    (new-size (uvsize new-instance-slots)))
    2480                (declare (fixmum old-size new-size))
     2560               (declare (fixnum old-size new-size))
    24812561               (dotimes (i old-size)
    24822562                 (declare (fixnum i))
    … …  
    29092989    (class-precedence-list class)))
    29102990
    2911 (defmethod class-precedence-list ((class standard-class))
     2991(defmethod class-precedence-list ((class class))
    29122992  (%inited-class-cpl class))
    29132993
    2914 (defmethod class-precedence-list ((class class))
    2915   (or (%class.cpl class)
    2916       (error "~s has no class-precedence-list." class)))
     2994
    29172995
    29182996
    … …  
    30723150                (nreverse res))
    30733151              (mapcar '%slot-definition-name
    3074                       (extract-instance-effective-slotds 
    3075                        (%class-slots (class-of object)))))))
     3152                      (extract-instance-effective-slotds
     3153                       (class-of object))))))
    30763154    (values
    30773155     (let* ((form (gethash class-name *make-load-form-saving-slots-hash*)))
Note: See TracChangeset for help on using the changeset viewer.