Index: /trunk/ccl/level-1/l1-aprims.lisp =================================================================== --- /trunk/ccl/level-1/l1-aprims.lisp (revision 394) +++ /trunk/ccl/level-1/l1-aprims.lisp (revision 395) @@ -284,4 +284,5 @@ (when (eq elt (%svref vector i)) (return i)))) +(defun logical-pathname-p (thing) (istruct-typep thing 'logical-pathname)) (progn @@ -444,11 +445,11 @@ (defun coerce-to-uvector (object subtype simple-p) ; simple-p ? (let ((type-code (typecode object))) - (cond ((eq type-code ppc32::tag-list) + (cond ((eq type-code target::tag-list) (%list-to-uvector subtype object)) - ((>= type-code ppc32::min-cl-ivector-subtag) ; 175 + ((>= type-code target::min-cl-ivector-subtag) ; 175 (if (or (null subtype)(= subtype type-code)) (return-from coerce-to-uvector object))) - ((>= type-code ppc32::min-vector-subtag) ; 170 - (if (= type-code ppc32::subtag-simple-vector) + ((>= type-code target::min-vector-subtag) ; 170 + (if (= type-code target::subtag-simple-vector) (if (or (null subtype) (= type-code subtype)) @@ -459,5 +460,5 @@ (return-from coerce-to-uvector object)))) (t (error "Can't coerce ~s to Uvector" object))) ; or just let length error - (if (null subtype)(setq subtype ppc32::subtag-simple-vector)) + (if (null subtype)(setq subtype target::subtag-simple-vector)) (let* ((size (length object)) (val (%alloc-misc size subtype))) @@ -479,5 +480,5 @@ (defun %list-to-uvector (subtype list) ; subtype may be nil (meaning simple-vector (let* ((n (length list)) - (new (%alloc-misc n (or subtype ppc32::subtag-simple-vector)))) ; yech + (new (%alloc-misc n (or subtype target::subtag-simple-vector)))) ; yech (dotimes (i n) (declare (fixnum i)) @@ -536,7 +537,7 @@ (eval-when (:compile-toplevel) - (assert (eql ppc32::arrayH.flags-cell ppc32::vectorH.flags-cell)) - (assert (eql ppc32::arrayH.displacement-cell ppc32::vectorH.displacement-cell)) - (assert (eql ppc32::arrayH.data-vector-cell ppc32::vectorH.data-vector-cell))) + (assert (eql target::arrayH.flags-cell target::vectorH.flags-cell)) + (assert (eql target::arrayH.displacement-cell target::vectorH.displacement-cell)) + (assert (eql target::arrayH.data-vector-cell target::vectorH.data-vector-cell))) @@ -585,7 +586,7 @@ ; $arh_disp_bit. If displaced-to is not adjustable, then our ; target can be its target instead of itself. - (when (or (eql vect-subtype ppc32::subtag-arrayH) - (eql vect-subtype ppc32::subtag-vectorH)) - (let ((dflags (%svref displaced-to ppc32::arrayH.flags-cell))) + (when (or (eql vect-subtype target::subtag-arrayH) + (eql vect-subtype target::subtag-vectorH)) + (let ((dflags (%svref displaced-to target::arrayH.flags-cell))) (declare (fixnum dflags)) (when (or (logbitp $arh_adjp_bit dflags) @@ -593,6 +594,6 @@ (progn #+nope - (setq target (%svref displaced-to ppc32::arrayH.data-vector-cell) - real-offset (+ offset (%svref displaced-to ppc32::arrayH.displacement-cell))) + (setq target (%svref displaced-to target::arrayH.data-vector-cell) + real-offset (+ offset (%svref displaced-to target::arrayH.displacement-cell))) (logbitp $arh_disp_bit dflags) #-nope t)) @@ -600,7 +601,7 @@ (setq vect-subtype (%array-header-subtype displaced-to))) ; assumes flags is low byte - (setq flags (dpb vect-subtype ppc32::arrayH.flags-cell-subtag-byte flags)) + (setq flags (dpb vect-subtype target::arrayH.flags-cell-subtag-byte flags)) (if (eq rank 1) - (%gvector ppc32::subtag-vectorH + (%gvector target::subtag-vectorH (if (fixnump fill) fill new-size) new-size @@ -608,16 +609,34 @@ real-offset flags) - (let ((val (%alloc-misc (+ ppc32::arrayh.dim0-cell rank) ppc32::subtag-arrayH))) - (setf (%svref val ppc32::arrayH.rank-cell) rank) - (setf (%svref val ppc32::arrayH.physsize-cell) new-size) - (setf (%svref val ppc32::arrayH.data-vector-cell) target) - (setf (%svref val ppc32::arrayH.displacement-cell) real-offset) - (setf (%svref val ppc32::arrayH.flags-cell) flags) + (let ((val (%alloc-misc (+ target::arrayh.dim0-cell rank) target::subtag-arrayH))) + (setf (%svref val target::arrayH.rank-cell) rank) + (setf (%svref val target::arrayH.physsize-cell) new-size) + (setf (%svref val target::arrayH.data-vector-cell) target) + (setf (%svref val target::arrayH.displacement-cell) real-offset) + (setf (%svref val target::arrayH.flags-cell) flags) (do* ((dims dimensions (cdr dims)) (i 0 (1+ i))) ((null dims)) (declare (fixnum i)(list dims)) - (setf (%svref val (%i+ ppc32::arrayH.dim0-cell i)) (car dims))) + (setf (%svref val (%i+ target::arrayH.dim0-cell i)) (car dims))) val))))) + +(defun make-array (dims &key (element-type t element-type-p) + displaced-to + displaced-index-offset + adjustable + fill-pointer + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p)) + (when (and initial-element-p initial-contents-p) + (error "Cannot specify both ~S and ~S" :initial-element-p :initial-contents-p)) + (make-array-1 dims element-type element-type-p + displaced-to + displaced-index-offset + adjustable + fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + nil)) @@ -862,7 +881,7 @@ (when (egc-enabled-p) (let* ((a (%active-dynamic-area))) - (setq g0-count (%fixnum-ref a ppc32::area.gc-count) a (%fixnum-ref a ppc32::area.older)) - (setq g1-count (%fixnum-ref a ppc32::area.gc-count) a (%fixnum-ref a ppc32::area.older)) - (setq g2-count (%fixnum-ref a ppc32::area.gc-count)))) + (setq g0-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g1-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g2-count (%fixnum-ref a target::area.gc-count)))) (values total full g2-count g1-count g0-count))) @@ -893,14 +912,14 @@ ; this IS effectively a passive way of inquiring about enabled status. (defun egc-enabled-p () - (not (eql 0 (%fixnum-ref (%active-dynamic-area) ppc32::area.older)))) + (not (eql 0 (%fixnum-ref (%active-dynamic-area) target::area.older)))) (defun egc-configuration () (let* ((ta (%get-kernel-global 'tenured-area)) - (g2 (%fixnum-ref ta ppc32::area.younger)) - (g1 (%fixnum-ref g2 ppc32::area.younger)) - (g0 (%fixnum-ref g1 ppc32::area.younger))) - (values (ash (the fixnum (%fixnum-ref g0 ppc32::area.threshold)) -8) - (ash (the fixnum (%fixnum-ref g1 ppc32::area.threshold)) -8) - (ash (the fixnum (%fixnum-ref g2 ppc32::area.threshold)) -8)))) + (g2 (%fixnum-ref ta target::area.younger)) + (g1 (%fixnum-ref g2 target::area.younger)) + (g0 (%fixnum-ref g1 target::area.younger))) + (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) -8) + (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) -8) + (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) -8)))) @@ -917,5 +936,5 @@ (if (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) 0 - (uvref macptr PPC32::XMACPTR.FLAGS-CELL))) + (uvref macptr TARGET::XMACPTR.FLAGS-CELL))) @@ -925,5 +944,5 @@ (defun set-macptr-flags (macptr value) (unless (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) - (setf (%svref macptr PPC32::XMACPTR.FLAGS-CELL) value) + (setf (%svref macptr TARGET::XMACPTR.FLAGS-CELL) value) value)) @@ -949,4 +968,6 @@ (or (and (>= code (char-code #\A)) (<= code (char-code #\Z))) (and (>= code (char-code #\a)) (<= code (char-code #\z)))))) + + Index: /trunk/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /trunk/ccl/level-1/l1-clos-boot.lisp (revision 394) +++ /trunk/ccl/level-1/l1-clos-boot.lisp (revision 395) @@ -31,6 +31,6 @@ (defun instance-slots (instance) (let* ((typecode (typecode instance))) - (cond ((eql typecode ppc32::subtag-instance) (instance.slots instance)) - ((eql typecode ppc32::subtag-macptr) (foreign-slots-vector instance)) + (cond ((eql typecode target::subtag-instance) (instance.slots instance)) + ((eql typecode target::subtag-macptr) (foreign-slots-vector instance)) ((typep instance 'standard-generic-function) (gf.slots instance)) (t (error "Don't know how to find slots of ~s" instance))))) @@ -532,5 +532,5 @@ (eval-when (:compile-toplevel :execute) (defmacro make-structure-vector (size) - `(%alloc-misc ,size ppc32::subtag-struct nil)) + `(%alloc-misc ,size target::subtag-struct nil)) ) @@ -1410,5 +1410,5 @@ (defun standard-instance-p (i) - (eq (typecode i) ppc32::subtag-instance)) + (eq (typecode i) target::subtag-instance)) @@ -2272,6 +2272,6 @@ (defun %maybe-std-slot-value-using-class (class instance slotd) - (if (and (eql (typecode class) ppc32::subtag-instance) - (eql (typecode slotd) ppc32::subtag-instance) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) (eq *standard-effective-slot-definition-class-wrapper* (instance.class-wrapper slotd)) @@ -2312,6 +2312,6 @@ (defun %maybe-std-setf-slot-value-using-class (class instance slotd new) - (if (and (eql (typecode class) ppc32::subtag-instance) - (eql (typecode slotd) ppc32::subtag-instance) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) (eq *standard-effective-slot-definition-class-wrapper* (instance.class-wrapper slotd))