Changeset 12202


Ignore:
Timestamp:
Jun 5, 2009, 6:38:18 PM (10 years ago)
Author:
gz
Message:

r11465 r11676 r11859 r11989 r12010 from trunk

Location:
branches/working-0711/ccl
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/X8632/x8632-arch.lisp

    r11660 r12202  
    696696  jvm-init
    697697  tcr-frame-ptr
    698   register_cstack
     698  register-xmacptr-dispose-function
    699699  raise-thread-interrupt
    700700  get-r-debug
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-arch.lisp

    r11660 r12202  
    796796  jvm-init
    797797  tcr-frame-ptr
    798   register_cstack
     798  register-xmacptr-dispose-function
    799799  raise-thread-interrupt
    800800  get-r-debug
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r12050 r12202  
    11871187(defstatic *lower-to-upper*  nil)
    11881188
     1189;;; "address" should be the address (as returned by FOREIGN-SYMBOL-ADDRESS)
     1190;;; of a foreign function that accepts a pointer as an argument and does
     1191;;; whatever's needed to dispose of it.  That function can be called from
     1192;;; the GC, so it shouldn't call back into lisp.
     1193(defun register-xmacptr-dispose-function (address)
     1194  (ff-call (%kernel-import target::kernel-import-register-xmacptr-dispose-function)
     1195           :address address
     1196           :int))
    11891197
    11901198
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r12048 r12202  
    688688   (documentation nil doc-p)
    689689   (primary-p nil primary-p-p))
    690   (declare (ignore slot-names))
    691   (if direct-superclasses-p
     690  (if (or direct-superclasses-p (eq slot-names t))
    692691    (progn
    693692      (setq direct-superclasses
     
    12821281                 (initform (cadr ssd))
    12831282                 (initfunction (constantly initform)))
    1284             (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
     1283            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction :initargs ,(list (make-keyword name))) dslots)))))
    12851284    (ensure-class (sd-name sd)
    12861285                  :metaclass 'structure-class
     
    18301829                             newval))))))))))
    18311830  instance)
     1831
     1832(defmethod shared-initialize ((struct structure-object) slot-names &rest initargs)
     1833  (unless (eq slot-names t)
     1834    (error "Structure instance ~s can't be reinitialized." struct))
     1835  (dolist (slotd (class-slots (class-cell-class (car (%svref struct 0)))))
     1836    (let* ((predicate (slot-definition-predicate slotd))
     1837           (location (slot-definition-location slotd)))
     1838      (declare (fixnum location))
     1839      (multiple-value-bind (ignore new-value foundp)
     1840          (get-properties initargs (slot-definition-initargs slotd))
     1841        (declare (ignore ignore))
     1842        (cond (foundp
     1843               ;; an initarg for the slot was passed to this function
     1844               ;; Typecheck the new-value, then call
     1845               ;; (SETF SLOT-VALUE-USING-CLASS)
     1846               (unless (or (null predicate)
     1847                           (funcall predicate new-value))
     1848                 (error 'bad-slot-type-from-initarg
     1849                        :slot-definition slotd
     1850                        :instance struct
     1851                        :datum new-value
     1852                        :expected-type  (slot-definition-type slotd)
     1853                          :initarg-name (car foundp)))
     1854                 (setf (struct-ref struct location) new-value))
     1855                (t
     1856                 ;; If the slot name is among the specified slot names, or
     1857                 ;; we're reinitializing all slots, and the slot is currently
     1858                 ;; unbound in the instance, set the slot's value based
     1859                 ;; on the initfunction (which captures the :INITFORM).
     1860                 (let* ((initfunction (slot-definition-initfunction slotd)))
     1861                   (if initfunction
     1862                     (let* ((newval (funcall initfunction)))
     1863                       (unless (or (null predicate)
     1864                                   (funcall predicate newval))
     1865                         (error 'bad-slot-type-from-initform
     1866                                :slot-definition slotd
     1867                                :expected-type (slot-definition-type slotd)
     1868                                :datum newval
     1869                                :instance struct))
     1870                       (setf (struct-ref struct location) newval)))))))))
     1871  struct)
     1872
     1873(defmethod initialize-instance ((struct structure-object) &rest initargs &key &allow-other-keys)
     1874  (declare (dynamic-extent initargs))
     1875  (apply #'shared-initialize struct t initargs))
     1876
     1877(defmethod make-instance ((class structure-class)  &rest initargs &key &allow-other-keys)
     1878  (declare (dynamic-extent initargs))
     1879  (let* ((struct (apply #'allocate-instance class initargs)))
     1880    (apply #'initialize-instance struct initargs)))
     1881
     1882   
    18321883
    18331884;;; Sometimes you can do a lot better at generic function dispatch than the
  • branches/working-0711/ccl/level-1/l1-files.lisp

    r11777 r12202  
    499499  (when path (pathname path)))
    500500
     501(defun get-pathname-sstring (string &optional (start 0) (end (length string)))
     502  #-windows-target
     503  (get-sstring string start end)
     504  #+windows-target
     505  (multiple-value-bind (sstr start end)
     506      (get-sstring string start end)
     507    (declare (fixnum start end)
     508             (simple-string sstr))
     509    (if (do* ((i start (1+ i)))
     510             ((= i end))
     511          (declare (fixnum i))
     512          (when (eql (schar sstr i) #\\)
     513            (return t)))
     514      (let* ((len (- end start))
     515             (new (make-string len)))
     516        (declare (fixnum len) (simple-string new))
     517        (dotimes (i len)
     518          (let* ((ch (schar sstr start)))
     519            (if (eql ch #\\)
     520              (setf (schar new i) #\/)
     521              (setf (schar new i) ch)))
     522          (incf start))
     523        (values new 0 len))
     524      (values sstr start end))))
     525             
    501526(defun string-to-pathname (string &optional (start 0) (end (length string))
    502527                                            (reference-host nil)
    503528                                            (defaults *default-pathname-defaults*))
    504529  (require-type reference-host '(or null string))
    505   (multiple-value-bind (sstr start end) (get-sstring string start end)
     530  (multiple-value-bind (sstr start end) (get-pathname-sstring string start end)
    506531    #-windows-target
    507532    (if (and (> end start)
     
    745770           (logical-pathname (%logical-pathname-host thing))
    746771           (pathname :unspecific)
    747            (string (multiple-value-bind (sstr start end) (get-sstring thing)
     772           (string (multiple-value-bind (sstr start end) (get-pathname-sstring thing)
    748773                     (pathname-host-sstr sstr start end)))
    749774           (t (report-bad-arg thing pathname-arg-type)))))
     
    795820                  (pathname (%pathname-directory path))
    796821                  (string
    797                    (multiple-value-bind (sstr start end) (get-sstring path)
    798                      #+no
    799                      (if (and (> end start)
    800                               (eql (schar sstr start) #\~))
    801                        (setq sstr (tilde-expand (subseq sstr start end))
    802                              start 0
    803                              end (length sstr)))
     822                   (multiple-value-bind (sstr start end) (get-pathname-sstring path)
    804823                     (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
    805824                       (unless (eq host :unspecific) (setq logical-p t))
     
    881900    (pathname (%physical-pathname-version path))
    882901    (string
    883      (multiple-value-bind (sstr start end) (get-sstring path)
     902     (multiple-value-bind (sstr start end) (get-pathname-sstring path)
    884903       (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
    885904         (if (eq host :unspecific)
     
    916935                 (pathname (%pathname-name path))
    917936                 (string
    918                   (multiple-value-bind (sstr start end) (get-sstring path)
     937                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
    919938                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
    920939                      (setq start newstart)
     
    952971                 (pathname (%pathname-type path))
    953972                 (string
    954                   (multiple-value-bind (sstr start end) (get-sstring path)
     973                  (multiple-value-bind (sstr start end) (get-pathname-sstring path)
    955974                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
    956975                      (setq start newstart)
  • branches/working-0711/ccl/level-1/l1-pathnames.lisp

    r12198 r12202  
    360360
    361361(defun logical-pathname-namestring-p (string)
    362   (multiple-value-bind (sstr start end) (get-sstring string)
     362  (multiple-value-bind (sstr start end) (get-pathname-sstring string)
    363363    (let ((host (pathname-host-sstr sstr start end t)))
    364364      (and host (not (eq host :unspecific))))))
  • branches/working-0711/ccl/level-1/x86-error-signal.lisp

    r11771 r12202  
    102102                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
    103103                          frame-ptr)))
     104                  ((= op1 #x90)
     105                   (setq skip (%check-anchored-uuo xcf 3))
     106                   (setf (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     107                         (%kernel-restart-internal $xvunbnd
     108                                                   (list
     109                                                    (encoded-gpr-lisp
     110                                                     xp
     111                                                     (ldb (byte 4 0) op2)))
     112                                                   frame-ptr)))
    104113                  ((< op1 #xa0)
    105114                   (setq skip (%check-anchored-uuo xcf 2))
    106                    ;; #x9x - register X is a symbol.  It's unbound.
    107                    (%kernel-restart-internal $xvunbnd
    108                                              (list
    109                                               (encoded-gpr-lisp
     115                   ;; #x9x, x>0 - register X is a symbol.  It's unbound,
     116                   ;; but we don't have enough info to offer USE-VALUE,
     117                   ;; STORE-VALUE, or CONTINUE restarts.
     118                   (%error (make-condition 'unbound-variable
     119                                           :name
     120                                           (encoded-gpr-lisp
    110121                                               xp
    111122                                               (ldb (byte 4 0) op1)))
    112                                              frame-ptr))
     123                           ()
     124                           frame-ptr))
    113125                  ((< op1 #xb0)
    114126                   (setq skip (%check-anchored-uuo xcf 2))
     
    275287                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
    276288                          frame-ptr)))
     289                  ((= op1 #x90)
     290                   (setq skip (%check-anchored-uuo xcf 3))
     291                   (setf (encoded-gpr-lisp
     292                          xp
     293                          (ldb (byte 3 0) op2))
     294                         (%kernel-restart-internal $xvunbnd
     295                                                   (list
     296                                                    (encoded-gpr-lisp
     297                                                     xp
     298                                                     (ldb (byte 3 0) op2)))
     299                                                   frame-ptr)))
    277300                  ((< op1 #xa0)
    278301                   (setq skip (%check-anchored-uuo xcf 2))
    279                    ;; #x9x - register X is a symbol.  It's unbound.
    280                    (%kernel-restart-internal $xvunbnd
    281                                              (list
    282                                               (encoded-gpr-lisp
     302                   ;; #x9x, x>- - register X is a symbol.  It's unbound,
     303                   ;; but we don't have enough info to offer USE-VALUE,
     304                   ;; STORE-VALUE, or CONTINUE restart
     305                   (%error (make-condition 'unbound-variable
     306                                           :name
     307                                           (encoded-gpr-lisp
    283308                                               xp
    284309                                               (ldb (byte 3 0) op1)))
    285                                              frame-ptr))
     310                           ()
     311                           frame-ptr))
    286312                  ((< op1 #xb0)
    287313                   (setq skip (%check-anchored-uuo xcf 2))
Note: See TracChangeset for help on using the changeset viewer.