Changeset 15343


Ignore:
Timestamp:
Apr 26, 2012, 3:37:32 AM (7 years ago)
Author:
gb
Message:

Define a simple SPARSE-VECTOR data type; use it for character attributes
in readtables.

Location:
trunk/source/level-1
Files:
2 edited

Legend:

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

    r14933 r15343  
    19781978;;; This -really- gets initialized later in the file
    19791979(defvar %standard-readtable%
    1980   (let* ((ttab (make-array 256 :element-type '(unsigned-byte 8)))
     1980  (let* ((ttab (make-sparse-vector char-code-limit '(unsigned-byte 8) $cht_cnst))
    19811981         (macs `((#\# . (,#'read-dispatch))))
    19821982         (case :upcase))
    1983     (dotimes (i 256) (declare (fixnum i))(uvset ttab i $cht_cnst))
    19841983    (dotimes (ch (1+ (char-code #\Space)))
    1985       (uvset ttab ch $cht_wsp))
    1986     (uvset ttab #xa0 $cht_wsp)
    1987     (uvset ttab (char-code #\\) $cht_sesc)
    1988     (uvset ttab (char-code #\|) $cht_mesc)
    1989     (uvset ttab (char-code #\#) $cht_ntmac)
    1990     (uvset ttab (char-code #\Backspace) $cht_ill)
    1991     (uvset ttab (char-code #\Rubout) $cht_ill)
     1984      (setf (sparse-vector-ref ttab ch) $cht_wsp))
     1985    (setf (sparse-vector-ref ttab #xa0) $cht_wsp)
     1986    (setf (sparse-vector-ref ttab (char-code #\\)) $cht_sesc)
     1987    (setf (sparse-vector-ref ttab (char-code #\|)) $cht_mesc)
     1988    (setf (sparse-vector-ref ttab (char-code #\#)) $cht_ntmac)
     1989    (setf (sparse-vector-ref ttab (char-code #\Backspace)) $cht_ill)
     1990    (setf (sparse-vector-ref ttab (char-code #\Rubout)) $cht_ill)
    19921991    (%istruct 'readtable ttab macs case)))
    19931992
     
    19991998(defun copy-readtable (&optional (from *readtable*) to)
    20001999  (setq from (if from (readtable-arg from)  %standard-readtable%))
    2001   (let* ((fttab (rdtab.ttab from))
    2002          (ttablen (uvsize fttab)))
    2003     (declare (fixnum ttablen))
     2000  (let* ((fttab (rdtab.ttab from)))
    20042001    (setq to (if to
    20052002               (readtable-arg to)
    20062003               (%istruct 'readtable
    2007                          (make-array ttablen :element-type '(unsigned-byte 8))
     2004                         (copy-sparse-vector fttab)
    20082005                         nil (rdtab.case from))))
    20092006    (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
    20102007    (setf (rdtab.case to) (rdtab.case from))
    2011     (let* ((tttab (rdtab.ttab to)))
    2012       (%copy-ivector-to-ivector fttab 0 tttab 0 ttablen))
    20132008    to))
    20142009
     
    20172012(defun %character-attribute (char attrtab)
    20182013  (declare (character char)
    2019            (type (simple-array (unsigned-byte 8) (*)) attrtab)
    20202014           (optimize (speed 3) (safety 0)))
    20212015  (let* ((code (char-code char)))
    20222016    (declare (fixnum code))
    2023     (if (< code (uvsize attrtab))
    2024       (aref attrtab code)
    2025       $cht_cnst)))
     2017    (sparse-vector-ref attrtab code)))
    20262018
    20272019(defun %set-character-attribute (char readtable attr)
    20282020  (let* ((code (char-code char))
    2029          (attrtab (rdtab.ttab readtable))
    2030          (oldsize (uvsize attrtab)))
    2031     (declare (type (mod #x110000) code)
    2032              (type (simple-array (unsigned-byte 8) (*)) attrtab))
    2033     (when (>= code oldsize)
    2034       ;; Characters whose code is > the current size of the table
    2035       ;; are implicitly constituents; don't grow the table just to
    2036       ;; store that info explicitly.
    2037       (if (eql attr $cht_cnst)
    2038         (return-from %set-character-attribute attr)
    2039         (let* ((newsize (min (+ code code) char-code-limit))
    2040                (new (make-array newsize
    2041                                 :element-type '(unsigned-byte 8)
    2042                                 :initial-element $cht_cnst)))
    2043           (declare ((simple-array (unsigned-byte 8) (*)) new))
    2044           (%copy-ivector-to-ivector attrtab 0 new 0 oldsize)
    2045           (setf (rdtab.ttab readtable) (setq attrtab new)))))
    2046     (setf (aref attrtab code) attr)))
     2021         (attrtab (rdtab.ttab readtable)))
     2022    (declare (type (mod #x110000) code))
     2023    (setf (sparse-vector-ref attrtab code) attr)))
    20472024
    20482025
  • trunk/source/level-1/sysutils.lisp

    r14896 r15343  
    905905
    906906
     907;;; Sparse vectors, or at least a certain kind of sparse-vector.
     908;;; This kind is oriented strongly towards maintaining character
     909;;; attributes for Unicode characters (for the reader, Hemlock,etc.)
     910(defstruct (sparse-vector (:constructor %make-sparse-vector)
     911                          (:copier nil))
     912  size
     913  element-type
     914  default
     915  table
     916  (lock (make-lock)))
     917
     918(defun make-sparse-vector (size element-type default)
     919  (unless (and (typep size 'fixnum)
     920               (locally (declare (fixnum size))
     921                 (and (> size 0)
     922                      (< size array-total-size-limit))))
     923    (report-bad-arg size `(integer 1 ,array-total-size-limit)))
     924  (setq element-type (upgraded-array-element-type element-type))
     925  (unless (typep default element-type)
     926    (report-bad-arg default element-type))
     927  (%make-sparse-vector :size size
     928                       :element-type element-type
     929                       :default default
     930                       :table (make-array 1
     931                                          :element-type t
     932                                          :initial-element nil)))
     933
     934(defun sparse-vector-ref (sv i)
     935  (unless (and (typep i 'fixnum)
     936               (>= (the fixnum i) 0)
     937               (< (the fixnum i) (the fixnum (sparse-vector-size sv))))
     938    (%err-disp $xarroob sv i))
     939  (locally (declare (fixnum i))
     940    (let* ((major (ash i -8))
     941           (table (sparse-vector-table sv))
     942           (v (if (< major (length table))
     943                (svref table major))))
     944      (declare (fixnum major))
     945      (if (null v)
     946        (sparse-vector-default sv)
     947        (uvref v (logand i #xff))))))
     948
     949(defun (setf sparse-vector-ref) (new sv i)
     950  (unless (and (typep i 'fixnum)
     951               (>= (the fixnum i) 0)
     952               (< (the fixnum i) (the fixnum (sparse-vector-size sv))))
     953    (%err-disp $xarroob sv i))
     954  (let* ((default (sparse-vector-default sv)))
     955    (with-lock-grabbed ((sparse-vector-lock sv))
     956      (locally (declare (fixnum i))
     957        (let* ((major (ash i -8))
     958               (minor (logand i #xff))
     959               (table (sparse-vector-table sv))
     960               (tablen (length table))
     961               (v (if (< major tablen)
     962                    (svref table major))))
     963          (unless v
     964            (unless (eql new default)
     965              (when (< major tablen)
     966                (let* ((newtab (make-array (the fixnum (1+ major)))))
     967                  (%copy-gvector-to-gvector table 0 newtab 0 tablen)
     968                  (setf (sparse-vector-table sv) (setq table newtab))))
     969              (setq v (setf (svref table major) (make-array 256 :element-type (sparse-vector-element-type sv) :initial-element default)))))
     970          (when v
     971            (uvset v minor new))))))
     972  new)
     973
     974(defun copy-sparse-vector (in)
     975  (let* ((intab (sparse-vector-table in))
     976         (tabsize (length intab )))
     977    (declare (fixnum tabsize) (simple-vector intab))
     978    (let* ((out (%make-sparse-vector :size (sparse-vector-size in)
     979                                     :element-type (sparse-vector-element-type in)
     980                                     :default (sparse-vector-default in)
     981                                     :table (make-array tabsize :initial-element nil)))
     982           (outtab (sparse-vector-table out)))
     983      (declare (simple-vector outtab))
     984      (dotimes (i tabsize out)
     985        (let* ((v (svref intab i)))
     986          (when v
     987            (setf (svref outtab i) (copy-seq v))))))))
     988
     989(defmethod print-object ((sv sparse-vector) stream)
     990  (print-unreadable-object (sv stream :type t :identity t)
     991    (format stream "~d ~s" (sparse-vector-size sv) (sparse-vector-element-type sv))))
Note: See TracChangeset for help on using the changeset viewer.