Changeset 13527


Ignore:
Timestamp:
Mar 12, 2010, 10:05:36 PM (9 years ago)
Author:
gz
Message:

From trunk: support for non-ascii reader macros (r13498)

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl

  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r13505 r13527  
    19901990(defun copy-readtable (&optional (from *readtable*) to)
    19911991  (setq from (if from (readtable-arg from)  %standard-readtable%))
    1992   (setq to (if to
    1993              (readtable-arg to)
    1994              (%istruct 'readtable
    1995                         (make-array 256 :element-type '(unsigned-byte 8))
     1992  (let* ((fttab (rdtab.ttab from))
     1993         (ttablen (uvsize fttab)))
     1994    (declare (fixnum ttablen))
     1995    (setq to (if to
     1996               (readtable-arg to)
     1997               (%istruct 'readtable
     1998                         (make-array ttablen :element-type '(unsigned-byte 8))
    19961999                         nil (rdtab.case from))))
    1997   (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
    1998   (setf (rdtab.case to) (rdtab.case from))
    1999   (let* ((fttab (rdtab.ttab from))
    2000          (tttab (rdtab.ttab to)))
    2001     (%copy-ivector-to-ivector fttab 0 tttab 0 256))
    2002   to)
     2000    (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
     2001    (setf (rdtab.case to) (rdtab.case from))
     2002    (let* ((tttab (rdtab.ttab to)))
     2003      (%copy-ivector-to-ivector fttab 0 tttab 0 ttablen))
     2004    to))
    20032005
    20042006(declaim (inline %character-attribute))
     
    20062008(defun %character-attribute (char attrtab)
    20072009  (declare (character char)
    2008            (type (simple-array (unsigned-byte 8) (256)) attrtab)
     2010           (type (simple-array (unsigned-byte 8) (*)) attrtab)
    20092011           (optimize (speed 3) (safety 0)))
    20102012  (let* ((code (char-code char)))
    20112013    (declare (fixnum code))
    2012     (if (< code 256)
     2014    (if (< code (uvsize attrtab))
    20132015      (aref attrtab code)
    2014       ;; Should probably have an extension mechanism for things
    2015       ;; like NBS.
    20162016      $cht_cnst)))
     2017
     2018(defun %set-character-attribute (char readtable attr)
     2019  (let* ((code (char-code char))
     2020         (attrtab (rdtab.ttab readtable))
     2021         (oldsize (uvsize attrtab)))
     2022    (declare (type (mod #x110000) code)
     2023             (type (simple-array (unsigned-byte 8) (*)) attrtab))
     2024    (when (>= code oldsize)
     2025      ;; Characters whose code is > the current size of the table
     2026      ;; are implicitly constituents; don't grow the table just to
     2027      ;; store that info explicitly.
     2028      (if (eql attr $cht_cnst)
     2029        (return-from %set-character-attribute attr)
     2030        (let* ((newsize (min (+ code code) char-code-limit))
     2031               (new (make-array newsize
     2032                                :element-type '(unsigned-byte 8)
     2033                                :initial-element $cht_cnst)))
     2034          (declare ((simple-array (unsigned-byte 8) (*)) new))
     2035          (%copy-ivector-to-ivector attrtab 0 new 0 oldsize)
     2036          (setf (rdtab.ttab readtable) (setq attrtab new)))))
     2037    (setf (aref attrtab code) attr)))
     2038
    20172039
    20182040;;; returns: (values attrib <aux-info>), where
     
    20472069         (if old-to-info
    20482070           (setf (rdtab.alist to-readtable) (delq old-to-info (rdtab.alist to-readtable)))))
    2049        (if (and (= from-attr $cht_cnst)
    2050                 (member to-char '(#\Newline #\Linefeed #\Page #\Return
    2051                                   #\Space #\Tab #\Backspace #\Rubout)))
    2052            (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) $cht_ill)
    2053            (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) from-attr)))
     2071       (%set-character-attribute to-char
     2072                                 to-readtable
     2073                                 (if (and (= from-attr $cht_cnst)
     2074                                          (member to-char '(#\Newline #\Linefeed #\Page #\Return
     2075                                                            #\Space #\Tab #\Backspace #\Rubout)))
     2076                                   $cht_ill
     2077                                   from-attr)))
    20542078      t)))
    20552079
     
    20782102    (declare (list info))
    20792103    (without-interrupts
    2080      (setf (uvref (rdtab.ttab readtable) (char-code char))
    2081            (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
     2104     (%set-character-attribute char readtable
     2105                               (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
    20822106     (if (and (null fn) info)
    20832107       (setf (rdtab.alist readtable) (delete info (rdtab.alist readtable) :test #'eq))
     
    21152139    (declare (list info))
    21162140    (without-interrupts
    2117      (setf (uvref (rdtab.ttab readtable) (char-code char))
     2141     (%set-character-attribute char readtable
    21182142           (if non-terminating-p $cht_ntmac $cht_tmac))
    21192143     (if info
Note: See TracChangeset for help on using the changeset viewer.