Changeset 10426


Ignore:
Timestamp:
Aug 11, 2008, 3:49:48 AM (11 years ago)
Author:
gb
Message:

Merge a lot of the CLOS/type-system changes from working-0711 branch
into trunk. Todo: compiler-macros for those changes.

Have -not- yet merged source-tracking changes, new record-source file
from working-0711, but this stuff seems to bootstrap in one swell foop.

Location:
trunk/source
Files:
18 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-boot-1.lisp

    r7726 r10426  
    103103
    104104; only do these if exist
    105 (defun init-logical-directories () 
    106   (let ((startup (mac-default-directory)))
    107     (replace-base-translation "home:" (or (user-homedir-pathname) startup))
    108     (replace-base-translation "ccl:" (ccl-directory))
    109     ))
     105(defun init-logical-directories ()
     106  (replace-base-translation "home:"  (user-homedir-pathname))
     107  (replace-base-translation "ccl:" (ccl-directory)))
    110108
    111109(push #'init-logical-directories *lisp-system-pointer-functions*)
  • trunk/source/level-1/l1-clos-boot.lisp

    r10424 r10426  
    4141          (t (%non-standard-instance-slots instance typecode)))))
    4242
     43
     44;;; True if X is a class but not a foreign-class.
     45(defun native-class-p (x)
     46  (if (%standard-instance-p x)
     47    (< (the fixnum (instance.hash x)) max-class-ordinal)))
     48
    4349(defun %class-name (class)
    44   (%class.name class))
     50  (if (native-class-p class)
     51    (%class.name class)
     52    (class-name class)))
    4553
    4654(defun %class-info (class)
    47   (%class.info class))
    48 
     55  (if (native-class-p class)
     56    (%class.info class)
     57    (class-info class)))
     58 
    4959
    5060(defun %class-kernel-p (class)
     
    6272
    6373(defun %class-own-wrapper (class)
    64   (%class.own-wrapper class))
     74  (if (native-class-p class)
     75    (%class.own-wrapper class)
     76   (class-own-wrapper class)))
    6577
    6678(defun (setf %class-own-wrapper) (new class)
     
    6880
    6981(defun %class-alist (class)
    70   (if (typep class 'slots-class)
    71     (%class.alist class)))
     82  (%class.alist class))
    7283
    7384(defun (setf %class-alist) (new class)
     
    7788
    7889(defun %class-slots (class)
    79   (if (typep class 'slots-class)
    80     (%class.slots class)))
     90  (if (native-class-p class)
     91    (%class.slots class)
     92    (class-slots class)))
    8193
    8294(defun (setf %class-slots) (new class)
    83   (if (typep class 'slots-class)
     95  (if (native-class-p class)
    8496    (setf (%class.slots class) new)
    85     new))
     97    (setf (class-slots class) new)))
    8698
    8799(defun %class-direct-slots (class)
    88   (if (typep class 'slots-class)
    89     (%class.direct-slots class)))
     100  (if (native-class-p class)
     101    (%class.direct-slots class)
     102    (class-direct-slots class)))
    90103
    91104(defun (setf %class-direct-slots) (new class)
    92   (if (typep class 'slots-class)
    93     (setf (%class.direct-slots class) new))
    94   new)
    95  
     105  (if (native-class-p class)
     106    (setf (%class.direct-slots class) new)
     107    (setf (class-direct-slots class) new)))
     108
     109
     110
     111
     112
     113
    96114(defun %class-direct-superclasses (class)
    97115  (%class.local-supers class))
     
    229247                                 next-slot-index))
    230248  )
     249
     250
    231251
    232252
     
    342362        (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
    343363        (if return-keys?
    344           (values bits (if key-list (apply #'vector (nreverse key-list)) #()))
    345           (values bits nil))))))
     364          (values bits (apply #'vector (nreverse key-list)))
     365          bits)))))
    346366
    347367(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok)
     
    574594          nil))
    575595
     596(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil
     597  "If true, each gf will get its own unique copy of its dcode.  Not recommended for
     598   real use (for one thing, it's known to break gf tracing), but may be helpful for
     599   profiling")
     600
    576601(let* ((class-wrapper-random-state (make-random-state))
    577602       (class-wrapper-random-state-lock (make-lock)))
     
    701726      (mapcar #'canonicalize-specializer specializers))))
    702727
     728(defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.")
     729
    703730(defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers
    704731                           &allow-other-keys)
    705732  (declare (dynamic-extent keys))
    706   (setq specializers (canonicalize-specializers specializers))
    707   (let* ((gf (ensure-generic-function name))
    708          (method (apply #'%make-method-instance
    709                         (%gf-method-class gf)
    710                         :name name
    711                         :specializers specializers
    712                         keys))
    713          (old-method (when (%gf-methods gf)
    714                        (ignore-errors
    715                          (find-method gf qualifiers specializers nil)))))
    716 
    717     (%add-method gf method)
    718     (when (and doc-p *save-doc-strings*)
    719       (set-documentation method t documentation))
    720     (record-source-file method 'method)
    721     (when old-method (%move-method-encapsulations-maybe old-method method))
    722     method))
     733  (if *sealed-clos-world*
     734    (error "Method (re)definition is not allowed in this environment.")
     735    (progn
     736      (setq specializers (canonicalize-specializers specializers))
     737      (let* ((gf (ensure-generic-function name))
     738             (method (apply #'%make-method-instance
     739                            (%gf-method-class gf)
     740                            :name name
     741                            :specializers specializers
     742                            keys))
     743             (old-method (when (%gf-methods gf)
     744                           (ignore-errors
     745                             (find-method gf qualifiers specializers nil)))))
     746
     747        (%add-method gf method)
     748        (when (and doc-p *save-doc-strings*)
     749          (set-documentation method t documentation))
     750        (record-source-file method 'method)
     751        (when old-method (%move-method-encapsulations-maybe old-method method))
     752        method))))
    723753       
    724754
     
    841871  (%add-standard-method-to-standard-gf gf method))
    842872
     873;; Redefined in l1-clos.lisp
     874(defun maybe-remove-make-instance-optimization (gfn method)
     875  (declare (ignore gfn method))
     876  nil)
     877
    843878(defun %add-standard-method-to-standard-gf (gfn method)
    844879  (when (%method-gf method)
     
    850885         (qualifiers (%method-qualifiers method)))
    851886    (remove-obsoleted-combined-methods method dt specializers)
     887    (maybe-remove-make-instance-optimization gfn method)
    852888    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    853889    (dolist (m methods)
     
    923959    (loop
    924960      (multiple-value-bind (found name cell) (m)
    925         (declare (list cell))
     961        (declare (type class-cell cell))
    926962        (unless found (return))
    927         (when (cdr cell)
     963        (when cell
    928964          (funcall function name (class-cell-class cell)))))))
    929965
     
    9681004   (when dt
    9691005     (if specializers
    970        (let* ((argnum (%gf-dispatch-table-argnum dt))
    971               (class (nth argnum specializers))
    972               (size (%gf-dispatch-table-size dt))
    973               (index 0))
    974          (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
    975          (if (typep class 'eql-specializer)
    976            (setq class (class-of (eql-specializer-object class))))
    977          (while (%i< index size)
    978            (let* ((wrapper (%gf-dispatch-table-ref dt index))
    979                   hash-index-0?
    980                   (cpl (and wrapper
    981                             (not (setq hash-index-0?
    982                                        (eql 0 (%wrapper-hash-index wrapper))))
    983                             (%inited-class-cpl
    984                              (require-type (%wrapper-class wrapper) 'class)))))
    985              (when (or hash-index-0? (and cpl (cpl-index class cpl)))
    986                (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
    987                      (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
    988              (setq index (%i+ index 2)))))
     1006       (let* ((argnum (%gf-dispatch-table-argnum dt)))
     1007         (when (>= argnum 0)
     1008           (let ((class (nth argnum specializers))
     1009                 (size (%gf-dispatch-table-size dt))
     1010                 (index 0))
     1011             (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
     1012             (if (typep class 'eql-specializer)
     1013                 (setq class (class-of (eql-specializer-object class))))
     1014             (while (%i< index size)
     1015               (let* ((wrapper (%gf-dispatch-table-ref dt index))
     1016                      hash-index-0?
     1017                      (cpl (and wrapper
     1018                                (not (setq hash-index-0?
     1019                                           (eql 0 (%wrapper-hash-index wrapper))))
     1020                                (%inited-class-cpl
     1021                                 (require-type (%wrapper-class wrapper) 'class)))))
     1022                 (when (or hash-index-0? (and cpl (cpl-index class cpl)))
     1023                   (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
     1024                         (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
     1025                 (setq index (%i+ index 2)))))))
    9891026       (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
    9901027
     
    9951032(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers)
    9961033  (declare (ignore other-specializers))
    997   (when (and first-specializer (typep first-specializer 'class))        ; no eql methods or gfs with no specializers need apply
     1034  (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply
    9981035    (let ((indices (cdr (assq gf *initialization-invalidation-alist*))))
    9991036      (when indices
    10001037        (labels ((invalidate (class indices)
    1001                              (when (std-class-p class)  ; catch the class named T
    1002                                (dolist (index indices)
    1003                                  (setf (standard-instance-instance-location-access class index) nil)))
    1004                              (dolist (subclass (%class.subclasses class))
    1005                                (invalidate subclass indices))))
     1038                   (when (std-class-p class) ; catch the class named T
     1039                     (dolist (index indices)
     1040                       (setf (standard-instance-instance-location-access class index) nil)))
     1041                   (dolist (subclass (%class.subclasses class))
     1042                     (invalidate subclass indices))))
    10061043          (invalidate first-specializer indices))))))
    10071044
     
    10111048;;; 2) the index of the first non-T specializer
    10121049(defun multi-method-index (method &aux (i 0) index)
    1013   (dolist (s (%method-specializers method) (values nil index))
     1050  (dolist (s (%method.specializers method) (values nil index))
    10141051    (unless (eq s *t-class*)
    10151052      (unless index (setq index i))
     
    10441081
    10451082
    1046            
    1047  
    10481083(defvar *writer-method-function-proto*
    10491084  #'(lambda (new instance)
    10501085      (set-slot-value instance 'x new)))
    10511086
     1087(defun dcode-for-gf (gf dcode)
     1088  (if *uniquify-dcode*
     1089    (let ((new-dcode (%copy-function dcode)))
     1090      (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf)))
     1091      new-dcode)
     1092    dcode))
    10521093
    10531094(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument.  The dcode functions will be caled with all of the incoming arguments.")
     
    10581099      (when dcode (return dcode)))))
    10591100
    1060            
    10611101(defun compute-dcode (gf &optional dt)
    10621102  (setq gf (require-type gf 'standard-generic-function))
     
    11841224  (let* ((typecode (typecode instance)))
    11851225    (declare (type (unsigned-byte 8) typecode))
    1186     (cond ((eql typecode target::subtag-istruct)
     1226    (cond ((eql typecode target::subtag-struct)
     1227           (%class.own-wrapper
     1228            (class-cell-class (car (%svref instance 0)))))
     1229          ((eql typecode target::subtag-istruct)
    11871230           (istruct-cell-info (%svref instance 0)))
    11881231          ((eql typecode target::subtag-basic-stream)
     
    11901233          ((typep instance 'funcallable-standard-object)
    11911234           (gf.instance.class-wrapper instance))
    1192           ((eql typecode target::subtag-macptr)
    1193            (foreign-instance-class-wrapper instance))
     1235          ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance))
    11941236          (t (%class.own-wrapper (class-of instance))))))
    11951237
    11961238(defun instance-class-wrapper (instance)
    1197   (if (= (typecode instance) target::subtag-instance)
     1239  (if (= (typecode instance)  target::subtag-instance)
    11981240    (instance.class-wrapper instance)
    11991241    (non-standard-instance-class-wrapper instance)))
    12001242
    12011243
     1244(defun std-instance-class-cell-typep (form class-cell)
     1245  (declare (type class-cell  class-cell))
     1246  (let* ((typecode (typecode form))
     1247         (wrapper (cond ((= typecode target::subtag-instance)
     1248                         (instance.class-wrapper form))
     1249                        ((= typecode target::subtag-basic-stream)
     1250                         (basic-stream.wrapper form))
     1251                        (t nil))))
     1252    (declare (type (unsigned-byte 8) typecode))
     1253    (when wrapper
     1254      (loop
     1255        (let ((class (class-cell-class class-cell)))
     1256          (if class
     1257            (let* ((ordinal (%class-ordinal class))
     1258                   (bits (or (%wrapper-cpl-bits wrapper)
     1259                             (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1260              (declare (fixnum ordinal))
     1261              (return
     1262                (if bits
     1263                  (locally (declare (simple-bit-vector bits)
     1264                                    (optimize (speed 3) (safety 0)))
     1265                    (if (< ordinal (length bits))
     1266                      (not (eql 0 (sbit bits ordinal))))))))
     1267            (let* ((name (class-cell-name class-cell))
     1268                   (new-cell (find-class-cell name nil)))
     1269              (unless
     1270                  (if (and new-cell (not (eq class-cell new-cell)))
     1271                    (setq class-cell new-cell class (class-cell-class class-cell))
     1272                    (return (typep form name)))))))))))
    12021273
    12031274(defun class-cell-typep (form class-cell)
    12041275  (locally (declare (type class-cell  class-cell))
     1276    (loop
    12051277    (let ((class (class-cell-class class-cell)))
    1206       (loop
    1207         (if class
    1208           (let* ((wrapper (if (%standard-instance-p form)
    1209                             (instance.class-wrapper form)
    1210                             (instance-class-wrapper form))))
    1211             (return
    1212               (not (null (memq class (or (%wrapper-cpl wrapper)
    1213                                          (%inited-class-cpl (%wrapper-class wrapper))))))))
    1214           (if (setq class (find-class (class-cell-name class-cell) nil))
    1215             (setf (class-cell-class class-cell) class)
    1216             (return (typep form (class-cell-name class-cell)))))))))
     1278      (if class
     1279        (let* ((ordinal (%class-ordinal class))
     1280               (wrapper (instance-class-wrapper form))
     1281               (bits (or (%wrapper-cpl-bits wrapper)
     1282                         (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1283          (declare (fixnum ordinal))
     1284          (return
     1285            (if bits
     1286              (locally (declare (simple-bit-vector bits)
     1287                                (optimize (speed 3) (safety 0)))
     1288                  (if (< ordinal (length bits))
     1289                    (not (eql 0 (sbit bits ordinal))))))))
     1290        (let* ((name (class-cell-name class-cell))
     1291               (new-cell (find-class-cell name nil)))
     1292          (unless
     1293              (if (and new-cell (not (eq class-cell new-cell)))
     1294                (setq class-cell new-cell class (class-cell-class class-cell))
     1295                (return (typep form name))))))))))
    12171296
    12181297
     
    12221301    arg
    12231302    (%kernel-restart $xwrongtype arg (car class-cell))))
    1224 
    1225 
    12261303
    12271304
     
    12421319          (find-class name errorp environment)))))
    12431320
     1321(defun update-class-proper-names (name old-class new-class)
     1322  (when (and old-class
     1323             (not (eq old-class new-class))
     1324             (eq (%class-proper-name old-class) name))
     1325    (setf (%class-proper-name old-class) nil))
     1326  (when (and new-class (eq (%class-name new-class) name))
     1327    (setf (%class-proper-name new-class) name)))
     1328
     1329
    12441330(defun set-find-class (name class)
    12451331  (clear-type-cache)
    1246   (let ((cell (find-class-cell name class)))
    1247     (when cell
    1248       (when class
    1249         (if (eq name (%class.name class))
    1250           (setf (info-type-kind name) :instance)))
    1251       (setf (class-cell-class cell) class))
     1332  (let* ((cell (find-class-cell name t))
     1333         (old-class (class-cell-class cell)))
     1334    (when class
     1335      (if (eq name (%class.name class))
     1336        (setf (info-type-kind name) :instance)))
     1337    (setf (class-cell-class cell) class)
     1338    (update-class-proper-names name old-class class)
    12521339    class))
    12531340
     
    12971384 (defun set-find-class (name class)
    12981385   (setq name (require-type name 'symbol))
    1299    (let ((cell (find-class-cell name t)))
     1386   (let* ((cell (find-class-cell name t))
     1387          (old-class (class-cell-class cell)))
    13001388     (declare (type class-cell cell))
    1301        (let ((old-class (class-cell-class cell)))
    1302          (when old-class
    1303            (when (eq (%class.name old-class) name)
    1304              (setf (info-type-kind name) nil)
    1305              (clear-type-cache))
    1306            (when *warn-if-redefine-kernel*
    1307              (check-setf-find-class-protected-class old-class class name))))
     1389     (when old-class
     1390       (when (eq (%class.name old-class) name)
     1391         (setf (info-type-kind name) nil)
     1392         (clear-type-cache))
     1393       (when *warn-if-redefine-kernel*
     1394         (check-setf-find-class-protected-class old-class class name)))
    13081395     (when (null class)
    13091396       (when cell
    13101397         (setf (class-cell-class cell) nil))
     1398       (update-class-proper-names name old-class class)
    13111399       (return-from set-find-class nil))
    13121400     (setq class (require-type class 'class))
     
    13211409         (%deftype name nil nil))
    13221410       (setf (info-type-kind name) :instance))
     1411     (update-class-proper-names name old-class class)
    13231412     (setf (class-cell-class cell) class)))
    13241413 )                                      ; end of queue-fixup
     
    13391428||#
    13401429
    1341 
    13421430(defglobal *next-class-ordinal* 0)
    13431431
     
    13661454      (unless no-error
    13671455        (error "Can't set ordinal of class ~s to ~s" class new)))))
     1456
    13681457
    13691458(defvar *t-class* (let* ((class (%cons-built-in-class 't)))
     
    14281517            (setf (sbit bits ordinal) 1)))))))
    14291518
    1430 
     1519         
    14311520(defun make-built-in-class (name &rest supers)
    14321521  (if (null supers)
     
    14511540      (setf (%class.cpl class) cpl)
    14521541      (setf (%class.own-wrapper class) wrapper)
    1453       (setf (%wrapper-cpl wrapper) cpl))
     1542      (setf (%wrapper-cpl wrapper) cpl
     1543            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
     1544            (%wrapper-class-ordinal wrapper) (%class-ordinal class)))
    14541545    (setf (%class.ctype class)  (make-class-ctype class))
    14551546    (setf (find-class name) class)
     
    14621553  (let* ((class (apply #'make-built-in-class name supers))
    14631554         (cell (register-istruct-cell name)))
    1464     (set-istruct-cell-info cell (%class.own-wrapper class))
     1555    (setf (istruct-cell-info cell) (%class.own-wrapper class))
    14651556    class))
    14661557
     
    14961587                     (%cons-wrapper class))))
    14971588      (setf (%class.cpl class) cpl
    1498             (%wrapper-instance-slots wrapper) (vector)           
     1589            (%wrapper-instance-slots wrapper) (vector)
    14991590            (%class.own-wrapper class) wrapper
    15001591            (%class.ctype class) (make-class-ctype class)
    15011592            (%class.slots class) nil
     1593            (%wrapper-class-ordinal wrapper) (%class-ordinal class)
    15021594            (%wrapper-cpl wrapper) cpl
    1503             (find-class name) class)
     1595            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
     1596            (find-class name) class
     1597            )
    15041598      (dolist (sup supers)
    15051599        (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
     
    15781672(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
    15791673      (%wrapper-class *standard-class-wrapper*) *standard-class-class*
     1674      (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*)
    15801675      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
    15811676
     
    16501745                                                              *slot-definition-class*))
    16511746(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
    1652                                                               *slot-definition-class*))
     1747                                                                 *slot-definition-class*))
    16531748(defstatic *standard-direct-slot-definition-class* (make-class
    1654                                                  'standard-direct-slot-definition
    1655                                                  *standard-class-wrapper*
    1656                                                  (list
    1657                                                   *standard-slot-definition-class*
    1658                                                   direct-slot-definition-class)))
     1749                                                    'standard-direct-slot-definition
     1750                                                    *standard-class-wrapper*
     1751                                                    (list
     1752                                                     *standard-slot-definition-class*
     1753                                                     direct-slot-definition-class)))
    16591754
    16601755(defstatic *standard-effective-slot-definition-class* (make-class
     
    16711766
    16721767
     1768
     1769
     1770 
    16731771
    16741772(let ((*dont-find-class-optimize* t)
     
    17631861  (make-istruct-class 'external-entry-point *istruct-class*)
    17641862  (make-istruct-class 'shlib *istruct-class*)
    1765                      
     1863
    17661864  (make-built-in-class 'complex (find-class 'number))
    17671865  (make-built-in-class 'real (find-class 'number))
     
    23582456
    23592457
    2360 ;;; Can't use typep at bootstrapping time.
     2458
    23612459(defun classp (x)
    2362   (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
    2363       (let ((wrapper (standard-object-p x)))
    2364         (or
    2365          (and wrapper
    2366               (let ((super (%wrapper-class wrapper)))
    2367                 (memq *class-class* (%inited-class-cpl super t))))))))
     2460  (if (%standard-instance-p x)
     2461    (< (the fixnum (instance.hash x)) max-class-ordinal)
     2462    (and (typep x 'macptr) (foreign-classp x))))
    23682463
    23692464(set-type-predicate 'class 'classp)
     
    26192714(declaim (inline find-slotd))
    26202715(defun find-slotd (name slots)
    2621   (find name slots :key #'%slot-definition-name))
     2716  (dolist (slotd slots)
     2717    (when (eq name (standard-slot-definition.name slotd))
     2718      (return slotd))))
    26222719
    26232720(declaim (inline %std-slot-vector-value))
     
    26532750           (eq *standard-class-wrapper* (instance.class-wrapper class)))
    26542751    (%std-slot-vector-value (instance-slots instance) slotd)
    2655     (slot-value-using-class class instance slotd)))
     2752    (if (= (the fixnum (typecode instance)) target::subtag-struct)
     2753      (struct-ref instance (standard-effective-slot-definition.location slotd))
     2754      (slot-value-using-class class instance slotd))))
    26562755
    26572756
     
    26972796    ;; Not safe to use instance.slots here, since the instance is not
    26982797    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
    2699     ;; should be inlined here.
     2798    ;; should be inlined here.)
    27002799    (%set-std-slot-vector-value (instance-slots instance) slotd new)
    2701     (setf (slot-value-using-class class instance slotd) new)))
     2800    (if (structurep instance)
     2801      (setf (struct-ref instance (standard-effective-slot-definition.location slotd))
     2802            new)
     2803      (setf (slot-value-using-class class instance slotd) new))))
    27022804
    27032805(defmethod slot-value-using-class ((class funcallable-standard-class)
     
    27142816
    27152817(defun slot-value (instance slot-name)
    2716   (let* ((class (class-of instance))
    2717            (slotd (find-slotd slot-name (%class-slots class))))
    2718       (if slotd
    2719        (slot-value-using-class class instance slotd)
    2720        (restart-case
    2721            (values (slot-missing class instance slot-name 'slot-value))
     2818  (let* ((wrapper
     2819          (let* ((w (instance-class-wrapper instance)))
     2820            (if (eql 0 (%wrapper-hash-index w))
     2821              (instance.class-wrapper (update-obsolete-instance instance))
     2822              w)))
     2823         (class (%wrapper-class wrapper))
     2824         (slotd (find-slotd slot-name (if (%standard-instance-p class)
     2825                                        (%class.slots class)
     2826                                        (class-slots class)))))
     2827    (if slotd
     2828      (%maybe-std-slot-value-using-class class instance slotd)
     2829      (if (typep slot-name 'symbol)
     2830        (restart-case
     2831         (values (slot-missing class instance slot-name 'slot-value))
    27222832         (continue ()
    2723            :report "Try accessing the slot again"
    2724            (slot-value instance slot-name))
     2833                   :report "Try accessing the slot again"
     2834                   (slot-value instance slot-name))
    27252835         (use-value (value)
    2726            :report "Return a value"
    2727            :interactive (lambda ()
    2728                           (format *query-io* "~&Value to use: ")
    2729                           (list (read *query-io*)))
    2730            value)))))
    2731    
     2836                    :report "Return a value"
     2837                    :interactive (lambda ()
     2838                                   (format *query-io* "~&Value to use: ")
     2839                                   (list (read *query-io*)))
     2840                    value))
     2841        (report-bad-arg slot-name 'symbol)))))
    27322842
    27332843
     
    27562866
    27572867(defun set-slot-value (instance name value)
    2758   (let* ((class (class-of instance))
    2759              (slotd (find-slotd  name (%class-slots class))))
    2760         (if slotd
    2761           (setf (slot-value-using-class class instance slotd) value)
    2762           (progn           
    2763             (slot-missing class instance name 'setf value)
    2764             value))))
     2868  (let* ((wrapper
     2869          (let* ((w (instance-class-wrapper instance)))
     2870            (if (eql 0 (%wrapper-hash-index w))
     2871              (instance.class-wrapper (update-obsolete-instance instance))
     2872              w)))
     2873         (class (%wrapper-class wrapper))
     2874         (slotd (find-slotd name (if (%standard-instance-p class)
     2875                                   (%class.slots class)
     2876                                   (class-slots class)))))
     2877    (if slotd
     2878      (%maybe-std-setf-slot-value-using-class class instance slotd value)
     2879      (if (typep name 'symbol)
     2880        (progn     
     2881          (slot-missing class instance name 'setf value)
     2882          value)
     2883        (report-bad-arg name 'symbol)))))
    27652884
    27662885(defsetf slot-value set-slot-value)
     
    27852904                slotd loc (slot-definition-allocation slotd))))))
    27862905
     2906(defun %maybe-std-slot-boundp-using-class (class instance slotd)
     2907  (if (and (eql (typecode class) target::subtag-instance)
     2908           (eql (typecode slotd) target::subtag-instance)
     2909           (eq *standard-effective-slot-definition-class-wrapper*
     2910               (instance.class-wrapper slotd))
     2911           (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2912    (%std-slot-vector-boundp (instance-slots instance) slotd)
     2913    (slot-boundp-using-class class instance slotd)))
     2914
     2915
    27872916(defmethod slot-boundp-using-class ((class standard-class)
    27882917                                    instance
     
    28002929
    28012930(defun slot-boundp (instance name)
    2802   (let* ((class (class-of instance))
    2803          (slotd (find-slotd name (%class-slots class))))
     2931  (let* ((wrapper
     2932          (let* ((w (instance-class-wrapper instance)))
     2933            (if (eql 0 (%wrapper-hash-index w))
     2934              (instance.class-wrapper (update-obsolete-instance instance))
     2935              w)))
     2936         (class (%wrapper-class wrapper))
     2937         (slotd (find-slotd name (if (%standard-instance-p class)
     2938                                   (%class.slots class)
     2939                                   (class-slots class)))))
    28042940    (if slotd
    2805       (slot-boundp-using-class class instance slotd)
    2806       (values (slot-missing class instance name 'slot-boundp)))))
     2941      (%maybe-std-slot-boundp-using-class class instance slotd)
     2942      (if (typep name 'symbol)
     2943        (values (slot-missing class instance name 'slot-boundp))
     2944        (report-bad-arg name 'symbol)))))
    28072945
    28082946(defun slot-value-if-bound (instance name &optional default)
     
    28182956
    28192957(defun slot-id-value (instance slot-id)
    2820   (let* ((wrapper (or (standard-object-p instance)
    2821                     (%class-own-wrapper (class-of instance)))))
     2958  (let* ((wrapper (instance-class-wrapper instance)))
    28222959    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
    28232960
    28242961(defun set-slot-id-value (instance slot-id value)
    2825   (let* ((wrapper (or (standard-object-p instance)
    2826                     (%class-own-wrapper (class-of instance)))))
     2962  (let* ((wrapper (instance-class-wrapper instance)))
    28272963    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
    28282964
     2965(defun slot-id-boundp (instance slot-id)
     2966  (let* ((wrapper (instance-class-wrapper instance))
     2967         (class (%wrapper-class wrapper))
     2968         (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
     2969    (if slotd
     2970      (%maybe-std-slot-boundp-using-class class instance slotd)
     2971      (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp)))))
     2972 
    28292973;;; returns nil if (apply gf args) wil cause an error because of the
    28302974;;; non-existance of a method (or if GF is not a generic function or the name
     
    29093053       (setf (%wrapper-hash-index wrapper) 0
    29103054             (%wrapper-cpl wrapper) nil
     3055             (%wrapper-cpl-bits wrapper) nil
    29113056             (%wrapper-instance-slots wrapper) 0
    29123057             (%wrapper-forwarding-info wrapper) forwarding-info
     
    32003345  (let ((wrapper (standard-object-p instance)))
    32013346    (unless wrapper
    3202       (if (standard-generic-function-p instance)
    3203         (setq wrapper (generic-function-wrapper instance))
    3204         (when (typep instance 'funcallable-standard-object)
    3205           (setq wrapper (gf.instance.class-wrapper instance))))
     3347              (when (typep instance 'funcallable-standard-object)
     3348          (setq wrapper (gf.instance.class-wrapper instance)))
    32063349     
    32073350      (unless wrapper
    3208         (report-bad-arg instance '(or standard-object standard-generic-function))))
     3351        (report-bad-arg instance '(or standard-object funcallable-standard-object))))
    32093352    (when (eql 0 (%wrapper-hash-index wrapper))
    32103353      (update-obsolete-instance instance)))
     
    32323375  (%change-class instance new-class initargs))
    32333376
    3234 (defmethod change-class ((instance funcallable-standard-object)
    3235                          (new-class funcallable-standard-class)
    3236                          &rest initargs &key &allow-other-keys)
    3237   (declare (dynamic-extent initargs))
    3238   (%change-class instance new-class initargs))
    3239  
    32403377
    32413378(defun %change-class (object new-class initargs)
     
    34353572(defmethod no-applicable-method (gf &rest args)
    34363573  (cerror "Try calling it again"
    3437           "No applicable method for args:~% ~s~% to ~s" args gf)
     3574          "There is no applicable method for the generic function:~%  ~s~%when called with arguments:~%  ~s" gf args)
    34383575  (apply gf args))
    34393576
     
    36123749
    36133750
    3614 (defun generic-function-wrapper (gf)
    3615   (unless (inherits-from-standard-generic-function-p (class-of gf))
    3616     (%badarg gf 'standard-generic-function))
    3617   (gf.instance.class-wrapper gf))
     3751
     3752
     3753                                   
     3754
     3755
    36183756
    36193757(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
     
    36723810                 (error "Can't find structure named ~s" class-name)))
    36733811         (res (make-structure-vector (sd-size sd))))
    3674     (setf (%svref res 0) (sd-superclasses sd))
     3812    (setf (%svref res 0) (mapcar (lambda (x)
     3813                                   (find-class-cell x t)) (sd-superclasses sd)))
    36753814    res))
    36763815
  • trunk/source/level-1/l1-clos.lisp

    r10423 r10426  
    150150           documentation class nil (ensure-slot-id name) #'true)))
    151151
    152 (defmethod class-slots ((class class)))
    153 (defmethod class-direct-slots ((class class)))
    154 (defmethod class-default-initargs ((class class)))
    155 (defmethod class-direct-default-initargs ((class class)))
    156152
    157153(defmethod compile-time-class-p ((class class)) nil)
     
    505501
    506502(defun forward-referenced-class-p (class)
    507   (typep class 'forward-referenced-class))
    508 
    509 ;;; This uses the primary class information to sort a class'es slots
     503  (and (%standard-instance-p class)
     504       (eq (%class-of-instance class) *forward-referenced-class-class*)))
     505
     506;;; This uses the primary class information to sort the slots of a class.
    510507(defun sort-effective-instance-slotds (slotds class cpl)
    511508  (let (primary-slotds
     
    636633      (let* ((wrapper (%class-own-wrapper class)))
    637634        (when wrapper
    638           (setf (%wrapper-cpl wrapper) cpl)))))
     635          (setf (%wrapper-cpl wrapper) cpl
     636                (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))))
    639637  (unless finalizep
    640638    (dolist (sub (%class-direct-subclasses class))
     
    775773    (setf (find-class name) class)))
    776774           
     775;; Can't go with optimize-make-instance-for-class-name because
     776;; ensure-class-using-class is called before that is defined.
     777(defun pessimize-make-instance-for-class-name (class-name)
     778  (let ((cell (find-class-cell class-name nil)))
     779    (when cell
     780      (setf (class-cell-instantiate cell) '%make-instance))))
     781
    777782;;; Redefine an existing (not forward-referenced) class.
    778783(defmethod ensure-class-using-class ((class class) name &rest keys &key)
     
    781786    (unless (eq (class-of class) metaclass)
    782787      (error "Can't change metaclass of ~s to ~s." class metaclass))
     788    (pessimize-make-instance-for-class-name name)
    783789    (apply #'reinitialize-instance class initargs)
    784790    (setf (find-class name) class)))
     
    786792
    787793(defun ensure-class (name &rest keys &key &allow-other-keys)
    788   (apply #'ensure-class-using-class (find-class name nil) name keys))
     794  (declare (special *sealed-clos-world*))
     795  (if *sealed-clos-world*
     796    (error "Class (re)definition is not allowed in this environment")
     797    (apply #'ensure-class-using-class (find-class name nil) name keys)))
    789798
    790799(defparameter *defclass-redefines-improperly-named-classes-pedantically*
     
    796805
    797806(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
    798   (record-source-file name 'class)
    799   ;; Maybe record source-file information for accessors as well
    800   ;; We should probably record them as "accessors of the class", since
    801   ;; there won't be any other explicit defining form associated with
    802   ;; them.
    803   (let* ((existing-class (find-class name nil)))
    804     (when (and *defclass-redefines-improperly-named-classes-pedantically*
    805                existing-class
    806               (not (eq (class-name existing-class) name)))
    807       ;; Class isn't properly named; act like it didn't exist
    808       (setq existing-class nil))
    809     (apply #'ensure-class-using-class existing-class name keys)))
     807  (declare (special *sealed-clos-world*))
     808  (if *sealed-clos-world*
     809    (error "Class (re)definition is not allowed in this environment")
     810    (progn
     811      (record-source-file name 'class)
     812      ;; Maybe record source-file information for accessors as well
     813      ;; We should probably record them as "accessors of the class", since
     814      ;; there won't be any other explicit defining form associated with
     815      ;; them.
     816      (let* ((existing-class (find-class name nil)))
     817        (when (and *defclass-redefines-improperly-named-classes-pedantically*
     818                   existing-class
     819                   (not (eq (class-name existing-class) name)))
     820          ;; Class isn't properly named; act like it didn't exist
     821          (setq existing-class nil))
     822        (apply #'ensure-class-using-class existing-class name keys)))))
    810823
    811824
     
    9961009   (:name direct-subclasses  :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
    9971010   (:name dependents :initform nil :initfunction ,#'false)
    998    (:name class-ctype :initform nil :initfunction ,#'false))
     1011   (:name class-ctype :initform nil :initfunction ,#'false)
     1012   (:name direct-slots :initform nil :initfunction ,#'false
     1013                  :readers (class-direct-slots)
     1014                  :writers ((setf class-direct-slots)))
     1015   (:name slots :initform nil :initfunction ,#'false
     1016    :readers (class-slots)
     1017    :writers ((setf class-slots)))
     1018   (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info))
     1019   (:name direct-default-initargs  :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
     1020   (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs)))
    9991021 :primary-p t)
    10001022
     
    10131035 'slots-class
    10141036 :direct-superclasses '(class)
    1015  :direct-slots `((:name direct-slots :initform nil :initfunction ,#'false
    1016                    :readers (class-direct-slots)
    1017                   :writers ((setf class-direct-slots)))
    1018                  (:name slots :initform nil :initfunction ,#'false
    1019                    :readers (class-slots))
    1020                  (:name kernel-p :initform nil :initfunction ,#'false)
    1021                  (:name direct-default-initargs  :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
    1022                  (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs))
    1023                  (:name alist :initform nil  :initfunction ,#'false))
     1037 :direct-slots `((:name alist :initform nil  :initfunction ,#'false))
    10241038 :primary-p t)
    10251039
     
    11291143                  :initfunction ,#'false :readers (slot-definition-writers))))
    11301144
    1131 
    11321145(%ensure-class-preserving-wrapper
    11331146 'effective-slot-definition
     
    11591172 :direct-superclasses '(standard-slot-definition direct-slot-definition)
    11601173)
    1161 
    11621174
    11631175(%ensure-class-preserving-wrapper
     
    12361248                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
    12371249           (cpl (compute-cpl class)))
    1238       (setf (%wrapper-cpl wrapper) cpl))))
     1250      (setf (%class.cpl class) cpl)
     1251      (setf (%wrapper-cpl wrapper) cpl
     1252            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))
    12391253             
    12401254
     
    13151329          (setf (slot-value class 'direct-superclasses) new))
    13161330      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
    1317       (fdefinition '%class-own-wrapper) #'class-own-wrapper
     1331      ;(fdefinition '%class-own-wrapper) #'class-own-wrapper
    13181332      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
    13191333)
     
    14601474(defmethod initialize-instance :before ((instance generic-function)
    14611475                                       &key &allow-other-keys)
    1462 
    14631476  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
    14641477
     
    17021715    (clear-type-cache))
    17031716  (reinitialize-instance class :name new)
     1717  (setf (%class-proper-name class)
     1718        (if (eq (find-class new nil) class)
     1719          new))
    17041720  new)
    17051721
     
    18081824
    18091825(defun optimize-dispatching-for-gf (gf)
    1810   (let* ((dcode (%gf-dcode gf)))
    1811     (when (or (eq dcode #'%%one-arg-dcode)
    1812               (eq dcode #'%%nth-arg-dcode))
     1826  (let* ((dcode (%gf-dcode gf))
     1827         (name (function-name dcode)))
     1828    (when (or (eq name '%%one-arg-dcode)
     1829              (eq name '%%nth-arg-dcode))
    18131830      (let ((methods (generic-function-methods gf)))
    18141831        (when (and methods (null (cdr methods)))
     
    18221839            (override-one-method-one-arg-dcode gf (car methods))))))))
    18231840
     1841(defparameter *unique-reader-dcode-functions* t)
     1842
    18241843;;; dcode for a GF with a single reader method which accesses
    18251844;;; a slot in a class that has no subclasses (that restriction
     
    18281847(defun singleton-reader-dcode (dt instance)
    18291848  (declare (optimize (speed 3) (safety 0)))
    1830   (let* ((class (%svref dt %gf-dispatch-table-first-data))
     1849  (let* ((wrapper (%svref dt %gf-dispatch-table-first-data))
    18311850         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
    18321851    (if (eq (if (eq (typecode instance) target::subtag-instance)
    1833               (%class-of-instance instance))
    1834             class)
     1852              (instance.class-wrapper instance))
     1853            wrapper)
    18351854      (%slot-ref (instance.slots instance) location)
    1836       (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1855      (cond ((and (eq (typecode instance) target::subtag-instance)
     1856                  (eq 0 (%wrapper-hash-index (instance.class-wrapper instance)))
     1857                  (progn (update-obsolete-instance instance)
     1858                         (eq (instance.class-wrapper instance) wrapper)))
     1859             (%slot-ref (instance.slots instance) location))
     1860            (t (no-applicable-method (%gf-dispatch-table-gf dt) instance))))))
    18371861(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
    18381862
     
    18421866(defun reader-constant-location-dcode (dt instance)
    18431867  (declare (optimize (speed 3) (safety 0)))
    1844   (let* ((classes (%svref dt %gf-dispatch-table-first-data))
    1845          (location (%svref dt (1+ %gf-dispatch-table-first-data))))
    18461868    (if (memq (if (eq (typecode instance) target::subtag-instance)
    18471869              (%class-of-instance instance))
    1848             classes)
    1849       (%slot-ref (instance.slots instance) location)
    1850       (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1870              (%svref dt %gf-dispatch-table-first-data))
     1871      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
     1872      (no-applicable-method (%gf-dispatch-table-gf dt) instance)))
    18511873(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*)
    18521874
     
    18541876;;; slot in one or more classes which have multiple subclasses, all of
    18551877;;; which (by luck or design) have the same slot-definition location.
    1856 ;;; The number of classes is for which the method is applicable is
    1857 ;;; large, but all are subclasses of a single class
     1878;;; The number of classes for which the method is applicable is
     1879;;; potentially large, but all are subclasses of a single class
    18581880(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
    18591881  (declare (optimize (speed 3) (safety 0)))
    1860   (let* ((defining-class (%svref dt %gf-dispatch-table-first-data))
    1861          (location (%svref dt (1+ %gf-dispatch-table-first-data)))
    1862          (class (if (eq (typecode instance) target::subtag-instance)
    1863                   (%class-of-instance instance))))
    1864     (if (and class (memq defining-class (or (%class.cpl class)
    1865                                             (%inited-class-cpl class))))
    1866       (%slot-ref (instance.slots instance) location)
     1882  (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data))
     1883         (bits  (let* ((wrapper
     1884                        (if (eq (typecode instance) target::subtag-instance)
     1885                          (instance.class-wrapper instance))))
     1886                  (when wrapper (or (%wrapper-cpl-bits wrapper)
     1887                                    (make-cpl-bits (%inited-class-cpl
     1888                                                    (%wrapper-class wrapper))))))))
     1889    (declare (fixnum defining-class-ordinal))
     1890    (if (and bits
     1891             (< defining-class-ordinal (the fixnum (uvsize bits)))
     1892             (not (eql 0 (sbit bits defining-class-ordinal))))
     1893      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
    18671894      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    18681895(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*)
     1896
     1897;;; It may be faster to make individual functions that take their
     1898;;; "parameters" (defining class ordinal, slot location) as constants.
     1899;;; It may not be.  Use *unique-reader-dcode-functions* to decide
     1900;;; whether or not to do so.
     1901(defun make-reader-constant-location-inherited-from-single-class-dcode
     1902    (defining-class-ordinal location gf)
     1903  (if *unique-reader-dcode-functions*
     1904    (let* ((gf-name (function-name gf)))
     1905      (values
     1906       (%make-function
     1907        `(slot-reader for ,gf-name)
     1908        `(lambda (instance)
     1909          (locally (declare (optimize (speed 3) (safety 0)))
     1910            (let* ((bits (let* ((wrapper
     1911                                 (if (eq (typecode instance) target::subtag-instance)
     1912                                   (instance.class-wrapper instance))))
     1913                           (when wrapper (or (%wrapper-cpl-bits wrapper)
     1914                                             (make-cpl-bits (%inited-class-cpl
     1915                                                             (%wrapper-class wrapper))))))))
     1916              (if (and bits
     1917                       (< ,defining-class-ordinal (the fixnum (uvsize bits)))
     1918                       (not (eql 0 (sbit bits ,defining-class-ordinal))))
     1919                (%slot-ref (instance.slots instance) ,location)
     1920                (no-applicable-method (function ,gf-name) instance)))))
     1921        nil)
     1922       #'funcallable-trampoline))
     1923    (let* ((dt (gf.dispatch-table gf)))
     1924      (setf (%svref dt %gf-dispatch-table-first-data)
     1925            defining-class-ordinal
     1926            (%svref dt (1+ %gf-dispatch-table-first-data))
     1927            location)
     1928      (values
     1929       (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode)
     1930       (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist))))))
    18691931
    18701932;;; Dcode for a GF whose methods are all reader-methods which access a
     
    18751937(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance)
    18761938  (declare (optimize (speed 3) (safety 0)))
    1877   (let* ((location (%svref dt (1+ %gf-dispatch-table-first-data)))
    1878          (class (if (eq (typecode instance) target::subtag-instance)
    1879                   (%class-of-instance instance)))
    1880          (cpl (if class (or (%class.cpl class) (%inited-class-cpl class)))))
    1881     (if (dolist (defining-class (%svref dt %gf-dispatch-table-first-data))
    1882           (when (memq defining-class cpl) (return t)))
    1883       (%slot-ref (instance.slots instance) location)
     1939  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
     1940                    (instance.class-wrapper instance)))
     1941         (bits (if wrapper (or (%wrapper-cpl-bits wrapper)
     1942                               (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1943         (nbits (if bits (uvsize bits) 0)))
     1944    (declare (fixnum nbits))
     1945    (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data))
     1946          (declare (fixnum ordinal))
     1947          (when (and (< ordinal nbits)
     1948                     (not (eql 0 (sbit bits ordinal))))
     1949            (return t)))
     1950      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
    18841951      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    18851952(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*)
     
    19321999                  (when (subtypep class other) (return nil))))
    19332000          (unique class))))))
     2001
     2002
    19342003
    19352004;;; Try to replace gf dispatch with something faster in f.
     
    19612030              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
    19622031                (clear-gf-dispatch-table dt)
     2032                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
    19632033                (cond ((null (cdr alist))
    19642034                       ;; Method is only applicable to a single class.
    19652035                       (destructuring-bind (class . location) (car alist)
    1966                          (setf (%svref dt %gf-dispatch-table-first-data) class
     2036                         (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class)
    19672037                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
    1968                                (gf.dcode f) #'singleton-reader-dcode)))
     2038                               (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode))))
    19692039                      ((dolist (other (cdr alist) t)
    19702040                         (unless (eq (cdr other) loc)
     
    19792049                                (%svref dt (1+ %gf-dispatch-table-first-data))
    19802050                                loc
    1981                                 (gf.dcode f) #'reader-constant-location-dcode))
     2051                                (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode)))
    19822052                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
    19832053                          ;; Lots of classes, all subclasses of a single class
    1984                           (setf (%svref dt %gf-dispatch-table-first-data)
    1985                                 (car classes)
    1986                                 (%svref dt (1+ %gf-dispatch-table-first-data))
    1987                                 loc
    1988                                 (gf.dcode f)
    1989                                 #'reader-constant-location-inherited-from-single-class-dcode))
     2054                          (multiple-value-bind (dcode trampoline)
     2055                              (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f)
     2056                            (setf (gf.dcode f) dcode)
     2057                            (replace-function-code f trampoline)))
    19902058                         (t
    19912059                          ;; Multple classes.  We should probably check
    19922060                          ;; to see they're disjoint
    19932061                          (setf (%svref dt %gf-dispatch-table-first-data)
    1994                                 classes
     2062                                (mapcar #'%class-ordinal classes)
    19952063                                (%svref dt (1+ %gf-dispatch-table-first-data))
    19962064                                loc
    19972065                                (gf.dcode f)
    1998                                 #'reader-constant-location-inherited-from-multiple-classes-dcode))))
     2066                                (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode)))))
    19992067                      (t
    20002068                       ;; Multiple classes; the slot's location varies.
     
    20022070                             alist
    20032071                             
    2004                              (gf.dcode f) #'reader-variable-location-dcode)))))))))))
     2072                             (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode))))))))))))
    20052073
    20062074;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
     
    20182086      ;;; Let %%1st-arg-dcode deal with it.
    20192087      (%%1st-arg-dcode dt args))))
     2088(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*)
    20202089
    20212090(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
     
    20242093      (funcall mf arg1 arg2)
    20252094      (%%1st-two-arg-dcode dt arg1 arg2))))
    2026 (register-dcode-proto #'reader-variable-location-dcode *gf-proto-two-arg*)
     2095(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*)
    20272096
    20282097(defun %%one-arg-eql-method-hack-dcode (dt arg)
     
    20412110                          (logbitp $lfbits-aok-bit bits))))
    20422111    (setf (%gf-dcode gf)
    2043           (cond ((and (eql nreq 1) (null other-args?))
    2044                  #'%%one-arg-eql-method-hack-dcode)
    2045                 ((and (eql nreq 2) (null other-args?))
    2046                  #'%%1st-two-arg-eql-method-hack-dcode)
    2047                 (t
    2048                  #'%%1st-arg-eql-method-hack-dcode)))))
    2049 
     2112          (dcode-for-gf gf
     2113                        (cond ((and (eql nreq 1) (null other-args?))
     2114                               #'%%one-arg-eql-method-hack-dcode)
     2115                              ((and (eql nreq 2) (null other-args?))
     2116                               #'%%1st-two-arg-eql-method-hack-dcode)
     2117                              (t
     2118                               #'%%1st-arg-eql-method-hack-dcode))))))
    20502119
    20512120(defun maybe-hack-eql-methods (gf)
     
    22942363           %find-classes%))
    22952364
     2365;; Redefined from bootstrapping verison in l1-clos-boot.lisp
     2366;; Remove the make-instance optimization if the user is adding
     2367;; a method on initialize-instance, allocate-instance, or shared-initialize
     2368(defun maybe-remove-make-instance-optimization (gfn method)
     2369  (when (or (eq gfn #'allocate-instance)
     2370            (eq gfn #'initialize-instance)
     2371            (eq gfn #'shared-initialize))
     2372    (let* ((specializer (car (method-specializers method)))
     2373           (cell (and (typep specializer 'class)
     2374                      (gethash (class-name specializer) %find-classes%))))
     2375      (when cell
     2376        (setf (class-cell-instantiate cell) '%make-instance)))))           
     2377
    22962378;;; Iterate over all known GFs; try to optimize their dcode in cases
    22972379;;; involving reader methods.
     
    23002382                                 (check-conflicts t)
    23012383                                 (optimize-make-instance t))
    2302   (declare (ignore check-conflicts))
     2384  (declare (ignore check-conflicts)
     2385           (special *sealed-clos-world*))
    23032386  (unless known-sealed-world
    23042387    (cerror "Proceed, if it's known that no new classes or methods will be defined."
     
    23122395      (when (%snap-reader-method f)
    23132396        (incf nwin)))
     2397    (setq *sealed-clos-world* t)
    23142398    (values ngf nwin 0)))
    23152399
     
    23252409      f)))
    23262410
     2411(defun pessimize-clos ()
     2412  (declare (special *sealed-clos-world*))
     2413  (when *sealed-clos-world*
     2414    ;; Undo MAKE-INSTANCE optimization
     2415    (maphash (lambda (class-name class-cell)
     2416               (declare (ignore class-name))
     2417               (setf (class-cell-instantiate class-cell) '%make-instance))
     2418             %find-classes%)
     2419    ;; Un-snap reader methods, undo other GF optimizations.
     2420    (dolist (f (population-data %all-gfs%))
     2421      (let* ((dt (%gf-dispatch-table f)))
     2422        (clear-gf-dispatch-table dt)
     2423        (compute-dcode f)))
     2424    (setq *sealed-clos-world* nil)
     2425    t))
     2426
     2427;;; If there's a single method (with standard method combination) on
     2428;;; GF and all of that method's arguments are specialized to the T
     2429;;; class - and if the method doesn't accept &key - we can just have
     2430;;; the generic function call the method-function
    23272431(defun dcode-for-universally-applicable-singleton (gf)
    23282432  (when (eq (generic-function-method-combination gf)
     
    23402444
    23412445(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton)
    2342 
    2343 
    2344 
    2345 
    2346      
  • trunk/source/level-1/l1-dcode.lisp

    r9845 r10426  
    294294
    295295(defun %find-1st-arg-combined-method (dt arg)
    296   (declare (optimize (speed 3)(safety 0)))
    297   (flet ((get-wrapper (arg)
    298            (if (not (%standard-instance-p arg))
    299              (or (and (typep arg 'macptr)
    300                       (foreign-instance-class-wrapper arg))
    301                  (and (generic-function-p arg)
    302                       (gf.instance.class-wrapper arg))
    303                  (let* ((class (class-of arg)))
    304                    (or (%class.own-wrapper class)
    305                        (progn
    306                          (update-class class nil)
    307                          (%class.own-wrapper class)))))
    308              (instance.class-wrapper arg))))
    309     (declare (inline get-wrapper))
    310     (let ((wrapper (get-wrapper arg)))
    311       (when (eql 0 (%wrapper-hash-index wrapper))
    312         (update-obsolete-instance arg)
    313         (setq wrapper (get-wrapper arg)))
    314       (let* ((mask (%gf-dispatch-table-mask dt))
    315              (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
    316              table-wrapper flag)
    317         (declare (fixnum index mask))
    318         (loop
    319           (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
    320             (return (%gf-dispatch-table-ref dt  (the fixnum (1+ index))))
    321             (progn
    322               (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
    323                 (if (or (neq table-wrapper (%unbound-marker))
    324                         (eql 0 flag))
    325                   (without-interrupts   ; why?
    326                    (return (1st-arg-combined-method-trap (%gf-dispatch-table-gf dt) wrapper arg))) ; the only difference?
    327                   (setq flag 0 index -2)))
    328               (setq index (+ 2 index)))))))))
     296  (let ((wrapper (instance-class-wrapper arg)))
     297    (when (eql 0 (%wrapper-hash-index wrapper))
     298      (update-obsolete-instance arg)
     299      (setq wrapper (instance-class-wrapper arg)))
     300    (let* ((mask (%gf-dispatch-table-mask dt))
     301           (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
     302           table-wrapper flag)
     303      (declare (fixnum index mask))
     304      (loop
     305        (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
     306          (return (%gf-dispatch-table-ref dt  (the fixnum (1+ index))))
     307          (progn
     308            (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
     309              (if (or (neq table-wrapper (%unbound-marker))
     310                      (eql 0 flag))
     311                (without-interrupts     ; why?
     312                 (return (1st-arg-combined-method-trap (%gf-dispatch-table-gf dt) wrapper arg))) ; the only difference?
     313                (setq flag 0 index -2)))
     314            (setq index (+ 2 index))))))))
    329315
    330316;;; for calls from outside - e.g. stream-reader
     
    338324(defun %find-nth-arg-combined-method (dt arg args) 
    339325  (declare (optimize (speed 3)(safety 0)))
    340   (flet ((get-wrapper (arg)
    341            (if (not (%standard-instance-p arg))
    342              (or (and (typep arg 'macptr)
    343                       (foreign-instance-class-wrapper arg))
    344                  (and (generic-function-p arg)
    345                       (gf.instance.class-wrapper arg))
    346                  (let* ((class (class-of arg)))
    347                    (or (%class.own-wrapper class)
    348                        (progn
    349                          (update-class class nil)
    350                          (%class.own-wrapper class)))))
    351              (instance.class-wrapper arg))))
    352     (declare (inline get-wrapper))
    353     (let ((wrapper (get-wrapper arg)))
    354       (when (eql 0 (%wrapper-hash-index wrapper))
    355         (update-obsolete-instance arg)
    356         (setq wrapper (get-wrapper arg)))
    357       (let* ((mask (%gf-dispatch-table-mask dt))
    358              (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
    359              table-wrapper flag)
    360         (declare (fixnum index mask))
    361         (loop
    362           (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
    363             (return (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
    364             (progn
    365               (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
    366                 (if (or (neq table-wrapper (%unbound-marker))
    367                         (eql 0 flag))
    368                   (without-interrupts ; why?
    369                    (let ((gf (%gf-dispatch-table-gf dt)))
    370                      (if (listp args)
    371                        (return (nth-arg-combined-method-trap-0 gf dt wrapper args))
    372                        (with-list-from-lexpr (args-list args)
    373                          (return (nth-arg-combined-method-trap-0 gf dt wrapper args-list))))))
    374                   (setq flag 0 index -2)))
    375               (setq index (+ 2 index)))))))))
     326  (let ((wrapper (instance-class-wrapper arg)))
     327    (when (eql 0 (%wrapper-hash-index wrapper))
     328      (update-obsolete-instance arg)
     329      (setq wrapper (instance-class-wrapper arg)))
     330    (let* ((mask (%gf-dispatch-table-mask dt))
     331           (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper))))
     332           table-wrapper flag)
     333      (declare (fixnum index mask))
     334      (loop
     335        (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper)
     336          (return (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
     337          (progn
     338            (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index))))
     339              (if (or (neq table-wrapper (%unbound-marker))
     340                      (eql 0 flag))
     341                (without-interrupts     ; why?
     342                 (let ((gf (%gf-dispatch-table-gf dt)))
     343                   (if (listp args)
     344                     (return (nth-arg-combined-method-trap-0 gf dt wrapper args))
     345                     (with-list-from-lexpr (args-list args)
     346                       (return (nth-arg-combined-method-trap-0 gf dt wrapper args-list))))))
     347                (setq flag 0 index -2)))
     348            (setq index (+ 2 index))))))))
    376349
    377350
     
    539512  (setf (combined-method.dcode cm) val))
    540513
     514(declaim (inline funcallable-instance-p))
    541515(defun funcallable-instance-p (thing)
    542516  (when (typep thing 'function)
     
    547521                               (ash 1 $lfbits-method-bit)))))))
    548522
     523(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p)
     524
    549525(defstatic *generic-function-class-wrapper* nil)
    550526(defstatic *standard-generic-function-class-wrapper* nil)
    551527
    552528(defun generic-function-p (thing)
    553   (and (typep thing 'function)
    554        (let ((bits (lfun-bits-known-function thing)))
    555          (declare (fixnum bits))
    556          (eq (ash 1 $lfbits-gfn-bit)
    557              (logand bits (logior (ash 1 $lfbits-gfn-bit)
    558                                   (ash 1 $lfbits-method-bit)))))
     529  (and (typep thing 'funcallable-standard-object)
    559530       (let* ((wrapper (gf.instance.class-wrapper thing)))
    560531         ;; In practice, many generic-functions are standard-generic-functions.
    561532         (or (eq *standard-generic-function-class-wrapper* wrapper)
    562533             (eq *generic-function-class-wrapper* wrapper)
    563              (memq  *generic-function-class*
    564                   (%inited-class-cpl (class-of thing)))))))
     534             (let* ((bits (or (%wrapper-cpl-bits wrapper)
     535                              (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))
     536                    (ordinal (%wrapper-class-ordinal *generic-function-class-wrapper*)))
     537               (and bits ordinal
     538                    (locally (declare (simple-bit-vector bits)
     539                                      (fixnum ordinal)
     540                                      (optimize (speed 3) (safety 0)))
     541                      (and (< ordinal (length bits))
     542                           (eql 1 (sbit bits ordinal))))))))))
    565543
    566544
     
    807785
    808786(register-dcode-proto #'%%0-arg-dcode *gf-proto*)
    809 
    810787
    811788(defun dcode-too-few-args (arg-count cm-or-gf)
     
    15341511
    15351512
     1513
    15361514(defun %%hash-table-combined-method-dcode (stuff args)
    15371515  ;; stuff is (argnum eql-hash-table . default-method)
  • trunk/source/level-1/l1-error-signal.lisp

    r8384 r10426  
    123123                nil))))
    124124
    125 
    126125(defun %error (condition args error-pointer)
    127126  (setq *error-reentry-count* 0)
  • trunk/source/level-1/l1-error-system.lisp

    r10356 r10426  
    7979(define-condition simple-error (simple-condition error) ())
    8080
    81 (define-condition simple-storage-condition (simple-condition storage-condition)())
     81(define-condition simple-storage-condition (simple-condition storage-condition) ())
    8282(define-condition stack-overflow-condition (simple-storage-condition) ())
    8383
     
    136136(define-condition cant-construct-arglist (improper-list)
    137137  ())
    138 
    139138
    140139
     
    492491                  (apply #'format stream (simple-condition-format-control c)
    493492                         (simple-condition-format-arguments c)))))
     493
     494(define-condition external-process-creation-failure (serious-condition)
     495  ((proc :initarg :proc))
     496  (:report (lambda (c stream)
     497             (with-slots (proc) c
     498               (let* ((code (external-process-%exit-code proc)))
     499                 (format stream "Fork failed in ~s: ~a. " proc (if (eql code -1) "random lisp error" (%strerror code))))))))
     500   
    494501                         
    495502(defun restartp (thing)
     
    987994
    988995
    989 (defun %check-type (value typespec placename typename)
    990   (let ((condition (make-condition 'type-error
    991                                    :datum value
    992                                    :expected-type typespec)))
    993     (if typename
    994       (setf (slot-value condition 'format-control)
    995             (format nil "value ~~S is not ~A (~~S)." typename)))
    996     (restart-case (%error condition nil (%get-frame-ptr))
    997                   (store-value (newval)
    998                                :report (lambda (s)
    999                                          (format s "Assign a new value of type ~a to ~s" typespec placename))
    1000                                :interactive (lambda ()
    1001                                               (format *query-io* "~&New value for ~S :" placename)
    1002                                               (list (eval (read))))
    1003                                newval))))
    1004996
    1005997
  • trunk/source/level-1/l1-format.lisp

    r6940 r10426  
    2626  (defmacro defformat (char name &rest def)
    2727    `(progn
    28        (add-format-char ,char (function (lambda . ,def)))
     28       (add-format-char ,char (nfunction ,name (lambda . ,def)))
    2929       ',name))
    3030  )
     
    6464; *format-control-string* and *format-length*, before returning.
    6565
    66 (defun sub-format (stream *format-index* *format-length* &aux (string *format-control-string*) char)
    67   (prog* ((length *format-length*) (i *format-index*) (lastpos i))
    68     (declare (fixnum i length lastpos))
     66(defun sub-format (stream *format-index* *format-length* &aux char)
     67  (prog* ((string (require-type *format-control-string* 'simple-string))
     68          (length *format-length*)
     69          (i *format-index*)
     70          (lastpos i))
     71    (declare (fixnum i length lastpos) (type simple-string string))
    6972    (go START)
    7073    EOF-ERROR
     
    7982        (let* ((limit (the fixnum (1- i))))
    8083          (unless (= limit lastpos)
    81             (write-string string stream :start  lastpos :end limit)))
     84            (write-simple-string string stream  lastpos limit)))
    8285        (let ((params nil) (fn) (colon nil) (atsign nil))
    8386          (block nil
     
    132135
    133136
    134 #|
     137#||
    135138(eval-when (load)
    136139  ;The non-consing version.
     
    284287) ;end of eval-when (load)
    285288
    286 |#
    287 
    288 ;Interim definitions
    289 
    290 ;This function is shadowed by CCL in order to use ~{ to print error messages.
     289||#
     290
     291;;;Interim definitions
     292
     293;;;This function is shadowed by CCL in order to use ~{ to print error messages.
    291294(defun format (stream control-string &rest format-arguments)
    292295  (declare (dynamic-extent format-arguments))
    293   (when (eq stream t) (setq stream *standard-output*))
    294296  (when (null stream)
    295297   (return-from format
    296298    (with-output-to-string (x)
    297299     (apply #'format x control-string format-arguments))))
    298   (unless (streamp stream) (report-bad-arg stream 'stream))
     300  (if (eq stream t)
     301    (setq stream *standard-output*)
     302    (unless (streamp stream) (report-bad-arg stream 'stream)))
    299303  (if (functionp control-string)
    300304    (apply control-string stream format-arguments)
  • trunk/source/level-1/l1-io.lisp

    r10352 r10426  
    101101        (stream-write-string stream string start end)))
    102102  string))
     103
     104(defun write-simple-string (string output-stream start end)
     105  "Write the characters of the subsequence of simple-string STRING bounded by START
     106and END to OUTPUT-STREAM."
     107  (let* ((stream (%real-print-stream output-stream))
     108         (string (the simple-string string))) ;; typecheck at high safety.
     109    (if (typep stream 'basic-stream)
     110      (let* ((ioblock (basic-stream-ioblock stream))
     111             (start (or start 0)))
     112        (with-ioblock-output-locked (ioblock)
     113          (if (and (eq start 0) (null end))
     114            (funcall (ioblock-write-simple-string-function ioblock)
     115                     ioblock string 0 (length string))
     116            (let* ((end (check-sequence-bounds string start end)))
     117              (funcall (ioblock-write-simple-string-function ioblock)
     118                       ioblock string start  (%i- end start))))))
     119      (if (and (not start) (not end))
     120        (stream-write-string stream string)
     121        (stream-write-string stream string start end)))
     122    string))
    103123
    104124(defun write-line (string &optional output-stream
     
    942962  (declare (type string string) (type character delim)
    943963           (type stream stream))
    944   (stream-write-char stream delim)
     964  (write-char delim stream)
    945965  (do* ((limit (length string))
    946966        (i 0 (1+ i)))
     
    950970           (needs-escape? (%char-needs-escape-p char #\\ delim)))
    951971      (if needs-escape?
    952           (stream-write-char stream #\\))
    953       (stream-write-char stream char)))
    954   (stream-write-char stream delim))
     972          (write-char #\\ stream))
     973      (write-char char stream)))
     974  (write-char delim stream))
    955975
    956976
  • trunk/source/level-1/l1-numbers.lisp

    r10211 r10426  
    423423(defun %cons-random-state (seed-1 seed-2)
    424424  #+32-bit-target
    425   (%istruct
    426    'random-state
    427    seed-1
    428    seed-2)
     425  (%istruct 'random-state seed-1 seed-2)
    429426  #+64-bit-target
    430   (%istruct
    431    'random-state
    432    (the fixnum (+ (the fixnum seed-2)
    433                   (the fixnum (ash (the fixnum seed-1) 16))))))
     427  (%istruct 'random-state (the fixnum (+ (the fixnum seed-2)
     428                          (the fixnum (ash (the fixnum seed-1) 16))))))
    434429
    435430;;; random associated stuff except for the print-object method which
  • trunk/source/level-1/l1-pathnames.lisp

    r10276 r10426  
    629629     
    630630             
     631
    631632(defun ccl-directory ()
    632633  (let* ((dirpath (getenv "CCL_DEFAULT_DIRECTORY")))
     
    635636      (make-pathname :directory (pathname-directory (%realpath (heap-image-name)))))))
    636637
    637 
    638638(defun user-homedir-pathname (&optional host)
    639639  "Return the home directory of the user as a pathname."
    640   (declare (ignore host)) 
    641   (let* ((native (get-user-home-dir (getuid))))
    642     (if native
    643       (native-to-directory-pathname native))))
    644 
    645 
    646 
    647 (defloadvar *user-homedir-pathname* (user-homedir-pathname))
     640  (declare (ignore host))
     641  (let* ((native
     642          (ignore-errors
     643            (truename
     644             (native-to-directory-pathname (or #+ccl-0711 (getenv "HOME")
     645                                               (get-user-home-dir (getuid))))))))
     646    (if (and native (eq :absolute (car (pathname-directory native))))
     647      native
     648      ;; Another plausible choice here is
     649      ;; #p"/tmp/.hidden-directory-of-some-irc-bot-in-eastern-europe/"
     650      ;; Of course, that might already be the value of $HOME.  Anyway,
     651      ;; the user's home directory just contains "config files" (like
     652      ;; SSH keys), and spoofing it can't hurt anything.
     653      (make-pathname :directory '(:absolute) :defaults nil))))
     654
     655
     656
    648657
    649658(defun translate-logical-pathname (pathname &key)
     
    663672               (signal-file-error $xnotranslation pathname)))))))
    664673
     674(defloadvar *user-homedir-pathname* (user-homedir-pathname))
     675
     676
    665677;;; Hide this from COMPILE-FILE, for obscure cross-compilation reasons
    666678
  • trunk/source/level-1/l1-processes.lisp

    r10253 r10426  
    296296by process-suspend."
    297297  (setq p (require-type p 'process))
    298   (%resume-tcr (process-tcr p)))
     298  (let* ((tcr (process-tcr p)))
     299    (and tcr (%resume-tcr tcr))))
    299300
    300301(defun process-suspend (p)
     
    303304  (if (eq p *current-process*)
    304305    (error "Suspending the current process can't work.  ~&(If the documentation claims otherwise, it's incorrect.)")
    305     (%suspend-tcr (process-tcr p))))
     306    (let* ((tcr (process-tcr p)))
     307      (and tcr (%suspend-tcr tcr)))))
    306308
    307309(defun process-suspend-count (p)
  • trunk/source/level-1/l1-reader.lisp

    r10340 r10426  
    22322232      (setf (token.ipos token) (the fixnum (1+ ipos)))
    22332233      (%schar (token.string token) ipos))))
    2234 
    22352234     
    22362235(defun input-stream-arg (stream)
  • trunk/source/level-1/l1-readloop-lds.lisp

    r8791 r10426  
    9191
    9292
     93(defun list-restarts ()
     94  (format *debug-io* "~&>   Type (:C <n>) to invoke one of the following restarts:")
     95  (display-restarts))
     96
    9397(define-toplevel-command :break pop () "exit current break loop" (abort-break))
    9498(define-toplevel-command :break a () "exit current break loop" (abort-break))
    9599(define-toplevel-command :break go () "continue" (continue))
    96100(define-toplevel-command :break q () "return to toplevel" (toplevel))
    97 (define-toplevel-command :break r () "list restarts"
    98   (format t "~&   (:C <n>) can be used to invoke one of the following restarts in this break loop:")
    99   (let* ((r (apply #'vector (compute-restarts *break-condition*))))
    100     (dotimes (i (length r) (terpri))
    101       (format *debug-io* "~&~d. ~a" i (svref r i)))))
    102 
    103 ;;; From Marco Baringer 2003/03/18
     101(define-toplevel-command :break r () "list restarts" (list-restarts))
    104102
    105103(define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
     
    110108
    111109(define-toplevel-command :break nframes ()
    112                          "print the number of stack frames accessible from this break loop"
    113                          (do* ((p *break-frame* (parent-frame p nil))
    114                                (i 0 (1+ i))
    115                                (last (last-frame-ptr)))
    116                               ((eql p last) (toplevel-print (list i)))))
     110  "print the number of stack frames accessible from this break loop"
     111  (do* ((p *break-frame* (parent-frame p nil))
     112        (i 0 (1+ i))
     113        (last (last-frame-ptr)))
     114      ((eql p last) (toplevel-print (list i)))))
    117115
    118116(define-toplevel-command :global ? () "help"
     117  (format t "~&The following toplevel commands are available:")
     118  (when *default-integer-command*
     119    (format t "~& <n>  ~8Tthe same as (~s <n>)" (car *default-integer-command*)))
    119120  (dolist (g *active-toplevel-commands*)
    120121    (dolist (c (cdr g))
     
    124125        (if args
    125126          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
    126           (format t "~& ~S  ~8T~A" command doc))))))
     127          (format t "~& ~S  ~8T~A" command doc)))))
     128  (format t "~&Any other form is evaluated and its results are printed out."))
    127129
    128130
     
    242244(%use-toplevel-commands :global)
    243245
     246(defparameter *toplevel-commands-dwim* t "If true, tries to interpret otherwise-erroneous toplevel
     247expressions as commands")
     248
     249(defvar *default-integer-command* nil
     250  "If non-nil, should be (keyword  min max)), causing integers between min and max to be
     251  interpreted as (keyword integer)")
     252
    244253(defun check-toplevel-command (form)
     254  (when (and *default-integer-command*
     255             (integerp form)
     256             (<= (cadr *default-integer-command*) form (caddr *default-integer-command*)))
     257    (setq form `(,(car *default-integer-command*) ,form)))
    245258  (let* ((cmd (if (consp form) (car form) form))
    246259         (args (if (consp form) (cdr form))))
    247     (if (keywordp cmd)
     260    (when (or (keywordp cmd)
     261              (and *toplevel-commands-dwim*
     262                   (non-nil-symbol-p cmd)
     263                   (not (if (consp form) (fboundp cmd) (boundp cmd)))
     264                   ;; Use find-symbol so don't make unneeded keywords.
     265                   (setq cmd (find-symbol (symbol-name cmd) :keyword))))
     266      (when (eq cmd :help) (setq cmd :?))
    248267      (dolist (g *active-toplevel-commands*)
    249         (when
    250             (let* ((pair (assoc cmd (cdr g))))
    251               (if pair
    252                 (progn (apply (cadr pair) args)
    253                        t)))
    254           (return t))))))
     268        (let* ((pair (assoc cmd (cdr g))))
     269          (when pair
     270            (apply (cadr pair) args)
     271            (return t)))))))
    255272
    256273(defparameter *quit-on-eof* nil)
     
    264281                       (output-stream *standard-output*)
    265282                       (break-level *break-level*)
    266                        (prompt-function #'(lambda (stream) (print-listener-prompt stream t))))
     283                       (prompt-function #'(lambda (stream)
     284                                            (when (and *show-available-restarts* *break-condition*)
     285                                              (list-restarts)
     286                                              (setf *show-available-restarts* nil))
     287                                            (print-listener-prompt stream t))))
    267288  (let* ((*break-level* break-level)
    268289         (*last-break-level* break-level)
     
    270291         *in-read-loop*
    271292         *** ** * +++ ++ + /// // / -
    272          (eof-value (cons nil nil)))
     293         (eof-value (cons nil nil))
     294         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)))
    273295    (declare (dynamic-extent eof-value))
    274296    (loop
     
    558580(defvar *break-frame* nil "frame-pointer arg to break-loop")
    559581(defvar *break-loop-when-uninterruptable* t)
     582(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil)
     583(defvar *show-available-restarts* nil)
    560584
    561585(defvar *error-reentry-count* 0)
     
    609633                 (*print-length* *error-print-length*)
    610634                                        ;(*print-pretty* nil)
    611                  (*print-array* nil))
    612             (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
    613             (format t "~&> If continued: ~A~%" continue))
    614           (format t "~&> Type :POP to abort, :R for a list of available restarts.~%"))
     635                   (*print-array* nil))
     636              (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
     637              (format t "~&> If continued: ~A~%" continue))
     638            (format t "~&> Type :POP to abort, :R for a list of available restarts.~%"))
    615639        (format t "~&> Type :? for other options.")
    616640        (terpri)
     
    624648                (application-ui-operation *application*
    625649                                          :enter-backtrace-context context)
    626                   (read-loop :break-level (1+ *break-level*)
    627                              :input-stream *debug-io*
    628                              :output-stream *debug-io*))
     650                (read-loop :break-level (1+ *break-level*)
     651                           :input-stream *debug-io*
     652                           :output-stream *debug-io*))
    629653           (application-ui-operation *application* :exit-backtrace-context
    630654                                     context)))))))
     
    633657
    634658(defun display-restarts (&optional (condition *break-condition*))
    635   (let ((i 0))
    636     (format t "~&[Pretend that these are buttons.]")
    637     (dolist (r (compute-restarts condition) i)
    638       (format t "~&~a : ~A" i r)
    639       (setq i (%i+ i 1)))
    640     (fresh-line nil)))
     659  (loop
     660    for restart in (compute-restarts condition)
     661    for count upfrom 0
     662    do (format *debug-io* "~&~D. ~A" count restart)
     663    finally (fresh-line *debug-io*)))
    641664
    642665(defun select-restart (n &optional (condition *break-condition*))
  • trunk/source/level-1/l1-readloop.lisp

    r10317 r10426  
    269269      (if win (values (expand-it expansion) t) (values sym nil)))))
    270270
     271(defun macroexpand-all (form &optional (env (new-lexical-environment)))
     272  "Recursivly expand all macros in FORM."
     273  (flet ((mexpand (forms env)
     274           (mapcar (lambda (form) (macroexpand-all form env)) forms)))
     275    (macrolet ((destructuring-bind-body (binds form &body body)
     276                 (if (eql '&body (first (last binds)))
     277                   (let ((&body (gensym "&BODY")))
     278                     `(destructuring-bind ,(append (butlast binds) (list '&body &body))
     279                          ,form
     280                        (multiple-value-bind (body decls)
     281                            (parse-body ,&body env nil)
     282                          ,@body)))
     283                   `(destructuring-bind ,binds ,form ,@body))))
     284      (multiple-value-bind (expansion win)
     285          (macroexpand-1 form env)
     286        (if win
     287          (macroexpand-all expansion env)
     288          (if (atom form)
     289            form
     290            (case (first form)
     291              (macrolet
     292               (destructuring-bind-body (macros &body) (rest form)
     293                (setf env (augment-environment env
     294                                               :macro (mapcar (lambda (macro)
     295                                                                (destructuring-bind
     296                                                                      (name arglist &body body)
     297                                                                    macro
     298                                                                  (list name (enclose (parse-macro name arglist body env)))))
     299                                                              macros)
     300                                               :declare (decl-specs-from-declarations decls)))
     301                (let ((body (mexpand body env)))
     302                  (if decls
     303                    `(locally ,@decls ,@body)
     304                    `(progn ,@body)))))
     305              (symbol-macrolet
     306               (destructuring-bind-body (symbol-macros &body) (rest form)
     307                (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls)))
     308                (let ((body (mexpand body env)))
     309                  (if decls
     310                    `(locally ,@decls ,@body)
     311                    `(progn ,@body)))))
     312              ((let let* compiler-let)
     313               (destructuring-bind-body (bindings &body) (rest form)
     314                `(,(first form)
     315                   ,(mapcar (lambda (binding)
     316                             
     317                              (if (listp binding)
     318                                (list (first binding) (macroexpand-all (second binding) env))
     319                                binding))
     320                            bindings)
     321                   ,@decls
     322                   ,@(mexpand body env))))
     323              ((flet labels)
     324               (destructuring-bind-body (bindings &body) (rest form)
     325                `(,(first form)
     326                   ,(mapcar (lambda (binding)
     327                              (list* (first binding) (cdr (macroexpand-all `(lambda ,@(rest binding)) env))))
     328                            bindings)
     329                   ,@decls
     330                   ,@(mexpand body env))))
     331              (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env)))
     332              (function
     333                 (if (and (consp (second form))
     334                          (eql 'lambda (first (second form))))
     335                   (destructuring-bind (lambda arglist &body body&decls)
     336                       (second form)
     337                     (declare (ignore lambda))
     338                     (multiple-value-bind (body decls)
     339                         (parse-body body&decls env)
     340                       `(lambda ,arglist ,@decls ,@(mexpand body env))))
     341                   form))
     342              ((eval-when the locally block return-from)
     343                 (list* (first form) (second form) (mexpand (cddr form) env)))
     344              (setq
     345                 `(setq ,@(loop for (name value) on (rest form) by #'cddr
     346                                collect name
     347                                collect (macroexpand-all value env))))
     348              ((go quote) form)
     349              ((fbind with-c-frame with-variable-c-frame ppc-lap-function)
     350               (error "Unable to macroexpand ~S." form))
     351              ((catch if load-time-value multiple-value-call multiple-value-prog1 progn
     352                progv tagbody throw unwind-protect)
     353               (cons (first form) (mexpand (rest form) env)))
     354              (t
     355               ;; need to check that (first form) is either fboundp or a local function...
     356               (cons (first form) (mexpand (rest form) env))))))))))
     357
    271358(defun macroexpand-1 (form &optional env &aux fn)
    272359  "If form is a macro (or symbol macro), expand it once. Return two values,
     
    317404    lambda-expression))
    318405
    319 
    320        
    321 
    322406;;; This is different from AUGMENT-ENVIRONMENT.
    323407;;; If "info" is a lambda expression, then
     
    335419  name)
    336420
    337 
    338 ;;; And this is different from FUNCTION-INFORMATION.
     421; And this is different from FUNCTION-INFORMATION.
    339422(defun retrieve-environment-function-info (name env)
    340423 (let ((defenv (definition-environment env)))
  • trunk/source/level-1/l1-typesys.lisp

    r10358 r10426  
    178178  `(specifier-type ',(type-specifier c)))
    179179
     180(defmethod make-load-form ((cell type-cell) &optional env)
     181  (declare (ignore env))
     182  `(register-type-cell `,(type-cell-type-specifier cell)))
     183
     184(defmethod print-object ((cell type-cell) stream)
     185  (print-unreadable-object (cell stream :type t :identity t)
     186    (format stream "for ~s" (type-cell-type-specifier cell))))
    180187
    181188(defun make-key-info (&key name type)
     
    11081115                             type1 type2
    11091116                             :complex-arg1 :complex-subtypep-arg1))))
     1117
     1118;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache
     1119;;; a mapping between a type-specifier and a CTYPE.
     1120(defun cell-csubtypep-2 (type-specifier type-cell)
     1121  (let* ((type1 (specifier-type type-specifier))
     1122         (type2 (or (type-cell-ctype type-cell)
     1123                    (let* ((ctype (specifier-type
     1124                                   (type-cell-type-specifier type-cell))))
     1125                      (when (cacheable-ctype-p ctype)
     1126                        (setf (type-cell-ctype type-cell) ctype))
     1127                      ctype))))
     1128    (cond ((or (eq type1 type2)
     1129               (eq type1 *empty-type*)
     1130               (eq type2 *wild-type*))
     1131           (values t t))
     1132          (t
     1133           (invoke-type-method :simple-subtypep :complex-subtypep-arg2
     1134                               type1 type2
     1135                               :complex-arg1 :complex-subtypep-arg1)))))
     1136                             
     1137
     1138
    11101139;;; Type=  --  Interface
    11111140;;;
     
    16481677
    16491678(defun hairy-ctype-p (x)
    1650   (istruct-typep x 'hairy-ctype))
     1679  (or (istruct-typep x 'hairy-ctype)
     1680      (istruct-typep x 'unknown-ctype)))
    16511681
    16521682(setf (type-predicate 'hairy-ctype) 'hairy-ctype-p)
     
    36063636            (let ((fun (second hairy-spec)))
    36073637              (cond ((and (symbolp fun) (fboundp fun))
    3608                      (values (not (null (ignore-errors (funcall fun obj)))) t))
     3638                     ;; Binding *BREAK-ON-SIGNALS* here is a modularity
     3639                     ;; violation intended to improve the signal-to-noise
     3640                     ;; ratio on a mailing list.
     3641                     (values (not (null (let* ((*break-on-signals* nil))
     3642                                          (ignore-errors (funcall fun obj))))) t))
    36093643                    (t
    36103644                     (values nil nil))))))))))
  • trunk/source/level-1/sysutils.lisp

    r10309 r10426  
    233233          '(integer  #.(1+ target::target-most-positive-fixnum))))
    234234       ((or array complex) (type-specifier (ctype-of form)))
     235       (single-float 'single-float)
     236       (double-float 'double-float)
    235237       (t
    236238        (if (eql (typecode form) target::subtag-istruct)
    237239          (istruct-type-name form)
    238           (let* ((class (class-of form))
    239                  (class-name (class-name class)))
    240             (if (eq class (find-class class-name nil))
    241               class-name
    242               class))))))))
     240          (let* ((class (class-of form)))
     241            (or (%class-proper-name class)
     242                class))))))))
    243243
    244244;;; Create the list-style description of an array.
     
    527527
    528528(defparameter *outstanding-deferred-warnings* nil)
     529
    529530
    530531(defun %defer-warnings (override &optional flags)
  • trunk/source/lib/foreign-types.lisp

    r10292 r10426  
    14371437
    14381438
    1439 (defun %cons-foreign-variable (name type &optional container)
    1440   (%istruct 'foreign-variable nil name type container))
    14411439
    14421440
  • trunk/source/library/lispequ.lisp

    r10424 r10426  
    949949(defmacro %cons-wrapper (class &optional
    950950                               (hash-index '(new-class-wrapper-hash-index)))
    951   `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil))
     951  (let* ((c (gensym)))
     952  `(let* ((,c ,class))
     953    (%istruct 'class-wrapper ,hash-index ,c nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil (%class-ordinal ,c t) nil))))
    952954
    953955
     
    13191321;;; "basic" (e.g., builtin, non-extensible) streams.
    13201322(def-accessors (basic-stream) %svref
    1321   basic-stream.wrapper                  ; a class wrapper
     1323  basic-stream.wrapper                  ; a class wrapper object
    13221324  basic-stream.flags                    ; fixnum; bits.
    13231325  basic-stream.state                    ; typically an ioblock
     
    13891391  )
    13901392
     1393(defun %cons-foreign-variable (name type &optional container)
     1394  (%istruct 'foreign-variable nil name type container))
    13911395
    13921396(def-accessor-macros %svref
     
    14831487  )
    14841488
    1485   (def-accessors (afunc) %svref
    1486     ()                                    ; 'afunc
    1487     afunc-acode
    1488     afunc-parent
    1489     afunc-vars
    1490     afunc-inherited-vars
    1491     afunc-blocks
    1492     afunc-tags
    1493     afunc-inner-functions
    1494     afunc-name
    1495     afunc-bits
    1496     afunc-lfun
    1497     afunc-environment
    1498     afunc-lambdaform
    1499     afunc-argsword
    1500     afunc-ref-form
    1501     afunc-warnings
    1502     afunc-fn-refcount
    1503     afunc-fn-downward-refcount
    1504     afunc-all-vars
    1505     afunc-callers
    1506     afunc-vcells
    1507     afunc-fcells
    1508     afunc-fwd-refs
    1509     afunc-lfun-info
    1510     afunc-linkmap)
    1511 
    1512 (declaim (inline %make-afunc))
     1489(def-accessors (afunc) %svref
     1490  ()                                    ; 'afunc
     1491  afunc-acode
     1492  afunc-parent
     1493  afunc-vars
     1494  afunc-inherited-vars
     1495  afunc-blocks
     1496  afunc-tags
     1497  afunc-inner-functions
     1498  afunc-name
     1499  afunc-bits
     1500  afunc-lfun
     1501  afunc-environment
     1502  afunc-lambdaform
     1503  afunc-argsword
     1504  afunc-ref-form
     1505  afunc-warnings
     1506  afunc-fn-refcount
     1507  afunc-fn-downward-refcount
     1508  afunc-all-vars
     1509  afunc-callers
     1510  afunc-vcells
     1511  afunc-fcells
     1512  afunc-fwd-refs
     1513  afunc-lfun-info
     1514  afunc-linkmap)
    15131515
    15141516(defmacro %make-afunc ()
Note: See TracChangeset for help on using the changeset viewer.