/[cmucl]/src/code/extfmts.lisp
ViewVC logotype

Diff of /src/code/extfmts.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.3.2.17 by rtoy, Fri Apr 24 19:18:12 2009 UTC revision 1.2.4.3.2.18 by rtoy, Thu Apr 30 18:52:43 2009 UTC
# Line 174  Line 174 
174                       (let (,@',slotb                       (let (,@',slotb
175                             (,code ',code)                             (,code ',code)
176                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
177                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp)))                         `(let ((,',code (the (unsigned-byte 21) ,,',tmp)))
178                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
179                            ,,body)))))                            ,,body)))))
180         (%intern-ef (make-external-format ,name         (%intern-ef (make-external-format ,name
# Line 186  Line 186 
186                                                            :initial-element nil)                                                            :initial-element nil)
187                                      :min ,(min min max) :max ,(max min max)))                                      :min ,(min min max) :max ,(max min max)))
188                      nil                      nil
189                      (vector ,@(mapcar #'third slotd))                      (let* ,(loop for x in slotd
190                                     collect (list (first x) (third x)))
191                          (vector ,@(mapcar #'first slotd)))
192                      ',slotd)))))                      ',slotd)))))
193    
194  ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public  ;;; DEFINE-COMPOSING-EXTERNAL-FORMAT  -- Public
# Line 206  Line 208 
208                    `(lambda (,state ,input ,unput)                    `(lambda (,state ,input ,unput)
209                       (declare (ignorable ,state ,input ,unput)                       (declare (ignorable ,state ,input ,unput)
210                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
211                       (let ((,input `(the (values (or (unsigned-byte 31) null)                       (let ((,input `(the (values (or (unsigned-byte 21) null)
212                                                   kernel:index)                                                   kernel:index)
213                                           ,,input))                                           ,,input))
214                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
# Line 217  Line 219 
219                                (optimize (ext:inhibit-warnings 3)))                                (optimize (ext:inhibit-warnings 3)))
220                       (let ((,code ',code)                       (let ((,code ',code)
221                             ,@(loop for var in vars collect `(,var (gensym))))                             ,@(loop for var in vars collect `(,var (gensym))))
222                         `(let ((,',code (the (unsigned-byte 31) ,,',tmp)))                         `(let ((,',code (the (unsigned-byte 21) ,,',tmp)))
223                            (declare (ignorable ,',code))                            (declare (ignorable ,',code))
224                            ,,body)))))                            ,,body)))))
225         (%intern-ef (make-external-format ,name         (%intern-ef (make-external-format ,name
# Line 340  Line 342 
342             (optimize (speed 3) (space 0) (safety 0) (debug 0)             (optimize (speed 3) (space 0) (safety 0) (debug 0)
343                       (ext:inhibit-warnings 3)))                       (ext:inhibit-warnings 3)))
344    (or (gethash table *.table-inverse.*)    (or (gethash table *.table-inverse.*)
345        (let* ((result (make-hash-table))        (let* ((mbits (if (= (array-total-size table) 128) 7 8))
346                 (lbits (cond ((> (array-total-size table) 256) 3)
347                              ((< (array-total-size table) 100) 6)
348                              (t 5)))
349                 (hvec (make-array (1+ (ash #x110000 (- 0 mbits lbits)))
350                                   :element-type '(unsigned-byte 16)
351                                   :initial-element #xFFFF))
352                 (mvec (make-array 0 :element-type '(unsigned-byte 16)))
353                 (lvec (make-array 0 :element-type '(unsigned-byte 16)))
354               (width (array-dimension table 0))               (width (array-dimension table 0))
355               (power (1- (array-rank table)))               (power (1- (array-rank table)))
356               (base (if (= width 94) 1 0)))               (base (if (= width 94) 1 0))
357          (assert (and (< power 3) (<= width 256)))               hx mx lx)
358            (assert (and (< power 2) (<= width 256)))
359          (dotimes (i (array-total-size table))          (dotimes (i (array-total-size table))
360            (declare (type (integer 0 (#.array-dimension-limit)) i))            (declare (type (integer 0 (#.array-dimension-limit)) i))
361            (let ((tmp i) (val (row-major-aref table i)) (z 0))            (let ((tmp i) (val (row-major-aref table i)) (z 0))
362              (declare (type (integer 0 (#.array-dimension-limit)) tmp)              (declare (type (integer 0 (#.array-dimension-limit)) tmp)
363                       (type (unsigned-byte 32) z))                       (type (unsigned-byte 16) z))
364              (unless (or (= val #xFFFE) (gethash val result))              (unless (= val #xFFFE)
365                (dotimes (j power)                (when (plusp power)
                 ;; j is only ever 0 in reality, since no n^3 tables are  
                 ;; defined; z was declared as 32-bit above, so that limits  
                 ;; us to 0 <= j <= 2   (see the ASSERT)  
                 (declare (type (integer 0 2) j))  
366                  (multiple-value-bind (x y) (floor tmp width)                  (multiple-value-bind (x y) (floor tmp width)
367                    (setq tmp x)                    (setq tmp x)
368                    (setq z (logior z (ash (the (integer 0 255) (+ y base))                    (setq z (logior z (ash (the (integer 0 255) (+ y base))
369                                           (the (integer 0 24)                                           (the (integer 0 24)
370                                             (* 8 (- power j))))))))                                             (* 8 power)))))))
371                (setf (gethash val result) (logior z (+ tmp base))))))                (setq hx (ash val (- 0 mbits lbits)))
372          (setf (gethash table *.table-inverse.*) result))))                (when (= (aref hvec hx) #xFFFF)
373                    (setf (aref hvec hx) (length mvec))
374                    (let ((tmp (make-array (+ (length mvec) (ash 1 mbits))
375                                           :element-type '(unsigned-byte 16)
376                                           :initial-element #xFFFF)))
377                      (replace tmp mvec)
378                      (setq mvec tmp)))
379                  (setq mx (logand (ash val (- lbits)) (lognot (ash -1 mbits))))
380                  (when (= (aref mvec (+ hx mx)) #xFFFF)
381                    (setf (aref mvec (+ hx mx)) (length lvec))
382                    (let ((tmp (make-array (+ (length lvec) (ash 1 lbits))
383                                           :element-type '(unsigned-byte 16)
384                                           :initial-element #xFFFF)))
385                      (replace tmp lvec)
386                      (setq lvec tmp)))
387                  (setq lx (logand val (lognot (ash -1 lbits))))
388                  (setf (aref lvec (+ (aref mvec (+ hx mx)) lx))
389                      (logior z (+ tmp base))))))
390            (setf (gethash table *.table-inverse.*)
391                (lisp::make-ntrie16 :split (logior (ash (1- mbits) 4) (1- lbits))
392                                    :hvec hvec :mvec mvec :lvec lvec)))))
393    
394    (declaim (inline get-inverse))
395    (defun get-inverse (ntrie code)
396      (declare (type lisp::ntrie16 ntrie) (type (integer 0 #x10FFFF) code))
397      (let ((n (lisp::qref ntrie code)))
398        (and n (let ((m (aref (lisp::ntrie16-lvec ntrie) n)))
399                 (if (= m #xFFFF) nil m)))))
400    
401    
402  (define-condition void-external-format (error)  (define-condition void-external-format (error)
# Line 397  Line 431 
431      `(multiple-value-bind (,tmp1 ,tmp2)      `(multiple-value-bind (,tmp1 ,tmp2)
432           ,(funcall (ef-octets-to-code ef) state input unput)           ,(funcall (ef-octets-to-code ef) state input unput)
433         (setf ,count (the kernel:index ,tmp2))         (setf ,count (the kernel:index ,tmp2))
434         (the (or (unsigned-byte 31) null) ,tmp1))))         (the (or (unsigned-byte 21) null) ,tmp1))))
435    
436  (defmacro codepoint-to-octets (external-format code state output)  (defmacro codepoint-to-octets (external-format code state output)
437    (let ((ef (find-external-format external-format)))    (let ((ef (find-external-format external-format)))
# Line 434  Line 468 
468                          (setf (aref (ef-cache ,tmp1) ,tmp2)                          (setf (aref (ef-cache ,tmp1) ,tmp2)
469                              (let ((*compile-print* nil)                              (let ((*compile-print* nil)
470                                    ;; Set default format when we compile so we                                    ;; Set default format when we compile so we
471                                    ;; can see compiler messages.  if we don't,                                    ;; can see compiler messages.  If we don't,
472                                    ;; we run into a problem that we might be                                    ;; we run into a problem that we might be
473                                    ;; changing the default format while we're                                    ;; changing the default format while we're
474                                    ;; compiling, and we don't know how to output                                    ;; compiling, and we don't know how to output

Legend:
Removed from v.1.2.4.3.2.17  
changed lines
  Added in v.1.2.4.3.2.18

  ViewVC Help
Powered by ViewVC 1.1.5