close Warning: Error with navigation contributor "AccountModule"

Changeset 39


Ignore:
Timestamp:
Jun 2, 2016, 12:42:40 AM (4 years ago)
Author:
gz
Message:

use cl:base-char type where appropriate, as this does the right thing in both ccl (where it's equivalent to cl:character) and lispworks (where it's equivalent to lw:base-character).

assorted other minor tweaks from merging back with lispworks version.

Location:
trunk
Files:
16 edited

Legend:

Unmodified
Added
Removed
  • trunk/btrees.lisp

    r32 r39  
    170170    (funcall thunk string)
    171171    (let* ((len (length string))
    172            (simple-string (make-string len)))
     172           (simple-string (make-string len :element-type 'base-char)))
    173173      (declare (dynamic-extent simple-string))
    174174      (multiple-value-bind (str offset) (array-data-and-offset string)
     
    420420                   (multiple-value-bind (value imm?) (load.p p)
    421421                     (let* ((len (load.b (incf p 4)))
    422                             (key (make-string len)))
     422                            (key (make-string len :element-type 'base-char)))
    423423                       (declare (fixnum len)
    424424                                (dynamic-extent key))
     
    430430                         (declare (fixnum newlen))
    431431                         (unless (and (eql newlen len)
    432                                       (let ((new-key (make-string newlen)))
     432                                      (let ((new-key (make-string newlen :element-type 'base-char)))
    433433                                        (declare (dynamic-extent new-key))
    434434                                        (load.string (the fixnum (1+ p)) newlen new-key)
     
    613613                              (if last-ptr (- last-ptr offset 4)))))
    614614            (let* ((len (aref vec ptr))
    615                    (str (make-string len)))
     615                   (str (make-string len :element-type 'base-char)))
    616616              (declare (dynamic-extent str))
    617617              (%copy-byte-array-portion vec (the fixnum (1+ ptr)) len str 0)
     
    979979                                       key-length
    980980                                       (accessing-byte-array (node-buf) (load.b node-ptr))))
    981                  (last-string (make-string last-string-length)))
     981                 (last-string (make-string last-string-length :element-type 'base-char)))
    982982            (declare (fixnum end-ptr node-ptr last-string-length)
    983983                     (dynamic-extent last-string))
     
    13261326                                                (accessing-byte-array (node-buf)
    13271327                                                  (load.b last-entry-ptr))))
    1328                                       (temp-string (make-string length)))
     1328                                      (temp-string (make-string length :element-type 'base-char)))
    13291329                                 (declare (fixnum last-entry-ptr length)
    13301330                                          (dynamic-extent temp-string))
  • trunk/compat.lisp

    r38 r39  
    2525  #-ccl (not (eq x y)))
    2626
    27 (defun delq (x list &optional count)
    28   (delete x list :test #'eq :count count))
     27(defun-inline delq (x list &optional (count most-positive-fixnum))
     28  #+ccl (ccl::delq x list count)
     29  #-ccl (delete x list :test #'eq :count count))
    2930
    3031(defun-inline make-hash (&key weak (test 'eql) (size nil size-p))
     
    150151  (and (typep array 'simple-array)
    151152       (let ((type (array-element-type array)))
    152          (or (eq type 'character)
     153         (or (eq type #+ccl 'character #+lispworks 'base-char)
    153154             (equal type '(signed-byte 8))
    154155             (equal type '(unsigned-byte 8))))))
     
    306307  #+ccl (ccl::parse-body body env doc-string-allowed)
    307308  #-ccl (let ((decls nil))
    308           env whatever
     309          env doc-string-allowed
    309310          (loop
    310311           (unless (and (consp body)
     
    349350
    350351(defun require-type (value type)
    351   (if (typep value type)
    352     value
    353     (error "~s is not of type ~s" value type)))
     352  #+ccl (ccl:require-type value type)
     353  #-ccl (if (typep value type)
     354            value
     355            (error "~s is not of type ~s" value type)))
    354356
    355357(defun memq (value list)
  • trunk/dca-clozure.lisp

    r23 r39  
    33;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    44;;
    5 ;; dca-ccl.lisp
     5;; dca-clozure.lisp
    66;; low-level accessors for disk-cache's, Clozure Common Lisp versions
    77;;
    8 ;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info).
     8;; Portions Copyright © 2006 Clozure Associates
    99;; Copyright © 1996 Digitool, Inc.
    1010;; Copyright © 1992-1995 Apple Computer, Inc.
  • trunk/dca-lispworks.lisp

    r12 r39  
    66;; low-level accessors for disk-cache's, lispworks versions
    77;;
    8 ;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info).
     8;; Portions Copyright © 2006 Clozure Associates
    99;; Copyright © 1996 Digitool, Inc.
    1010;; Copyright © 1992-1995 Apple Computer, Inc.
     
    183183  value)
    184184
     185(defun load-bytes-to-iarray (disk-cache address num-bytes array)
     186  ;; Array is a non-displaced array of immediate data.  I won't even begin to guess at the
     187  ;; internal format.
     188  (let* ((num-elts (array-total-size array))
     189         (ivector (make-array num-elts :element-type (array-element-type array))))
     190    (load-bytes-to-ivector disk-cache address num-bytes ivector)
     191    (loop for i from 0 below num-elts
     192          do (setf (row-major-aref array i) (aref ivector i)))
     193    array))
     194
    185195(defun store-bytes-from-iarray (array disk-cache address num-bytes)
    186196  ;; Array is a non-displaced array of immediate data.  I won't even begin to guess at the
  • trunk/disk-cache-accessors.lisp

    r38 r39  
    341341               (array-data-and-offset string)))
    342342            (t (setq inner-string
    343                      (setq string (make-string length :element-type 'base-character)))))
     343                     (setq string (make-string length :element-type 'base-char)))))
    344344      (loop
    345345        (with-disk-cache-locked (disk-cache)
     
    430430(defun %load-string (array index length &optional string)
    431431  (unless string
    432     (setq string (make-string length :element-type 'base-character)))
     432    (setq string (make-string length :element-type 'base-char)))
    433433  (%copy-byte-array-portion array index length string 0))
    434434
     
    894894  (let ((address 0)
    895895        (string (make-array 50 :fill-pointer t :adjustable t
    896                             :element-type 'base-character)))
     896                            :element-type 'base-char)))
    897897    (loop
    898898      (let ((length (wood::read-long wood::dc address)))
  • trunk/disk-cache-inspector.lisp

    r12 r39  
    9191
    9292(defparameter *disk-cache-inspector-string*
    93   (make-string 16 :element-type 'character))
     93  (make-string 16 :element-type 'base-char))
    9494(defparameter *disk-cache-inspector-value*
    9595  (make-string (+ 8 2 8 1 8 1 8 1 8 2 16 2)
    9696               :initial-element #\space
    97                :element-type 'character))
     97               :element-type 'base-char))
    9898
    9999(defmethod inspector::line-n ((in disk-cache-inspector) n)
  • trunk/disk-cache.lisp

    r38 r39  
    333333(defvar *open-disk-caches* nil)
    334334
    335 ; New code
    336 (defparameter *big-io-buffers*
    337   #+ccl (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open))))
    338   #+LispWorks nil)
    339 
    340335(defun open-disk-cache (filename &key shared-p read-only-p
    341336                                    (page-size *default-page-size* page-size-p)
  • trunk/lw-inspector.lisp

    r38 r39  
    1919        (value (make-string (+ 36 1 16)
    2020                            :initial-element #\space
    21                             :element-type 'base-character)))
     21                            :element-type 'base-char)))
    2222    (flet ((enc (offset value index)
    2323             (incf offset start)
     
    4747
    4848(defparameter *disk-cache-inspector-buffer*
    49   (make-string 16 :element-type 'base-character))
     49  (make-string 16 :element-type 'base-char))
    5050
    5151(defmethod lw:get-inspector-values ((disk-cache disk-cache) (mode (eql 'disk-cache-data)))
  • trunk/package.lisp

    r30 r39  
    88  #+ccl
    99  (:import-from :ccl
    10                 :function-information)
     10                #:function-information)
    1111  (:export #:load-wood
    1212           #:reload
  • trunk/persistent-clos.lisp

    r38 r39  
    189189             (ccl:class-own-wrapper class))))
    190190
    191 ; This knows internals of MCL's CLOS implementation
    192191(defun class-slots-vector (class)
    193192  (%wrapper-instance-slots (class-own-wrapper class)))
     
    230229(defun class-instance-slots (class)
    231230  "Return the slot-definition instances of CLASS with :instance allocation."
     231  #+LispWorks (clos::class-instance-slots object)
     232  #+ccl
    232233  (let ((slots (c2mop:class-slots class)))
    233234    (dolist (slot slots slots)
     
    239240           slots))))))
    240241
    241 #+ccl
    242242(defun class-instance-slot-names (class)
    243243  "Return a vector of the names of the instance slots of CLASS."
     
    245245    (unless wrapper
    246246      (c2mop:class-prototype class)
    247       (setq wrapper (ccl:class-own-wrapper class))
     247      (setq wrapper (class-own-wrapper class))
    248248      (unless wrapper (error "Can't find class-own-wrapper for ~s" class)))
    249     (ccl::%wrapper-instance-slots wrapper)))
    250 
    251 #-ccl
    252 (defun class-instance-slot-names (class)
    253   "Return a vector of the names of the instance slots of CLASS."
    254   (let ((slots (class-instance-slots class)))
    255     (map 'vector #'c2mop:slot-definition-name slots)))
     249    (%wrapper-instance-slots wrapper)))
    256250
    257251(defun p-instance-class (instance)
  • trunk/persistent-heap.lisp

    r38 r39  
    385385    :shared-buffer
    386386    :shared-buffer-pool
    387     #+ccl :mac-file-creator
    388     #+ccl :external-format
    389387    :pheap-class
    390388    :initial-transaction-p))
     
    13571355
    13581356(defun p-load-bit-vector (pheap disk-cache pointer depth subtype)
     1357  #-ccl (declare (ignore subtype))
    13591358  (let* ((cached? t)
    13601359         (res (maybe-cached-value pheap pointer
     
    16271626
    16281627(defun immediate-object-p (object)
     1628  #+ccl
    16291629  (let ((typecode (ccl::typecode object)))
    16301630    #+x8664-target
     
    17921792(defmethod %p-store-object (pheap (object function) descend)
    17931793  (let* ((split-vec (apply #'vector (split-lfun object *preserve-lfun-info*)))
    1794          (subtype (uvector-subtype split-vec)))
     1794         (subtype (uvector-subtype split-vec))
    17951795         (length (length split-vec)))
    17961796    (%p-store-object-body (pheap object descend disk-cache address)
    17971797      (declare (ignore object))
    17981798      (+ (dc-make-uvector disk-cache length subtype) (- $t_lfun $t_vector))
    1799       (p-store-gvector pheap split-vec descend disk-cache (+ address (- $t_vector $t_lfun)) length)))
     1799      (p-store-gvector pheap split-vec descend disk-cache (+ address (- $t_vector $t_lfun)) length))))
    18001800
    18011801(defmethod %p-store-object (pheap (object cons) descend)
     
    19151915
    19161916
    1917 #+ccl
    19181917(defmethod %p-store-object (pheap (object integer) descend)
    1919   (if (%ccl2-fixnum-p object)
     1918  (if (immediate-object-p object)
    19201919      (values object t)
    19211920      (let* ((abs (abs object))
    19221921             (words (1+ (floor (integer-length abs) 16))))
    1923         (%p-store-as-uvector pheap object descend words $v_bignum))))
    1924 
    1925 #+LispWorks
    1926 (defmethod %p-store-object (pheap (object integer) descend)
    1927   (if (fixnump object)
    1928       (values object t)
    1929       (let ((words (1+ (floor (integer-length (abs object)) 16))))
    19301922        (%p-store-as-uvector pheap object descend words $v_bignum))))
    19311923
  • trunk/test.lisp

    r30 r39  
    99(defvar *pheap* nil)
    1010(defvar *root-btree* nil)
    11 (defparameter *pheap-filename* "test.pheap")
     11(defparameter *pheap-filename* "wood:test.pheap")
    1212
    1313(defun run-all-tests (&optional recreate)
  • trunk/wood-gc.lisp

    r32 r39  
    375375         (values-list (dc-symbol-values-list input-dc symbol))
    376376         (len (dc-%vector-size output-dc print-name))
    377          (str (make-string len :element-type 'base-character)))
     377         (str (make-string len :element-type 'base-char)))
    378378    (declare (dynamic-extent str))
    379379    (read-string output-dc (+ print-name $v_data) len str)
     
    435435(defun gc-copy-bytes (address bytes input-dc output-dc)
    436436  (let* ((res (- (%allocate-storage output-dc nil bytes) $t_cons))
    437          (string (make-string 512 :element-type 'base-character))
     437         (string (make-string 512 :element-type 'base-char))
    438438         (from address)
    439439         (to res)
  • trunk/wood.asd

    r24 r39  
    2323   (:file #+wood-portable "dca-portable"
    2424          #+clozure-common-lisp "dca-clozure"
    25           #+LispWords "dca-lispworkd")
     25          #+LispWorks "dca-lispworks")
    2626   (:file "disk-cache-accessors")
    2727   #+not-yet
  • trunk/wood.lisp

    r38 r39  
    5757               (simple-error (condition)
    5858                (if (equalp "Wrong FASL version."
    59                             (simple-condition-format-string condition))
     59                            (simple-condition-format-control condition))
    6060                  (progn
    6161                    (format t "~&;Deleting FASL file from other MCL version...")
  • trunk/woodequ.lisp

    r38 r39  
    5757  `(logand ,pointer -8))
    5858
     59#+ccl (progn
     60
    5961(defconstant $tag-shift 3)
    6062(defconstant $tag-mask 7)
    6163
    62 #+ccl (progn
    6364(defconstant $t_fixnum 0)
    6465(defconstant $t_vector 1)
Note: See TracChangeset for help on using the changeset viewer.