Changeset 16442


Ignore:
Timestamp:
Jun 29, 2015, 11:26:47 AM (4 years ago)
Author:
gb
Message:

Use sparse-vectors for reader-macros. seems to scale better. Fixes ticket:1282
in the trunk.

Back to work.

Location:
trunk/source
Files:
2 edited

Legend:

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

    r16431 r16442  
    18461846    (register-character-name name char)))
    18471847
     1848(defun need-char-code (char)
     1849  (or (char-code char) (error "undefined charactern ~a" char)))
     1850
    18481851
    18491852
     
    19561959
    19571960(eval-when (:compile-toplevel :execute)
    1958 (def-accessors %svref
    1959   token.string
    1960   token.ipos
    1961   token.opos
    1962   token.len
    1963 )
    1964 
    1965 (defmacro with-token-buffer ((name) &body body &environment env)
    1966   (multiple-value-bind (body decls) (parse-body body env nil)
    1967     `(let* ((,name (vector (%get-token-string 16) 0 0 16 nil)))
    1968        (declare (dynamic-extent ,name))
    1969        (unwind-protect
    1970          (locally ,@decls ,@body)
    1971          (%return-token-string ,name)))))
    1972 )
     1961  (def-accessors %svref
     1962      token.string
     1963    token.ipos
     1964    token.opos
     1965    token.len
     1966    )
     1967
     1968  (defmacro with-token-buffer ((name) &body body &environment env)
     1969    (multiple-value-bind (body decls) (parse-body body env nil)
     1970      `(let* ((,name (vector (%get-token-string 16) 0 0 16 nil)))
     1971        (declare (dynamic-extent ,name))
     1972        (unwind-protect
     1973             (locally ,@decls ,@body)
     1974          (%return-token-string ,name)))))
     1975  )
    19731976
    19741977(defun read-dispatch (stream char)
    1975   (let* ((info (cdr (assq char (rdtab.alist *readtable*)))))
     1978  (let* ((alistp (typep (rdtab.macros *readtable*) 'list))
     1979         (info (if alistp
     1980                 (cdr (assq char (rdtab.macros *readtable*)))
     1981                 (let* ((code (need-char-code char)))
     1982                   (sparse-vector-ref (rdtab.macros *readtable*) code)))))
    19761983    (with-token-buffer (tb)
    19771984      (let* ((subchar nil)
     
    19821989                (return (setq subchar (char-upcase subchar)
    19831990                              numarg (%token-to-number tb 10)))))
    1984         (let* ((dispfun (cdr (assq subchar (cdr info)))))     ; <== WAS char
     1991        (let* ((dispfun (if alistp (cdr (assq subchar (cdr info)))
     1992                          (and (consp info) (sparse-vector-ref (cdr info) (need-char-code subchar))))))
     1993   ; <== WAS char
     1994               
     1995                         
    19851996          (if dispfun
    19861997              (funcall dispfun stream subchar numarg)
     
    19902001(defvar %standard-readtable%
    19912002  (let* ((ttab (make-sparse-vector char-code-limit '(unsigned-byte 8) $cht_cnst))
    1992          (macs `((#\# . (,#'read-dispatch))))
     2003         (macs (make-sparse-vector char-code-limit t nil))
    19932004         (case :upcase))
     2005  (setf (sparse-vector-ref macs (char-code #\#)) (cons #'read-dispatch (make-sparse-vector char-code-limit t nil)))
    19942006    (dotimes (ch (1+ (char-code #\Space)))
    19952007      (setf (sparse-vector-ref ttab ch) $cht_wsp))
     
    20072019(queue-fixup (setq %initial-readtable% (copy-readtable *readtable*)))
    20082020
     2021(defun %get-readtable-char (char &optional (readtable *readtable*))
     2022  (setq char (require-type char 'character))
     2023  (let* ((attr (%character-attribute char (rdtab.ttab readtable))))
     2024    (declare (fixnum attr))
     2025    (values attr (if (logbitp $cht_macbit attr) (assoc char (rdtab.macros readtable))))))
     2026
     2027(defun copy-macro-table (table)
     2028  (let*  ((out (copy-sparse-vector table))
     2029          (outtab (sparse-vector-table out)))
     2030   
     2031   (dotimes (i (length outtab) out)
     2032      (let* ((v (svref outtab i)))
     2033        (when v
     2034          (dotimes (j (length v))
     2035            (let* ((datum (svref v j)))
     2036              (when (consp datum)
     2037                (setf (svref v i)
     2038                      (cons (car datum)
     2039                            (copy-macro-table (cdr datum))))))))))))
     2040   
     2041
     2042
    20092043(defun copy-readtable (&optional (from *readtable*) to)
    20102044  (setq from (if from (readtable-arg from)  %standard-readtable%))
     
    20152049                         (copy-sparse-vector fttab)
    20162050                         nil (rdtab.case from))))
    2017     (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
     2051    (if (listp (rdtab.macros from))
     2052      (setf (rdtab.macros to) (copy-tree (rdtab.macros from)))
     2053      (setf (rdtab.macros to) (copy-macro-table (rdtab.macros from))))
     2054
     2055
    20182056    (setf (rdtab.case to) (rdtab.case from))
    20192057    to))
     
    20352073
    20362074
    2037 ;;; returns: (values attrib <aux-info>), where
    2038 ;;;           <aux-info> = (char . fn), if terminating macro
    2039 ;;;                      = (char . (fn . dispatch-alist)), if dispatching macro
    2040 ;;;                      = nil otherwise
    2041 
    2042 
    2043 (defun %get-readtable-char (char &optional (readtable *readtable*))
    2044   (setq char (require-type char 'character))
    2045   (let* ((attr (%character-attribute char (rdtab.ttab readtable))))
    2046     (declare (fixnum attr))
    2047     (values attr (if (logbitp $cht_macbit attr) (assoc char (rdtab.alist readtable))))))
     2075
     2076
     2077
    20482078
    20492079
     
    20562086  (setq to-readtable (readtable-arg to-readtable))
    20572087  (setq from-readtable (readtable-arg (or from-readtable %initial-readtable%)))
    2058   (multiple-value-bind (from-attr from-info) (%get-readtable-char from-char from-readtable)
    2059     (let* ((new-tree (copy-tree (cdr from-info)))
    2060            (old-to-info (nth-value 1 (%get-readtable-char to-char to-readtable))))
    2061       (without-interrupts
    2062        (if from-info
    2063          (if old-to-info
    2064            (setf (cdr old-to-info) new-tree)
    2065            (push (cons to-char new-tree) (rdtab.alist to-readtable)))
    2066          (if old-to-info
    2067            (setf (rdtab.alist to-readtable) (delq old-to-info (rdtab.alist to-readtable)))))
    2068        (%set-character-attribute to-char
    2069                                  to-readtable
    2070                                  (if (and (= from-attr $cht_cnst)
    2071                                           (member to-char '(#\Newline #\Linefeed #\Page #\Return
    2072                                                             #\Space #\Tab #\Backspace #\Rubout)))
    2073                                    $cht_ill
    2074                                    from-attr)))
    2075       t)))
     2088  (let* ((from-attr (%character-attribute from-char (rdtab.ttab from-readtable)))
     2089         (from-info (sparse-vector-ref (rdtab.macros from-readtable) (need-char-code from-char))))
     2090    (if (atom from-info)
     2091      (setf (sparse-vector-ref (rdtab.macros to-readtable) (need-char-code to-char)) from-info)
     2092      (setf (sparse-vector-ref (rdtab.macros to-readtable) (need-char-code to-char))
     2093            (cons (car from-info)
     2094                  (copy-macro-table  (cdr from-info)))))
     2095     
     2096    (%set-character-attribute  to-char
     2097                               to-readtable
     2098                               (if (and (= from-attr $cht_cnst)
     2099                                        (member to-char '(#\Newline #\Linefeed #\Page #\Return
     2100                                                          #\Space #\Tab #\Backspace #\Rubout)))
     2101                                 $cht_ill
     2102                                 from-attr)))
     2103  t)
    20762104
    20772105(defun get-macro-character (char &optional readtable)
     
    20812109  be embedded in a symbol name."
    20822110  (setq readtable (readtable-arg readtable))
    2083   (multiple-value-bind (attr info) (%get-readtable-char char readtable)
    2084     (declare (fixnum attr) (list info))
    2085     (let* ((def (cdr info)))
    2086       (values (if (consp def) (car def) def)
    2087               (= attr $cht_ntmac)))))
     2111  (if (listp (rdtab.macros readtable))
     2112    (multiple-value-bind (attr info) (%get-readtable-char char readtable)
     2113      (declare (fixnum attr) (list info))
     2114      (let* ((def (cdr info)))
     2115        (values (if (consp def) (car def) def)
     2116                (= attr $cht_ntmac))))
     2117    (let* ((code (need-char-code char))
     2118           (info (sparse-vector-ref (rdtab.macros readtable) code)))
     2119     
     2120             
     2121      (values (if (atom info) info (car info))
     2122              (= (%character-attribute  char (rdtab.ttab readtable)) $cht_ntmac)))))
     2123
     2124     
    20882125
    20892126(defun set-macro-character (char fn &optional non-terminating-p readtable)
     
    20962133    (unless (or (symbolp fn) (functionp fn))
    20972134      (setq fn (require-type fn '(or symbol function)))))
    2098   (let* ((info (nth-value 1 (%get-readtable-char char readtable))))
    2099     (declare (list info))
    2100     (without-interrupts
    2101      (%set-character-attribute char readtable
    2102                                (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
    2103      (if (and (null fn) info)
    2104        (setf (rdtab.alist readtable) (delete info (rdtab.alist readtable) :test #'eq))
    2105        (if (null info)
    2106          (push (cons char fn) (rdtab.alist readtable))
    2107          (let* ((def (cdr info)))
    2108            (if (atom def)
    2109              (setf (cdr info) fn)         ; Non-dispatching
    2110              (setf (car def) fn))))))     ; Dispatching
    2111     t))
     2135  (%set-character-attribute char readtable
     2136                            (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
     2137  (if (listp (rdtab.macros readtable))
     2138    (let* ((info (nth-value 1 (%get-readtable-char char readtable))))
     2139      (declare (list info))
     2140      (without-interrupts
     2141     
     2142       (if (and (null fn) info)
     2143         (setf (rdtab.macros readtable) (delete info (rdtab.macros readtable) :test #'eq))
     2144         (if (null info)
     2145           (push (cons char fn) (rdtab.macros readtable))
     2146           (let* ((def (cdr info)))
     2147             (if (atom def)
     2148               (setf (cdr info) fn)     ; Non-dispatching
     2149               (setf (car def) fn)))))) ; Dispatching
     2150      t)
     2151    (let* ((code (or (need-char-code char) ))
     2152           (info (sparse-vector-ref (rdtab.macros readtable) code)))
     2153      (if (consp info)
     2154        (setf (car info) fn)
     2155        (setf (sparse-vector-ref (rdtab.macros readtable) code) fn))
     2156      t)))
    21122157
    21132158(defun readtable-case (readtable)
     
    21332178  (setq readtable (readtable-arg readtable))
    21342179  (setq char (require-type char 'base-char))
     2180  (%set-character-attribute char readtable
     2181           (if non-terminating-p $cht_ntmac $cht_tmac))
     2182  (if (listp (rdtab.macros readtable))
     2183   
    21352184  (let* ((info (nth-value 1 (%get-readtable-char char readtable))))
    21362185    (declare (list info))
    21372186    (without-interrupts
    2138      (%set-character-attribute char readtable
    2139            (if non-terminating-p $cht_ntmac $cht_tmac))
    2140      (if info
     2187          (if info
    21412188       (rplacd (cdr info) nil)
    2142        (push (cons char (cons #'read-dispatch nil)) (rdtab.alist readtable)))))
     2189       (push (cons char (cons #'read-dispatch nil)) (rdtab.macros readtable)))))
     2190    (setf (sparse-vector-ref (rdtab.macros readtable) (need-char-code char))
     2191          (cons #'read-dispatch (make-sparse-vector char-code-limit t nil))))
    21432192  t)
    21442193
     
    21502199  (setq sub-ch (char-upcase (require-type sub-ch 'base-char)))
    21512200  (unless (digit-char-p sub-ch 10)
    2152     (let* ((def (cdr (nth-value 1 (%get-readtable-char disp-ch readtable)))))
    2153       (if (consp def)
    2154         (cdr (assq sub-ch (cdr def)))
    2155         (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)))))
     2201    (if (listp (rdtab.macros readtable))
     2202      (let* ((def (cdr (nth-value 1 (%get-readtable-char disp-ch readtable)))))
     2203        (if (consp def)
     2204          (cdr (assq sub-ch (cdr def)))
     2205          (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)))
     2206      (let* ((code (char-code disp-ch))
     2207             (info (sparse-vector-ref (rdtab.macros readtable) code)))
     2208        (if (atom info)
     2209          (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)
     2210          (let* ((subcode (char-code sub-ch)))
     2211            (sparse-vector-ref (cdr info) subcode)))))))
    21562212
    21572213(defun set-dispatch-macro-character (disp-ch sub-ch fn &optional readtable)
     
    21632219  (when (digit-char-p sub-ch 10)
    21642220    (error "subchar can't be a decimal digit - ~a ." sub-ch))
    2165   (let* ((info (nth-value 1 (%get-readtable-char disp-ch readtable)))
    2166          (def (cdr info)))
    2167     (declare (list info))
    2168     (unless (consp def)
    2169       (error "~A is not a dispatching macro character in ~s ." disp-ch readtable))
    2170     (let* ((alist (cdr def))
    2171            (pair (assq sub-ch alist)))
    2172       (if pair
    2173         (setf (cdr pair) fn)
    2174         (push (cons sub-ch fn) (cdr def))))
    2175     t))
    2176 
     2221  (if (listp (rdtab.macros readtable))
     2222    (let* ((info (nth-value 1 (%get-readtable-char disp-ch readtable)))
     2223           (def (cdr info)))
     2224      (declare (list info))
     2225      (unless (consp def)
     2226        (error "~A is not a dispatching macro character in ~s ." disp-ch readtable))
     2227      (let* ((alist (cdr def))
     2228             (pair (assq sub-ch alist)))
     2229        (if pair
     2230          (setf (cdr pair) fn)
     2231          (push (cons sub-ch fn) (cdr def))))
     2232      t)
     2233    (let* ((code (char-code disp-ch))
     2234           (info (sparse-vector-ref (rdtab.macros readtable) code)))
     2235      (if (atom info)
     2236        (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)
     2237        (let* ((subcode (char-code sub-ch)))
     2238          (setf (sparse-vector-ref (cdr info) subcode) fn))))))
     2239
     2240
     2241(defun convert-readtable-macros (readtable)
     2242  (let*  ((alist (rdtab.macros readtable)))
     2243    (when (listp alist)
     2244      (let* ((new (make-sparse-vector char-code-limit t  nil)))
     2245        (dolist (pair alist)
     2246          (destructuring-bind (char . f) pair
     2247            (if (atom f)
     2248              (setf (sparse-vector-ref new (need-char-code char)) f)
     2249              (let* ((sub (make-sparse-vector char-code-limit t nil)))
     2250                (dolist (pair (cdr f))
     2251                  (destructuring-bind (subch . subf) pair
     2252                    (setf (sparse-vector-ref sub (need-char-code subch)) subf)))
     2253                (setf (sparse-vector-ref new (need-char-code char))(cons (car f) sub))))))
     2254      (setf (rdtab.macros readtable) new)))))
    21772255
    21782256;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    25252603                     (if (not (logbitp $cht_macbit attr))
    25262604                       (%parse-token stream firstchar dot-ok)
    2527                        (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
     2605                       (let* ((def (if (listp (rdtab.macros readtable))
     2606                                     (cdr (assq firstchar (rdtab.macros readtable)))
     2607                                     (sparse-vector-ref (rdtab.macros readtable) (need-char-code firstchar )))))
    25282608                         (cond ((null def))
    25292609                               ((atom def)
  • trunk/source/library/lispequ.lisp

    r16340 r16442  
    616616  ()                                        ; 'readtable
    617617  rdtab.ttab                                ; type table
    618   rdtab.alist                               ; macro-char alist
     618  rdtab.macros                               ; macro-char table
    619619  rdtab.case)                               ; gratuitous braindeath
    620620
Note: See TracChangeset for help on using the changeset viewer.