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

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

File:
1 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
Note: See TracChangeset for help on using the changeset viewer.