Changeset 7624

branches/working-0711/ccl/compiler/PPC/PPC32/ppc32-arch.lisp

-                      r6456
+                      r7624
   malloced-ptr
   spinlock)
+(define-storage-layout rwlock 0
+  spin
+  state
+  blocked-writers
+  blocked-readers
+  writer
+  reader-signal
+  writer-signal
+  malloced-ptr
+  )
 ;;; For the eabi port: mark this stack frame as Lisp's (since EABI

branches/working-0711/ccl/compiler/PPC/PPC64/ppc64-arch.lisp

-                      r6457
+                      r7624
   malloced-ptr
   spinlock)
+(define-storage-layout rwlock 0
+  spin
+  state
+  blocked-writers
+  blocked-readers
+  writer
+  reader-signal
+  writer-signal
+  malloced-ptr
+  )
 ;;; For the eabi port: mark this stack frame as Lisp's (since EABI

branches/working-0711/ccl/compiler/PPC/ppc-lapmacros.lisp

-                      r5096
+                      r7624
    (:ppc32 `(slwi ,@args))
    (:ppc64 `(sldi ,@args))))
+(defppclapmacro slri. (&rest args)
+  (target-arch-case
+   (:ppc32 `(slwi. ,@args))
+   (:ppc64 `(sldi. ,@args))))
 (defppclapmacro srr (&rest args)

branches/working-0711/ccl/compiler/X86/X8664/x8664-arch.lisp

-                      r6462
+                      r7624
 (defx86reg save3 r11)
 (defx86reg save3.l r11d)
 (defx86reg save3.w r10w)
 (defx86reg save3.b r10b)
+(defx86reg save3.w r11w)
+(defx86reg save3.b r11b)
 (defx86reg save2 r12)
 …
   malloced-ptr
   spinlock)
+(define-storage-layout rwlock 0
+  spin
+  state
+  blocked-writers
+  blocked-readers
+  writer
+  reader-signal
+  writer-signal
+  malloced-ptr
+  )
 (defmacro define-header (name element-count subtag)

branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp

-                      r7376
+                      r7624
                     (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
                                                                    (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
                     (dynamic-extent-names name))
+                         (dynamic-extent-names name))
                   (progn
                     (rlets (list name (foreign-record-type-name argtype)))
 …
                                (:unsigned-byte '%get-unsigned-byte)
                                (:address
+                                ;(dynamic-extent-names name)
+                                #+nil
+                                (dynamic-extent-names name)
                                 '%get-ptr))
                              ,stack-ptr

branches/working-0711/ccl/compiler/X86/x86-arch.lisp

r6930	r7624
40	40	area-lock ; serialize access to gc
41	41	exception-lock ; serialize exception handling
42		~~deleted-static-pairs ; hash-consing~~
	42	static-conses ; when FREEZE is in effect
43	43	default-allocation-quantum ; log2_heap_segment_size, as a fixnum.
44	44	intflag ; interrupt-pending flag

branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

-                      r6996
+                      r7624
 (defun nop-fixup (ds bytemode sizeflag)
+  (declare (ignore bytemode sizeflag))
+  (declare (ignore bytemode sizeflag)
+           (ignorable ds))
+  #+nothing
   (if (logtest (x86-ds-prefixes ds) +prefix-repz+)
     (break "should be PAUSE")))

branches/working-0711/ccl/compiler/X86/x862.lisp

-                      r7443
+                      r7624
                      (case src-mode
                        (#.hard-reg-class-gpr-mode-node
+                        (! unbox-u32 dest src))
+                        (if *x862-reckless*
+                          (! %unbox-u32 dest src)
+                          (! unbox-u32 dest src)))
                        ((#.hard-reg-class-gpr-mode-u32
                          #.hard-reg-class-gpr-mode-s32)
 …
                      (case src-mode
                        (#.hard-reg-class-gpr-mode-node
+                        (! unbox-u16 dest src))
+                        (if *x862-reckless*
+                          (! %unbox-u16 dest src)
+                          (! unbox-u16 dest src)))
                        ((#.hard-reg-class-gpr-mode-u8
                          #.hard-reg-class-gpr-mode-s8)

branches/working-0711/ccl/compiler/arch.lisp

-                      r5529
+                      r7624
 (defconstant tcr-flag-bit-foreign 0)
 (defconstant tcr-flag-bit-awaiting-preset 1)
+(defconstant tcr-flag-bit-alt-suspend 2)
+(defconstant tcr-flag-bit-propagate-exception 3)
+(defconstant tcr-flag-bit-suspend-ack-pending 4)
+(defconstant tcr-flag-bit-pending-exception 5)
+(defconstant tcr-flag-bit-foreign-exception 6)
+(defconstant tcr-flag-bit-pending-suspend 7)
 …
 (defconstant error-cant-take-car 8)
 (defconstant error-cant-take-cdr 9)
+(defconstant error-propagate-suspend 10)
 (defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
 (eval-when (:compile-toplevel :load-toplevel :execute)
 …
 (defconstant gc-trap-function-configure-egc 64)
 (defconstant gc-trap-function-set-hons-area-size 128)
+(defconstant gc-trap-function-freeze 129)
+(defconstant gc-trap-function-thaw 130)

branches/working-0711/ccl/compiler/nx1.lisp

-                      r6175
+                      r7624
      (%nx1-operator %immediate-set-xxx)
      (case op
        (%%set-signed-longlong (logior 32 8))
        (t 8))
+       (%%set-signed-longlong 8)
+       (t (logior 32 8)))
      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
      (nx1-form offset)

branches/working-0711/ccl/compiler/optimizers.lisp

-                      r6473
+                      r7624
     t))
+;;; return new form if no keys (or if keys constant and specify :TEST
+;;; {#'eq, #'eql} only.)
+(defun eq-eql-call (x l keys eq-fn  eql-fn env)
+  (flet ((eql-to-eq ()
+           (or (eql-iff-eq-p x env)
+               (and (or (quoted-form-p l) (null l))
+                    (dolist (elt (%cadr l) t)
+                      (when (eq eq-fn 'assq) (setq elt (car elt)))
+                      (when (and (numberp elt) (not (fixnump elt)))
+                        (return nil)))))))
+    (if (null keys)
+      (list (if (eql-to-eq) eq-fn eql-fn) x l)
+      (if (constant-keywords-p keys)
+(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
+  (if (null keys)
+    `(,default ,item ,list)
+     (if (constant-keywords-p keys)
         (destructuring-bind (&key (test nil test-p)
                                   (test-not nil test-not-p)
                                   (key nil key-p))
                             keys
           (declare (ignore test-not key))
+          (declare (ignore test-not))
           (if (and test-p
+                   (not test-not-p)
+                   (not key-p)
+                   (not test-not-p)
+                   (or (not key-p)
+                       (and (consp key)
+                            (consp (%cdr key))
+                            (null (%cddr key))
+                            (or (eq (%car key) 'function)
+                                (eq (%car key) 'quote))
+                            (eq (%cadr key) 'identity)))
                    (consp test)
                    (consp (%cdr test))
 …
                    (or (eq (%car test) 'function)
                        (eq (%car test) 'quote)))
+            (let ((testname (%cadr test)))
+              (if (or (eq testname 'eq)
+                      (and (eq testname 'eql)
+                           (eql-to-eq)))
+                (list eq-fn x l)
+                (if (and eql-fn (eq testname 'eql))
+                  (list eql-fn x l))))))))))
+            (let* ((testname (%cadr test))
+                   (reduced (cdr (assoc testname alist))))
+              (if reduced
+                `(,reduced ,item ,list)
+                `(,testonly ,item ,list ,test))))))))
 (defun eql-iff-eq-p (thing env)
 …
     (if (not (self-evaluating-p thing))
         (return-from eql-iff-eq-p
+                     (nx-form-typep thing
+                                     '(or fixnum
+                                       #+64-bit-target single-float
+                                       character symbol
+                                       (and (not number) (not macptr))) env))))
+          (or (nx-form-typep thing  'symbol env)
+              (nx-form-typep thing 'character env)
+              (nx-form-typep thing
+                             '(or fixnum
+                               #+64-bit-target single-float
+                               symbol character
+                               (and (not number) (not macptr))) env)))))
   (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
+      (symbolp thing) (characterp thing)
       (and (not (numberp thing)) (not (macptrp thing)))))
+(defun equal-iff-eql-p (thing env)
+  (if (quoted-form-p thing)
+    (setq thing (%cadr thing))
+    (if (not (self-evaluating-p thing))
+      (return-from equal-iff-eql-p
+        (nx-form-typep thing
+                       '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
+  (not (typep thing '(or cons string bit-vector pathname))))
 (defun fold-constant-subforms (call env)
 …
 (define-compiler-macro assoc (&whole call &environment env item list &rest keys)
   (or (eq-eql-call item list keys 'assq 'asseql env)
+(define-compiler-macro assoc (&whole call item list &rest keys)
+  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test)
       call))
+(define-compiler-macro assequal (&whole call &environment env item list)
+  (if (or (equal-iff-eql-p item env)
+          (and (quoted-form-p list)
+               (proper-list-p (%cadr list))
+               (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
+    `(asseql ,item ,list)
+    call))
+(define-compiler-macro asseql (&whole call &environment env item list)
+  (if (or (eql-iff-eq-p item env)
+          (and (quoted-form-p list)
+               (proper-list-p (%cadr list))
+               (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
+    `(assq ,item ,list)
+    call))
+(define-compiler-macro assq (item list)
+  (let* ((itemx (gensym))
+         (listx (gensym))
+         (pair (gensym)))
+    `(let* ((,itemx ,item)
+            (,listx ,list))
+      (dolist (,pair ,listx)
+        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
 (define-compiler-macro caar (form)
 …
            (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
 (define-compiler-macro member (&whole call &environment env item list &rest keys)
   (or (eq-eql-call item list keys 'memq 'memeql env)
+(define-compiler-macro member (&whole call item list &rest keys)
+  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
       call))
+(define-compiler-macro memequal (&whole call &environment env item list)
+  (if (or (equal-iff-eql-p item env)
+          (and (quoted-form-p list)
+               (proper-list-p (%cadr list))
+               (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list))))
+    `(memeql ,item ,list)
+    call))
+(define-compiler-macro memeql (&whole call &environment env item list)
+  (if (or (eql-iff-eq-p item env)
+          (and (quoted-form-p list)
+               (proper-list-p (%cadr list))
+               (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
+    `(memq ,item ,list)
+    call))
 (define-compiler-macro memq (&whole call &environment env item list)
    ;(memq x '(y)) => (if (eq x 'y) '(y))
    ;Would it be worth making a two elt list into an OR?  Maybe if
    ;optimizing for speed...
+  ;;(memq x '(y)) => (if (eq x 'y) '(y))
+  ;;Would it be worth making a two elt list into an OR?  Maybe if
+  ;;optimizing for speed...
    (if (and (or (quoted-form-p list)
                 (null list))
             (null (cdr (%cadr list))))
      (if list `(if (eq ,item ',(%caadr list)) ,list))
+     call))
+     (let* ((x (gensym))
+            (tail (gensym)))
+       `(do* ((,x ,item)
+              (,tail ,list (cdr (the list ,tail))))
+         ((null ,tail))
+         (if (eq (car ,tail) ,x) (return ,tail))))))
 (define-compiler-macro minusp (x)
 …
             (%i< count 3))
      `(,(svref '#(car cadr caddr) count) ,list)
      call))
+     `(car (nthcdr ,count ,list))))
 (define-compiler-macro nthcdr (&whole call &environment env count list)
 …
            (%i< count 4))
      (if (%izerop count)
        list
+       `(require-type ,list 'list)
        `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
+     call))
+    (let* ((i (gensym))
+           (n (gensym))                 ; evaluation order
+           (tail (gensym)))
+      `(let* ((,n (require-type ,count 'unsigned-byte))
+              (,tail (require-type ,list 'list)))
+        (dotimes (,i ,n ,tail)
+          (unless (setq ,tail (cdr ,tail))
+            (return nil)))))))
 (define-compiler-macro plusp (x)
 …
       `(float ,thing 0.0d0)
       call)))
+(define-compiler-macro equal (&whole call x y &environment env)
+  (if (or (equal-iff-eql-p x env)
+          (equal-iff-eql-p y env))
+    `(eql ,x ,y)
+    call))
 (provide "OPTIMIZERS")

branches/working-0711/ccl/level-0/PPC/ppc-misc.lisp

-                      r7343
+                      r7624
   (blr))
+;;; Return true iff we were able to increment a non-negative
+;;; lock._value
+(defppclapfunction %try-read-lock-rwlock ((lock arg_z))
+  (check-nargs 1)
+  (li imm1 target::lock._value)
+  @try
+  (lrarx imm0 lock imm1)
+  (cmpri imm0 0)
+  (blt @fail)                           ; locked for writing
+  (addi imm0 imm0 '1)
+  (strcx. imm0 lock imm1)
+  (bne @try)                            ; lost reservation, try again
+  (isync)
+  (blr)                                 ; return the lock
+@fail
+  (li imm0 target::reservation-discharge)
+  (strcx. rzero rzero imm0)
+  (li arg_z nil)
+  (blr))
+(defppclapfunction unlock-rwlock ((lock arg_z))
+  (ldr imm2 target::lock._value lock)
+  (cmpri imm2 0)
+  (li imm1 target::lock._value)
+  (ble @unlock-write)
+  @unlock-read
+  (lrarx imm0 lock imm1)
+  (subi imm0 imm0 '1)
+  (strcx. imm0 lock imm1)
+  (bne @unlock-read)
+  (isync)
+  (blr)
+  @unlock-write
+  ;;; If we aren't the writer, return NIL.
+  ;;; If we are and the value's about to go to 0, clear the writer field.
+  (ldr imm0 target::lock.writer lock)
+  (cmpr imm0 target::rcontext)
+  (ldrx imm0 lock imm1)
+  (cmpri cr1 imm0 '-1)
+  (addi imm0 imm0 '1)
+  (bne @fail)
+  (bne cr1 @noclear)
+  (str rzero target::lock.writer lock)
+  @noclear
+  (str imm0 target::lock._value lock)
+  (blr)
+  @fail
+  (li arg_z nil)
+  (blr))
 (defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
 …
   (blr))
+(defppclapfunction %check-deferred-gc ()
+  (ldr imm0 target::tcr.flags target::rcontext)
+  (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)))
+  (li arg_z nil)
+  (bgelr)
+  (uuo_interr arch::error-propagate-suspend rzero)
+  (li arg_z t)
+  (blr))
 ; end of ppc-misc.lisp

branches/working-0711/ccl/level-0/X86/x86-array.lisp

-                      r6476
+                      r7624
+;; rewrite in LAP someday (soon).
+#+x8664-target
+(progn
+;;; None of the stores in here can be intergenerational; the vector
+;;; is known to be younger than the initial value
+(defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z))
+  (jmp @test)
+  @loop
+  (movq (% value) (@ x8664::misc-data-offset (% vector) (% len)))
+  @test
+  (subq ($ x8664::fixnumone) (% len))
+  (jns @loop)
+  (single-value-return))
+;;; "val" is either a fixnum or a uvector with 64-bits of data
+;;; (small bignum, DOUBLE-FLOAT).
+(defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z))
+  (unbox-fixnum value imm0)
+  (testb ($ x8664::fixnummask) (%b value))
+  (je @test)
+  (movq (@ x8664::misc-data-offset (% value)) (% imm0))
+  (jmp @test)
+  @loop
+  (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len)))
+  @test
+  (subq ($ x8664::fixnumone) (% len))
+  (jns @loop)
+  (single-value-return))
+(defun %init-ivector64 (typecode len val uvector)
+  (declare (type (mod 256) typecode))
+  (%%init-ivector64 len
+                    (case typecode
+                      (#.x8664::subtag-fixnum-vector
+                       (require-type val 'fixnum))
+                      (#.x8664::subtag-double-float-vector
+                       (if (typep val 'double-float)
+                         val
+                         (require-type val 'double-float)))
+                      (#.x8664::subtag-s64-vector
+                       (require-type val '(signed-byte 64)))
+                      (#.x8664::subtag-u64-vector
+                       (require-type val '(unsigned-byte 64)))
+                      (t (report-bad-arg uvector
+                                         '(or (simple-array fixnum (*))
+                                           (simple-array double-float (*))
+                                           (simple-array (signed-byte 64) (*))
+                                           (simple-array (unsigned-byte 64) (*))))))
+                    uvector))
+(eval-when (:compile-toplevel :execute)
+  (declaim (inline %init-ivector-u32)))
+(defun %init-ivector-u32 (len u32val uvector)
+  (declare (type index len)
+           (type (unsigned-byte 32) u32val)
+           (type (simple-array (unsigned-byte 32) (*)) uvector)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i len uvector)
+    (setf (aref uvector i) u32val)))
+(eval-when (:compile-toplevel :execute)
+  (declaim (inline %init-ivector-u16)))
+(defun %init-ivector-u16 (len val uvector)
+  (declare (type index len)
+           (type (unsigned-byte 16) val)
+           (type (simple-array (unsigned-byte 16) (*)) uvector)
+           (optimize (speed 3) (safety 0)))
+  (dotimes (i len uvector)
+    (setf (aref uvector i) val)))
+(defun %init-ivector32 (typecode len val uvector)
+  (declare (type (unsigned-byte 32) typecode)
+           (type index len))
+  (let* ((u32val (case typecode
+                   (#.x8664::subtag-s32-vector
+                    (logand (the (signed-byte 32)
+                              (require-type val '(signed-byte 32)))
+                            #xffffffff))
+                   (#.x8664::subtag-single-float-vector
+                    (single-float-bits (require-type val 'single-float)))
+                   (#.x8664::subtag-simple-base-string
+                    (char-code val))
+                   (t
+                    (require-type val '(unsigned-byte 32))))))
+    (declare (type (unsigned-byte 32) u32val))
+    (%init-ivector-u32 len u32val uvector)))
+(defun %init-misc (val uvector)
+  (let* ((len (uvsize uvector))
+         (typecode (typecode uvector))
+         (fulltag (logand x8664::fulltagmask typecode)))
+    (declare (type index len)
+             (type (unsigned-byte 8) typecode)
+             (type (mod 16) fulltag))
+    (if (or (= fulltag x8664::fulltag-nodeheader-0)
+            (= fulltag x8664::fulltag-nodeheader-1))
+      (%init-gvector len val uvector)
+      (if (= fulltag x8664::ivector-class-64-bit)
+        (%init-ivector64 typecode len val uvector)
+        (if (= fulltag x8664::ivector-class-32-bit)
+          (%init-ivector32 typecode len val uvector)
+          ;; Value must be a fixnum, 1, 8, 16 bits
+          (case typecode
+            (#.x8664::subtag-u16-vector
+             (%init-ivector-u16 len
+                                (require-type val '(unsigned-byte 16))
+                                uvector))
+            (#.x8664::subtag-s16-vector
+             (%init-ivector-u16 len
+                                (logand (the (signed-byte 16)
+                                          (require-type val '(unsigned-byte 16)))
+                                        #xffff)
+                                uvector))
+            (#.x8664::subtag-u8-vector
+             (let* ((v0 (require-type val '(unsigned-byte 8)))
+                    (l0 (ash (the fixnum (1+ len)) -1)))
+               (declare (type (unsigned-byte 8) v0)
+                        (type index l0))
+               (%init-ivector-u16 l0
+                                  (logior (the (unsigned-byte 16) (ash v0 8))
+                                          v0)
+                                  uvector)))
+            (#.x8664::subtag-s8-vector
+             (let* ((v0 (logand #xff
+                                (the (signed-byte 8)
+                                  (require-type val '(signed-byte 8)))))
+                    (l0 (ash (the fixnum (1+ len)) -1)))
+               (declare (type (unsigned-byte 8) v0)
+                        (type index l0))
+               (%init-ivector-u16 l0
+                                  (logior (the (unsigned-byte 16) (ash v0 8))
+                                          v0)
+                                  uvector)))
+            (#.x8664::subtag-bit-vector
+             (if (eql 0 val)
+               uvector
+               (let* ((v0 (case val
+                            (1 -1)
+                            (t (report-bad-arg val 'bit))))
+                      (l0 (ash (the fixnum (+ len 64)) -6)))
+                 (declare (type (unsigned-byte 8) v0)
+                          (type index l0))
+                 (%%init-ivector64  l0 v0 uvector))))
+            (t (report-bad-arg uvector
+                               '(or simple-bit-vector
+                                   (simple-array (signed-byte 8) (*))
+                                   (simple-array (unsigned-byte 8) (*))
+                                   (simple-array (signed-byte 16) (*))
+                                   (simple-array (unsigned-byte 16) (*)))))))))))
+)
+#-x8664-target
 (defun %init-misc (val uvector)
   (dotimes (i (uvsize uvector) uvector)
     (setf (uvref uvector i) val)))
 ;;; Make a new vector of size newsize whose subtag matches that of oldv-arg.

branches/working-0711/ccl/level-0/X86/x86-clos.lisp

r6477	r7624
35	35	(shrq ($ x8664::word-shift) (% imm1))
36	36	(movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
37		~~(shlq ($ x8664::word-shift) (% imm1))~~
38	37	@have-table-index
39	38	(movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))

branches/working-0711/ccl/level-0/X86/x86-misc.lisp

-                      r7343
+                      r7624
 ;;; Return true iff we were able to increment a non-negative
 ;;; lock._value
+(defx86lapfunction %try-read-lock-rwlock ((lock arg_z))
+  (check-nargs 1)
+  @try
+  (movq (@ x8664::lock._value (% lock)) (% rax))
+  (movq (% rax) (% imm1))
+  (addq ($ '1) (% imm1))
+  (jle @fail)
+  (lock)
+  (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
+  (jne @try)
+  (single-value-return)                                 ; return the lock
+@fail
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return))
+(defx86lapfunction unlock-rwlock ((lock arg_z))
+  (cmpq ($ 0) (@ x8664::lock._value (% lock)))
+  (jle @unlock-write)
+  @unlock-read
+  (movq (@ x8664::lock._value (% lock)) (% rax))
+  (lea (@ '-1 (% imm0)) (% imm1))
+  (lock)
+  (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
+  (jne @unlock-read)
+  (single-value-return)
+  @unlock-write
+  ;;; If we aren't the writer, return NIL.
+  ;;; If we are and the value's about to go to 0, clear the writer field.
+  (movq (@ x8664::lock.writer (% lock)) (% imm0))
+  (cmpq (% imm0) (@ (% :rcontext) x8664::tcr.linear))
+  (jne @fail)
+  (cmpq ($ '-1) (@ x8664::lock._value (% lock)))
+  (jne @still-owner)
+  (movsd (% fpzero) (@ x8664::lock.writer (% lock)))
+  @still-owner
+  (addq ($ '1) (@ x8664::lock._value (% lock)))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return))
 (defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
 …
     (movq (% imm0) (% arg_z))
     (single-value-return)))
+(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z))
+  (unbox-fixnum newval imm0)
+  (macptr-ptr ptr arg_y)                ; had better be aligned
+  (lock)                                ; implicit ?
+  (xchgl (% imm0.l) (@ (% arg_y)))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
 …
 ;;; it still called ?
+(defx86lapfunction %check-deferred-gc ()
+  (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (@ (% :rcontext) x8664::tcr.flags))
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (jae @done)
+  (ud2a)
+  (:byte 3)
+  (movl ($ x8664::t-value) (% arg_z.l))
+  @done
+  (single-value-return))
+(defx86lapfunction %get-spin-lock ((p arg_z))
+  (check-nargs 1)
+  (save-simple-frame)
+  @again
+  (macptr-ptr arg_z imm1)
+  (movq (@ '*spin-lock-tries* (% fn)) (% temp0))
+  (movq (@ target::symbol.vcell (% temp0)) (% temp0))
+  (movq (@ (% :rcontext) x8664::tcr.linear) (% arg_y))
+  @try-swap
+  (xorq (% rax) (% rax))
+  (lock)
+  (cmpxchgq (% arg_y) (@ (% imm1)))
+  (je @done)
+  (pause)
+  (subq ($ '1) (% temp0))
+  (jne @try-swap)
+  (pushq (% arg_z))
+  (call-symbol yield 0)
+  (popq (% arg_z))
+  (jmp @again)
+  @done
+  (restore-simple-frame)
+  (single-value-return))
 ;;; end of x86-misc.lisp

branches/working-0711/ccl/level-0/X86/x86-utils.lisp

-                      r6483
+                      r7624
   (single-value-return))
+(defx86lapfunction freeze ()
+  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
+  (movq ($ arch::gc-trap-function-freeze) (% imm0))
+  (uuo-gc-trap)
+  (jmp-subprim .SPmakeu64))

branches/working-0711/ccl/level-0/l0-aprims.lisp

-                      r7451
+                      r7624
 ;;; This weak list is used to track semaphores as well as locks.
 (defvar %system-locks% nil)
+(setf %system-locks% (%cons-population nil))
 (defun record-system-lock (l)
 …
         (when nul-terminated
           (setf (%get-byte pointer n) 0)))
       nil)
     (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)))
+      nil))
+  (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
 (defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
 …
              :address))))
+(defun %make-rwlock-ptr ()
+  (record-system-lock
+   (%setf-macptr
+    (make-gcable-macptr $flags_DisposeRwLock)
+    (ff-call (%kernel-import target::kernel-import-rwlock-new)
+             :address))))
 (defun make-recursive-lock ()
 …
     (report-bad-arg r 'recursive-lock)))
+(defun read-write-lock-ptr (rw)
+  (if (and (eq target::subtag-lock (typecode rw))
+           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
+    (%svref rw target::lock._value-cell)
+    (report-bad-arg rw 'read-write-lock)))
 (defun make-read-write-lock ()
   "Create and return a read-write lock, which can be used for
 synchronization between threads."
   (gvector :lock 0 'read-write-lock 0 nil))
+  (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil))

branches/working-0711/ccl/level-0/l0-bignum64.lisp

-                      r5837
+                      r7624
+(defun %bignum-random (number state)
+  (let* ((ndigits (%bignum-length number))
+         (sign-index (1- ndigits)))
+    (declare (fixnum ndigits sign-index))
+    (with-bignum-buffers ((bignum ndigits))
+      (dotimes (i sign-index)
+        (setf (bignum-ref bignum i) (%next-random-seed state)))
+      (setf (bignum-ref bignum sign-index)
+            (logand #x7fffffff (the (unsigned-byte 32)
+                                 (%next-random-seed state))))
+      (let* ((result (mod bignum number)))
+        (if (eq result bignum)
+          (copy-uvector bignum)
+          result)))))
 (defun logbitp (index integer)
   "Predicate returns T if bit index of integer is a 1."

branches/working-0711/ccl/level-0/l0-hash.lisp

-                      r6918
+                      r7624
    find                                 ; nhash.find
    find-new                             ; nhash.find-new
+   nil                                  ; hhash.read-only
    ))
 …
+(defvar *continue-from-readonly-hashtable-lock-error* nil)
+(defun signal-read-only-hash-table-error (hash write-p)
+  (cond (*continue-from-readonly-hashtable-lock-error*
+         (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
+                 "Hash-table ~s is readonly" hash)
+         (assert-hash-table-writeable hash)
+         (lock-hash-table hash write-p))
+        (t (error "Hash-table ~s is readonly" hash))))
+(defun lock-hash-table (hash write-p)
+  (if (nhash.read-only hash)
+    (if write-p
+        (signal-read-only-hash-table-error hash write-p)
+      :readonly)
+    (let* ((lock (nhash.exclusion-lock hash)))
+      (if lock
+        (write-lock-rwlock lock)
+        (progn (unless (eq (nhash.owner hash) *current-process*)
+                 (error "Not owner of hash table ~s" hash)))))))
+(defun lock-hash-table-for-map (hash)
+  (if (nhash.read-only hash)
+    :readonly
+    (let* ((lock (nhash.exclusion-lock hash)))
+      (if lock
+        (write-lock-rwlock lock)
+        (progn (unless (eq (nhash.owner hash) *current-process*)
+                 (error "Not owner of hash table ~s" hash)))))))
+(defun unlock-hash-table (hash was-readonly)
+  (unless was-readonly
+    (let* ((lock (nhash.exclusion-lock hash)))
+      (if lock
+        (unlock-rwlock lock)))))
 …
     (report-bad-arg hash 'hash-table))
   (without-interrupts
    (lock-hash-table hash)
+   (lock-hash-table hash t)
    (let* ((vector (nhash.vector hash))
           (size (nhash.vector-size vector))
 …
            (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
                                                (nhash.vector.flags vector))))
    (unlock-hash-table hash)
+   (unlock-hash-table hash nil)
    hash))
 …
-(defun lock-hash-table (hash)
-  (let* ((lock (nhash.exclusion-lock hash)))
-    (if lock
-      (write-lock-rwlock lock)
-      (progn (unless (eq (nhash.owner hash) *current-process*)
-               (error "Not owner of hash table ~s" hash))))))
-(defun unlock-hash-table (hash)
-  (let* ((lock (nhash.exclusion-lock hash)))
-    (if lock
-      (unlock-rwlock lock))))
 (defun gethash (key hash &optional default)
 …
          (vector-key nil)
          (gc-locked nil)
+         (readonly nil)
          (foundp nil))
     (without-interrupts
      (lock-hash-table hash)
+     (setq readonly (eq (lock-hash-table hash nil) :readonly))
      (let* ((vector (nhash.vector hash)))
        (if (and (eq key (nhash.vector.cache-key vector))
 …
              (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
                                       (not (eq vector-key deleted-hash-key-marker))))
+                    #+no
                     (setf (nhash.vector.cache-key vector) vector-key
                           (nhash.vector.cache-value vector) value
 …
                (t (return)))))))
      (when gc-locked (%unlock-gc-lock))
      (unlock-hash-table hash))
+     (unlock-hash-table hash readonly))
     (if foundp
       (values value t)
 …
   (let* ((foundp nil))
     (without-interrupts
      (lock-hash-table hash)
+     (lock-hash-table hash t)
      (%lock-gc-lock)
      (when (%needs-rehashing-p hash)
 …
              (unless (= (the fixnum (hti.index iterator))
                         (the fixnum (nhash.vector.cache-idx vector)))
                (unlock-hash-table hash)
+               (unlock-hash-table hash nil)
                (%unlock-gc-lock)
                (error "Can't remove key ~s during iteration on hash-table ~s"
 …
                (unless (= (the fixnum (hti.index iterator))
                           (the fixnum (vector-index->index vector-index)))
                  (unlock-hash-table hash)
+                 (unlock-hash-table hash nil)
                  (%unlock-gc-lock)
                  (error "Can't remove key ~s during iteration on hash-table ~s"
 …
      ;; Return T if we deleted something
      (%unlock-gc-lock)
      (unlock-hash-table hash))
+     (unlock-hash-table hash nil))
     foundp))
 …
    (block protected
      (tagbody
         (lock-hash-table hash)
+        (lock-hash-table hash t)
         AGAIN
         (%lock-gc-lock)
 …
             (when (and (< index (the fixnum (uvsize vector)))
                        (not (funcall test (%svref vector index) key)))
               (unlock-hash-table hash)
+              (unlock-hash-table hash nil)
               (%unlock-gc-lock)
               (error "Can't add key ~s during iteration on hash-table ~s"
 …
                   (nhash.vector.cache-value vector) value)))))
    (%unlock-gc-lock)
    (unlock-hash-table hash))
+   (unlock-hash-table hash nil))
   value)
 …
     vector))
+(defun assert-hash-table-readonly (hash)
+  (unless (hash-table-p hash)
+    (report-bad-arg hash 'hash-table))
+  (or (nhash.read-only hash)
+      (without-interrupts
+       (lock-hash-table hash t)
+       (let* ((flags (nhash.vector.flags (nhash.vector hash))))
+         (declare (fixnum flags))
+         (when (or (logbitp $nhash_track_keys_bit flags)
+                   (logbitp $nhash_component_address_bit flags))
+           (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
+           (unlock-hash-table hash nil)
+           (return-from assert-hash-table-readonly nil))
+         (setf (nhash.read-only hash) t)
+         (unlock-hash-table hash nil)
+         t))))
+;; This is dangerous, if multiple threads are accessing a read-only
+;; hash table. Use it responsibly.
+(defun assert-hash-table-writeable (hash)
+  (unless (hash-table-p hash)
+    (report-bad-arg hash 'hash-table))
+  (when (nhash.read-only hash)
+    (setf (nhash.read-only hash) nil)
+    t))
+(defun readonly-hash-table-p (hash)
+  (unless (hash-table-p hash)
+    (report-bad-arg hash 'hash-table))
+  (nhash.read-only hash))

branches/working-0711/ccl/level-0/l0-io.lisp

-                      r6181
+                      r7624
+; write nbytes bytes from buffer buf to file-descriptor fd.
+(defun utf-8-octets-in-string (string start end)
+  (if (>= end start)
+    (do* ((noctets 0)
+          (i start (1+ i)))
+         ((= i end) noctets)
+      (declare (fixnum noctets))
+      (let* ((code (char-code (schar string i))))
+        (declare (type (mod #x110000) code))
+        (incf noctets
+              (if (< code #x80)
+                (if (< code #x800)
+                  (if (< code #x10000)
+))))))
+))
+(defun utf-8-memory-encode (string pointer idx start end)
+  (declare (fixnum idx))
+  (do* ((i start (1+ i)))
+       ((>= i end) idx)
+    (let* ((code (char-code (schar string i))))
+      (declare (type (mod #x110000) code))
+      (cond ((< code #x80)
+             (setf (%get-unsigned-byte pointer idx) code)
+             (incf idx))
+            ((< code #x800)
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xc0 (the fixnum (ash code -6))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand code #x3f))))
+             (incf idx 2))
+            ((< code #x10000)
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xe0 (the fixnum (ash code -12))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                   (logior #x80 (the fixnum (logand code #x3f))))
+             (incf idx 3))
+            (t
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xf0
+                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
+                   (logand #x3f code))
+             (incf idx 4))))))
+(defun utf-8-memory-decode (pointer noctets idx string)
+  (declare (fixnum noctets idx))
+  (do* ((i 0 (1+ i))
+        (end (+ idx noctets))
+        (index idx (1+ index)))
+       ((>= index end) (if (= index end) index 0))
+    (let* ((1st-unit (%get-unsigned-byte pointer index)))
+      (declare (type (unsigned-byte 8) 1st-unit))
+      (let* ((char (if (< 1st-unit #x80)
+                     (code-char 1st-unit)
+                     (if (>= 1st-unit #xc2)
+                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
+                         (declare (type (unsigned-byte 8) 2nd-unit))
+                         (if (< 1st-unit #xe0)
+                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                             (code-char
+                              (logior
+                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
+                               (the fixnum (logxor 2nd-unit #x80)))))
+                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
+                             (declare (type (unsigned-byte 8) 3rd-unit))
+                             (if (< 1st-unit #xf0)
+                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                        (or (>= 1st-unit #xe1)
+                                            (>= 2nd-unit #xa0)))
+                                 (code-char (the fixnum
+                                              (logior (the fixnum
+                                                        (ash (the fixnum (logand 1st-unit #xf))
+))
+                                                      (the fixnum
+                                                        (logior
+                                                         (the fixnum
+                                                           (ash (the fixnum (logand 2nd-unit #x3f))
+))
+                                                         (the fixnum (logand 3rd-unit #x3f))))))))
+                               (if (< 1st-unit #xf8)
+                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
+                                   (declare (type (unsigned-byte 8) 4th-unit))
+                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
+                                            (or (>= 1st-unit #xf1)
+                                                (>= 2nd-unit #x90)))
+                                     (code-char
+                                      (logior
+                                       (the fixnum
+                                         (logior
+                                          (the fixnum
+                                            (ash (the fixnum (logand 1st-unit 7)) 18))
+                                          (the fixnum
+                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
+                                       (the fixnum
+                                         (logior
+                                          (the fixnum
+                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
+                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
+        (setf (schar string i) (or char #\Replacement_Character))))))
+(defun utf-8-length-of-memory-encoding (pointer noctets start)
+  (do* ((i start)
+        (end (+ start noctets))
+        (nchars 0 (1+ nchars)))
+       ((= i end) (values nchars i))
+    (let* ((code (%get-unsigned-byte pointer i))
+           (nexti (+ i (cond ((< code #x80) 1)
+                             ((< code #xe0) 2)
+                             ((< code #xf0) 3)
+                             (t 4)))))
+      (declare (type (unsigned-byte 8) code))
+      (if (> nexti end)
+        (return (values nchars i))
+        (setq i nexti)))))
+;;; write nbytes bytes from buffer buf to file-descriptor fd.
 (defun fd-write (fd buf nbytes)
   (syscall syscalls::write fd buf nbytes))
 …
 (defun fd-open (path flags &optional (create-mode #o666))
+  (with-cstrs ((p path))
+    (syscall syscalls::open p flags create-mode)))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
+    (let* ((fd (syscall syscalls::open p flags create-mode)))
+      (declare (fixnum fd))
+      (when (or (= fd (- #$EMFILE))
+                (= fd (- #$EMFILE)))
+        (gc)
+        (drain-termination-queue)
+        (setq fd (syscall syscalls::open p flags create-mode)))
+      fd)))
 (defun fd-chmod (fd mode)

branches/working-0711/ccl/level-0/l0-misc.lisp

-                      r6917
+                      r7624
 (in-package "CCL")
+;;; Bootstrapping for futexes
+#+(and linuxx8664-target)
+(eval-when (:compile-toplevel :execute)
+  (pushnew :futex *features*))
+#+futex
+(eval-when (:compile-toplevel :execute)
+  ;; We only need a few constants from <linux/futex.h>, which may
+  ;; not have been included in the :libc .cdb files.
+  (defconstant FUTEX-WAIT 0)
+  (defconstant FUTEX-WAKE 1)
+  (defconstant futex-avail 0)
+  (defconstant futex-locked 1)
+  (defconstant futex-contended 2)
+  (require "X8664-LINUX-SYSCALLS")
+  (declaim (inline %lock-futex %unlock-futex)))
 ; Miscellany.
 …
   t)
+(defun frozen-space-dnodes ()
+  "Returns the current size of the frozen area."
+  (%fixnum-ref-natural (%get-kernel-global 'tenured-area)
+                       target::area.static-dnodes))
 (defun %usedbytes ()
   (%normalize-areas)
 …
                 (incf library bytes)
                 (incf static bytes))))))
       (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))
         (decf dynamic hons-size)
         (values dynamic static library hons-size))))
+      (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift)))
+        (decf dynamic frozen-size)
+        (values dynamic static library frozen-size))))
 …
 ; Returns six values.
 ;   sp free
 ;   sp used
 ;   vsp free
 ;   vsp used
 ;   tsp free
 ;   tsp used
+;;; Returns six values.
+;;;   sp free
+;;;   sp used
+;;;   vsp free
+;;;   vsp used
+;;;   tsp free
+;;;   tsp used
 (defun %thread-stack-space (&optional (thread *current-lisp-thread*))
   (when (eq thread *current-lisp-thread*)
 …
          (static-used nil)
          (staticlib-used nil)
          (hons-space-size nil)
+         (frozen-space-size nil)
          (lispheap nil)
          (reserved nil)
 …
          (stack-free)
          (stack-used-by-thread nil))
     (with-other-threads-suspended
         (without-gcing
          (setq freebytes (%freebytes))
          (when verbose
            (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
              (%usedbytes))
            (setq lispheap (+ freebytes usedbytes)
                  reserved (%reservedbytes)
                  static (+ static-used staticlib-used hons-space-size))
            (multiple-value-setq (stack-total stack-used stack-free)
              (%stack-space))
            (unless (eq verbose :default)
              (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
+    (progn
+      (progn
+        (setq freebytes (%freebytes))
+        (when verbose
+          (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size)
+            (%usedbytes))
+          (setq lispheap (+ freebytes usedbytes)
+                reserved (%reservedbytes)
+                static (+ static-used staticlib-used frozen-space-size))
+          (multiple-value-setq (stack-total stack-used stack-free)
+            (%stack-space))
+          (unless (eq verbose :default)
+            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
     (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
     (when verbose
 …
 0
                 static (k static))
         (when (and hons-space-size (not (zerop hons-space-size)))
           (format t "~&~,3f MB of static memory reserved for hash consing."
                   (/ hons-space-size (float (ash 1 20)))))
+        (when (and frozen-space-size (not (zerop frozen-space-size)))
+          (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory"
+                  (/ frozen-space-size (float (ash 1 20)))))
         (format t "~&~,3f MB reserved for heap expansion."
                 (/ reserved (float (ash 1 20))))
 …
     (declare (fixnum end))))
+(defun %get-utf-8-cstring (pointer)
+  (do* ((end 0 (1+ end)))
+       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
+        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
+               (string (make-string len)))
+          (utf-8-memory-decode pointer end 0 string)
+          string))
+    (declare (fixnum end))))
 ;;; This is mostly here so we can bootstrap shared libs without
 ;;; having to bootstrap #_strcmp.
 …
 (defparameter *spin-lock-tries* 1)
+(defparameter *spin-lock-timeouts* 0)
+#+(and (not futex) (not x86-target))
 (defun %get-spin-lock (p)
   (let* ((self (%current-tcr))
 …
         (when (eql 0 (%ptr-store-fixnum-conditional p 0 self))
           (return-from %get-spin-lock t)))
+      (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell)
       (yield))))
+#-futex
 (defun %lock-recursive-lock (lock &optional flag)
   (with-macptrs ((p)
 …
       (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock"))))
+#+futex
+(defun futex-wait (p val)
+  (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0))
+#+futex
+(defun futex-wake (p n)
+  (syscall syscalls::futex p FUTEX-WAKE n (%null-ptr) (%null-ptr) 0))
+#+futex
+(defun %lock-futex (p wait-level)
+  (let* ((val (%ptr-store-conditional p futex-avail futex-locked)))
+    (declare (fixnum val))
+    (or (eql val futex-avail)
+        (loop
+          (if (eql val futex-contended)
+            (let* ((*interrupt-level* wait-level))
+              (futex-wait p val))
+            (setq val futex-contended))
+          (when (eql futex-avail (xchgl val p))
+            (return t))))))
+#+futex
+(defun %unlock-futex (p)
+  (unless (eql futex-avail (%atomic-decf-ptr p))
+    (setf (%get-natural p target::lockptr.avail) futex-avail)
+    (futex-wake p #$INT_MAX)))
+#+futex
+(defun %lock-recursive-lock (lock &optional flag)
+  (if (istruct-typep flag 'lock-acquisition)
+    (setf (lock-acquisition.status flag) nil)
+    (if flag (report-bad-arg flag 'lock-acquisition)))
+  (let* ((self (%current-tcr))
+         (level *interrupt-level*))
+    (declare (fixnum self val))
+    (without-interrupts
+     (cond ((eql self (%get-object lock target::lockptr.owner))
+            (incf (%get-natural lock target::lockptr.count)))
+           (t (%lock-futex lock level)
+              (%set-object lock target::lockptr.owner self)
+              (setf (%get-natural lock target::lockptr.count) 1)))
+     (when flag
+       (setf (lock-acquisition.status flag) t))
+     t)))
 ;;; Locking the exception lock to inhibit GC (from other threads)
 …
     (%unlock-recursive-lock lock)))
+#-futex
 (defun %try-recursive-lock (lock &optional flag)
   (with-macptrs ((p)
 …
               win))))))
+#+futex
+(defun %try-recursive-lock (lock &optional flag)
+  (let* ((self (%current-tcr)))
+    (declare (fixnum self))
+    (if flag
+      (if (istruct-typep flag 'lock-acquisition)
+        (setf (lock-acquisition.status flag) nil)
+        (report-bad-arg flag 'lock-acquisition)))
+    (without-interrupts
+     (cond ((eql (%get-object lock target::lockptr.owner) self)
+            (incf (%get-natural lock target::lockptr.count))
+            (if flag (setf (lock-acquisition.status flag) t))
+            t)
+           (t
+            (when (eql 0 (%ptr-store-conditional lock futex-avail futex-locked))
+              (%set-object lock target::lockptr.owner self)
+              (setf (%get-natural lock target::lockptr.count) 1)
+              (if flag (setf (lock-acquisition.status flag) t))
+              t))))))
+#-futex
 (defun %unlock-recursive-lock (lock)
   (with-macptrs ((signal (%get-ptr lock target::lockptr.signal))
 …
     nil)
+#+futex
+(defun %unlock-recursive-lock (lock)
+  (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr))
+    (error 'not-lock-owner :lock lock))
+  (without-interrupts
+   (when (eql 0 (decf (the fixnum
+                        (%get-natural lock target::lockptr.count))))
+     (setf (%get-natural lock target::lockptr.owner) 0)
+     (%unlock-futex lock)))
+    nil)
 (defun %%lock-owner (lock)
 …
           (return cell))))))
+(defun atomic-pop-uvector-cell (v i)
+  (let* ((offset (+ target::misc-data-offset (ash i target::word-shift))))
+    (loop
+      (let* ((old (%svref v i)))
+        (if (null old)
+          (return (values nil nil))
+          (let* ((tail (cdr old)))
+            (when (%store-node-conditional offset v old tail)
+              (return (values (car old) t)))))))))
 (defun store-gvector-conditional (index gvector old new)
   (%store-node-conditional (+ target::misc-data-offset
 …
 (defun %atomic-incf-symbol-value (s &optional (by 1))
   (setq s (require-type s 'symbol))
+  (let* ((binding-address (%symbol-binding-address s)))
+    (declare (fixnum binding-address))
+    (if (zerop binding-address)
+      (%atomic-incf-node by s target::symbol.vcell-cell)
+      (%atomic-incf-node by binding-address (* 2 target::node-size)))))
+(defun write-lock-rwlock (lock)
+  (let* ((context (%current-tcr)))
+    (if (eq (%svref lock target::lock.writer-cell) context)
+      (progn
+        (decf (%svref lock target::lock._value-cell))
+        lock)
+      (loop
+        (when (%store-immediate-conditional target::lock._value lock 0 -1)
+          (setf (%svref lock target::lock.writer-cell) context)
+          (return lock))
+        (%nanosleep 0 *ns-per-tick*)))))
+(defun read-lock-rwlock (lock)
+  (loop
+    (when (%try-read-lock-rwlock lock)
+      (return lock))
+    (%nanosleep 0 *ns-per-tick*)))
+  (multiple-value-bind (base offset) (%symbol-binding-address s)
+    (%atomic-incf-node by base offset)))
+;;; What happens if there are some pending readers and another writer,
+;;; and we abort out of the semaphore wait ?  If the writer semaphore is
+;;; signaled before we abandon interest in it
+#-futex
+(defun %write-lock-rwlock-ptr (ptr &optional flag)
+  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (incf (%get-signed-natural ptr target::rwlock.state))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (if flag
+             (setf (lock-acquisition.status flag) t))
+           t)
+         (do* ()
+              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state) 1
+                     (%get-natural ptr target::rwlock.spin) 0)
+               (%set-object ptr target::rwlock.writer tcr)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (incf (%get-natural ptr target::rwlock.blocked-writers))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (let* ((*interrupt-level* level))
+                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
+           (%get-spin-lock ptr)))))))
+#+futex
+(defun %write-lock-rwlock-ptr (ptr &optional flag)
+  (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) )
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%lock-futex ptr level)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (incf (%get-signed-natural ptr target::rwlock.state))
+           (%unlock-futex ptr)
+           (if flag
+             (setf (lock-acquisition.status flag) t))
+           t)
+         (do* ()
+              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state) 1)
+               (%unlock-futex ptr)
+               (%set-object ptr target::rwlock.writer tcr)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (incf (%get-natural ptr target::rwlock.blocked-writers))
+           (let* ((waitval (%get-natural write-signal 0)))
+             (%unlock-futex ptr)
+             (let* ((*interrupt-level* level))
+               (futex-wait write-signal waitval)))
+           (%lock-futex ptr level)
+           (decf (%get-natural ptr target::rwlock.blocked-writers))))))))
+(defun write-lock-rwlock (lock &optional flag)
+  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
+#-futex
+(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
+  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (error 'deadlock :lock lock))
+         (do* ((state
+                (%get-signed-natural ptr target::rwlock.state)
+                (%get-signed-natural ptr target::rwlock.state)))
+              ((<= state 0)
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state)
+                     (the fixnum (1- state))
+                     (%get-natural ptr target::rwlock.spin) 0)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (declare (fixnum state))
+           (incf (%get-natural ptr target::rwlock.blocked-readers))
+           (setf (%get-natural ptr target::rwlock.spin) 0)
+           (let* ((*interrupt-level* level))
+             (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
+           (%get-spin-lock ptr)))))))
+#+futex
+(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
+  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)))
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (declare (fixnum tcr))
+      (without-interrupts
+       (%lock-futex ptr level)
+       (if (eq (%get-object ptr target::rwlock.writer) tcr)
+         (progn
+           (%unlock-futex ptr)
+           (error 'deadlock :lock lock))
+         (do* ((state
+                (%get-signed-natural ptr target::rwlock.state)
+                (%get-signed-natural ptr target::rwlock.state)))
+              ((<= state 0)
+               ;; That wasn't so bad, was it ?  We have the spinlock now.
+               (setf (%get-signed-natural ptr target::rwlock.state)
+                     (the fixnum (1- state)))
+               (%unlock-futex ptr)
+               (if flag
+                 (setf (lock-acquisition.status flag) t))
+               t)
+           (declare (fixnum state))
+           (incf (%get-natural ptr target::rwlock.blocked-readers))
+           (let* ((waitval (%get-natural reader-signal 0)))
+             (%unlock-futex ptr)
+             (let* ((*interrupt-level* level))
+               (futex-wait reader-signal waitval)))
+           (%lock-futex ptr level)
+           (decf (%get-natural ptr target::rwlock.blocked-readers))))))))
+(defun read-lock-rwlock (lock &optional flag)
+  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
+;;; If the current thread already owns the lock for writing, increment
+;;; the lock's state.  Otherwise, try to lock the lock for reading.
+(defun %ensure-at-least-read-locked (lock &optional flag)
+  (if (istruct-typep flag 'lock-acquisition)
+    (setf (lock-acquisition.status flag) nil)
+    (if flag (report-bad-arg flag 'lock-acquisition)))
+  (let* ((ptr (read-write-lock-ptr lock))
+         (tcr (%current-tcr))
+         #+futex (level *interrupt-level*))
+    (declare (fixnum tcr))
+    (or
+     (without-interrupts
+      #+futex
+      (%lock-futex ptr level)
+      #-futex
+      (%get-spin-lock ptr)
+      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
+        (declare (fixnum state))
+        (let ((win
+               (cond ((<= state 0)
+                      (setf (%get-signed-natural ptr target::rwlock.state)
+                            (the fixnum (1- state)))
+                      t)
+                     ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
+                      (setf (%get-signed-natural ptr target::rwlock.state)
+                            (the fixnum (1+ state)))
+                      t))))
+          #+futex
+          (%unlock-futex ptr)
+          #-futex
+          (setf (%get-natural ptr target::rwlock.spin) 0)
+          (when win
+            (if flag
+              (setf (lock-acquisition.status flag) t))
+            t))))
+       (%read-lock-rwlock-ptr ptr lock flag))))
+#-futex
+(defun %unlock-rwlock-ptr (ptr lock)
+  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
+                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
+    (without-interrupts
+     (%get-spin-lock ptr)
+     (let* ((state (%get-signed-natural ptr target::rwlock.state))
+            (tcr (%current-tcr)))
+       (declare (fixnum state tcr))
+       (cond ((> state 0)
+              (unless (eql tcr (%get-object ptr target::rwlock.writer))
+                (setf (%get-natural ptr target::rwlock.spin) 0)
+                (error 'not-lock-owner :lock lock))
+              (decf state))
+             ((< state 0) (incf state))
+             (t (setf (%get-natural ptr target::rwlock.spin) 0)
+                (error 'not-locked :lock lock)))
+       (setf (%get-signed-natural ptr target::rwlock.state) state)
+       (when (zerop state)
+         ;; We want any thread waiting for a lock semaphore to
+         ;; be able to wait interruptibly.  When a thread waits,
+         ;; it increments either the "blocked-readers" or "blocked-writers"
+         ;; field, but since it may get interrupted before obtaining
+         ;; the semaphore that's more of "an expression of interest"
+         ;; in taking the lock than it is "a firm commitment to take it."
+         ;; It's generally (much) better to signal the semaphore(s)
+         ;; too often than it would be to not signal them often
+         ;; enough; spurious wakeups are better than deadlock.
+         ;; So: if there are blocked writers, the writer-signal
+         ;; is raised once for each apparent blocked writer.  (At most
+         ;; one writer will actually succeed in taking the lock.)
+         ;; If there are blocked readers, the reader-signal is raised
+         ;; once for each of them.  (It's possible for both the
+         ;; reader and writer semaphores to be raised on the same
+         ;; unlock; the writer semaphore is raised first, so in that
+         ;; sense, writers still have priority but it's not guaranteed.)
+         ;; Both the "blocked-writers" and "blocked-readers" fields
+         ;; are cleared here (they can't be changed from another thread
+         ;; until this thread releases the spinlock.)
+         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
+         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
+                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
+           (declare (fixnum nreaders nwriters))
+           (when (> nwriters 0)
+             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
+             (dotimes (i nwriters)
+               (%signal-semaphore-ptr writer-signal)))
+           (when (> nreaders 0)
+             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
+             (dotimes (i nreaders)
+               (%signal-semaphore-ptr reader-signal)))))
+       (setf (%get-natural ptr target::rwlock.spin) 0)
+       t))))
+#+futex
+(defun %unlock-rwlock-ptr (ptr lock)
+  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))
+                 (writer-signal (%INC-ptr ptr target::rwlock.writer-signal)))
+    (let* ((signal nil)
+           (wakeup 0))
+    (without-interrupts
+     (%lock-futex ptr -1)
+     (let* ((state (%get-signed-natural ptr target::rwlock.state))
+            (tcr (%current-tcr)))
+       (declare (fixnum state tcr))
+       (cond ((> state 0)
+              (unless (eql tcr (%get-object ptr target::rwlock.writer))
+                (%unlock-futex ptr)
+                (error 'not-lock-owner :lock lock))
+              (decf state))
+             ((< state 0) (incf state))
+             (t (%unlock-futex ptr)
+                (error 'not-locked :lock lock)))
+       (setf (%get-signed-natural ptr target::rwlock.state) state)
+       (when (zerop state)
+         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
+         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
+                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
+           (declare (fixnum nreaders nwriters))
+           (if (> nwriters 0)
+             (setq signal writer-signal wakeup 1)
+             (if (> nreaders 0)
+               (setq signal reader-signal wakeup #$INT_MAX)))))
+       (when signal (incf (%get-signed-natural signal 0)))
+       (%unlock-futex ptr)
+       (when signal (futex-wake signal wakeup))
+       t)))))
+(defun unlock-rwlock (lock)
+  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
+;;; There are all kinds of ways to lose here.
+;;; The caller must have read access to the lock exactly once,
+;;; or have write access.
+;;; there's currently no way to detect whether the caller has
+;;; read access at all.
+;;; If we have to block and get interrupted, cleanup code may
+;;; try to unlock a lock that we don't hold. (It might be possible
+;;; to circumvent that if we use the same notifcation object here
+;;; that controls that cleanup process.)
+(defun %promote-rwlock (lock &optional flag)
+  (let* ((ptr (read-write-lock-ptr lock)))
+    (if (istruct-typep flag 'lock-acquisition)
+      (setf (lock-acquisition.status flag) nil)
+      (if flag (report-bad-arg flag 'lock-acquisition)))
+    (let* ((level *interrupt-level*)
+           (tcr (%current-tcr)))
+      (without-interrupts
+       #+futex
+       (%lock-futex ptr level)
+       #-futex
+       (%get-spin-lock ptr)
+       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
+         (declare (fixnum state))
+         (cond ((> state 0)
+                (unless (eql (%get-object ptr target::rwlock.writer) tcr)
+                  #+futex
+                  (%unlock-futex ptr)
+                  #-futex
+                  (setf (%get-natural ptr target::rwlock.spin) 0)
+                  (error :not-lock-owner :lock lock)))
+               ((= state 0)
+                #+futex (%unlock-futex ptr)
+                #-futex (setf (%get-natural ptr target::rwlock.spin) 0)
+                (error :not-locked :lock lock))
+               (t
+                (if (= state -1)
+                  (progn
+                    (setf (%get-signed-natural ptr target::rwlock.state) 1)
+                    (%set-object ptr target::rwlock.writer tcr)
+                    #+futex
+                    (%unlock-futex ptr)
+                    #-futex
+                    (setf (%get-natural ptr target::rwlock.spin) 0)
+                    (if flag
+                      (setf (lock-acquisition.status flag) t))
+                    t)
+                  (progn
+                    (%unlock-rwlock-ptr ptr lock)
+                    (let* ((*interrupt-level* level))
+                      (%write-lock-rwlock-ptr ptr flag)))))))))))
 (defun safe-get-ptr (p &optional dest)

branches/working-0711/ccl/level-0/l0-numbers.lisp

-                      r7354
+                      r7624
+#+32-bit-target
 (defun random (number &optional (state *random-state*))
   (if (not (typep state 'random-state)) (report-bad-arg state 'random-state))
 …
         (if (< number 65536)
           (fast-mod (%next-random-seed state) number)
+          (%bignum-random number state))))
+          (let* ((n 0)
+                 (nhalf (ash (+ 15 (integer-length number)) -4)))
+            (declare (fixnum n nhalf))
+            (dotimes (i nhalf (fast-mod n number))
+              (setq n (logior (the fixnum (ash n 16))
+                              (the fixnum (%next-random-seed state)))))))))
      ((and (typep number 'double-float) (> (the double-float number) 0.0))
       (%float-random number state))
 …
      (t (report-bad-arg number '(or (integer (0)) (float (0.0)))))))
+#+64-bit-target
+(defun random (number &optional (state *random-state*))
+  (if (not (typep state 'random-state)) (report-bad-arg state 'random-state))
+  (cond
+    ((and (fixnump number) (> (the fixnum number) 0))
+     (locally (declare (fixnum number))
+       (let* ((n 0)
+              (n32 (ash (+ 31 (integer-length number)) -5)))
+         (declare (fixnum n n32))
+         (dotimes (i n32 (fast-mod n number))
+           (setq n (logior (the fixnum (ash n 32))
+                           (the fixnum (%next-random-seed state))))))))
+    ((and (typep number 'double-float) (> (the double-float number) 0.0))
+     (%float-random number state))
+    ((and (typep number 'short-float) (> (the short-float number) 0.0s0))
+     (%float-random number state))
+    ((and (bignump number) (> number 0))
+     (%bignum-random number state))
+    (t (report-bad-arg number '(or (integer (0)) (float (0.0)))))))
 #|
 …
 #+64-bit-target
+(defun %next-random-pair (high low)
+  (declare (type (unsigned-byte 16) high low))
+  (let* ((n0
+          (%i* 48271
+             (the  (unsigned-byte 31)
+               (logior (the (unsigned-byte 31)
+                         (ash (ldb (byte 15 0) high) 16))
+                       (the (unsigned-byte 16)
+                         (ldb (byte 16 0) low))))))
+         (n (fast-mod n0 (1- (expt 2 31)))))
+(defun %next-random-seed (state)
+  (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271))))
     (declare (fixnum n))
+    (values (ldb (byte 15 16) n)
+            (ldb (byte 16 0) n))))
+    (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31))))
+    (logand n (1- (ash 1 32)))))
+#+32-bit-target
 (defun %next-random-seed (state)
   (multiple-value-bind (high low) (%next-random-pair (%svref state 1)
                                                      (%svref state 2))
+  (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state)
+                                                     (random.seed-2 state))
     (declare (type (unsigned-byte 15) high)
              (type (unsigned-byte 16) low))
     (setf (%svref state 1) high
           (%svref state 2) low)
+    (setf (random.seed-1 state) high
+          (random.seed-2 state) low)
     (logior high (the fixnum (logand low (ash 1 15))))))
+#+32-bit-target
 (defun %bignum-random (number state)
   (let* ((bits (+ (integer-length number) 8))
 …
 (defun %float-random (number state)
+  (if (zerop number)
+    number
+    (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum)))
+      (declare (dynamic-extent ratio))
+      (* number ratio))))
+  (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum)))
+    (declare (dynamic-extent ratio))
+    (* number ratio)))
 (eval-when (:compile-toplevel :execute)

branches/working-0711/ccl/level-0/l0-pred.lisp

-                      r7578
+                      r7624
     catch-frame                         ; 4
     function                            ; 5
     lisp-thread                         ; 6
+    basic-stream                         ; 6
     symbol                              ; 7
     lock                                ; 8
 …
       ratio
       symbol
       lisp-thread
+      basic-stream
       standard-instance
       complex
 …
     package
     slot-vector
     lisp-thread
+    basic-stream
     function-vector                                        ;8
     array-header

branches/working-0711/ccl/level-0/l0-utils.lisp

-                      r6916
+                      r7624
     (assq item list)))
+(defun assequal (item list)
+  (dolist (pair list)
+    (if pair
+      (if (equal item (car pair))
+        (return pair)))))
 ;;; (memeql item list) <=> (member item list :test #'eql :key #'identity)
 (defun memeql (item list)
 …
          ((endp l))
       (when (eql (%car l) item) (return l)))
+    (memq item list))
+)
+    (memq item list)))
+(defun memequal (item list)
+  (do* ((l list (%cdr l)))
+       ((endp l))
+    (when (equal (%car l) item) (return l))))

branches/working-0711/ccl/level-0/nfasload.lisp

r6184	r7624
1045	1045	xload-startup-file))
1046	1046	(%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
1047
	1047	(setq %system-locks% (%cons-population nil))
1048	1048	;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
1049	1049	;; do SET-PACKAGE in cold load functions.

branches/working-0711/ccl/level-1/l1-aprims.lisp

-                      r7463
+                      r7624
           (gethash lower *non-standard-lower-to-upper*) upper)))
+(assert-hash-table-readonly *non-standard-upper-to-lower*)
+(assert-hash-table-readonly *non-standard-lower-to-upper*)
 (defun %non-standard-upper-case-equivalent (char)
   (gethash char *non-standard-lower-to-upper*))

branches/working-0711/ccl/level-1/l1-boot-2.lisp

r6186	r7624
269	269	(bin-load-provide "MCL-COMPAT" "mcl-compat")
270	270	(require "LOOP")
271		~~(require "HASH-CONS")~~
272	271	(bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
273	272	(l1-load-provide "VERSION" "version")

branches/working-0711/ccl/level-1/l1-clos.lisp

-                      r5944
+                      r7624
                              newval))))))))))
   instance)
+;;; Sometimes you can do a lot better at generic function dispatch than the
+;;; default. This supports that for the one-arg-dcode case.
+(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t))
+  nil)
+(defun optimize-generic-function-dispatching ()
+  (dolist (gf (population.data %all-gfs%))
+    (when (eq #'%%one-arg-dcode (%gf-dcode gf))
+      (let ((methods (generic-function-methods gf)))
+        (when (eql 1 (length methods))
+          (override-one-method-one-arg-dcode gf (car methods)))))))
+;;; dcode for a GF with a single reader method which accesses
+;;; a slot in a class that has no subclasses (that restriction
+;;; makes typechecking simpler and also ensures that the slot's
+;;; location is correct.)
+(defun singleton-reader-dcode (dt instance)
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((class (%svref dt %gf-dispatch-table-first-data))
+         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
+    (if (eq (if (eq (typecode instance) target::subtag-instance)
+              (%class-of-instance instance))
+            class)
+      (%slot-ref (instance.slots instance) location)
+      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+;;; Dcode for a GF whose methods are all reader-methods which access a
+;;; slot in one or more classes which have multiple subclasses, all of
+;;; which (by luck or design) have the same slot-definition location.
+(defun reader-constant-location-dcode (dt instance)
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((classes (%svref dt %gf-dispatch-table-first-data))
+         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
+    (if (memq (if (eq (typecode instance) target::subtag-instance)
+              (%class-of-instance instance))
+            classes)
+      (%slot-ref (instance.slots instance) location)
+      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+;;; Similar to the case above, but we use an alist to map classes
+;;; to their non-constant locations.
+(defun reader-variable-location-dcode (dt instance)
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
+         (location (cdr
+                    (assq
+                     (if (eq (typecode instance) target::subtag-instance)
+                       (%class-of-instance instance))
+                     alist))))
+    (if location
+      (%slot-ref (instance.slots instance) location)
+      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+(defun class-and-slot-location-alist (classes slot-name)
+  (let* ((alist nil))
+    (labels ((add-class (c)
+               (unless (assq c alist)
+                 (let* ((slots (class-slots c)))
+                   (unless slots
+                     (finalize-inheritance c)
+                     (setq slots (class-slots c)))
+                   (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist))
+                 (dolist (sub (class-direct-subclasses c))
+                   (add-class sub)))))
+      (dolist (class classes) (add-class class))
+      ;; Building the alist the way that we have should often approximate
+      ;; this ordering; the idea is that leaf classes are more likely to
+      ;; be instantiated than non-leaves.
+      (sort alist (lambda (c1 c2)
+                    (< (length (class-direct-subclasses c1))
+                       (length (class-direct-subclasses c2))))
+            :key #'car))))
+;;; Try to replace gf dispatch with something faster in f.
+(defun %snap-reader-method (f)
+  (when (slot-boundp f 'methods)
+    (let* ((methods (generic-function-methods f)))
+      (when (and methods
+                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
+                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
+                 (every (lambda (m) (null (method-qualifiers m))) methods))
+        (let* ((m0 (car methods))
+               (name (slot-definition-name (accessor-method-slot-definition m0))))
+          (when (every (lambda (m)
+                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
+                       (cdr methods))
+            ;; All methods are *STANDARD-READER-METHODS* that
+            ;; access the same slot name.  Build an alist of
+            ;; mapping all subclasses of all classes on which those
+            ;; methods are specialized to the effective slot's
+            ;; location in that subclass.
+            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
+                                    methods))
+                   (alist (class-and-slot-location-alist classes name))
+                   (loc (cdar alist))
+                   (dt (gf.dispatch-table f)))
+              ;; Only try to handle the case where all slots have
+              ;; :allocation :instance (and all locations - the CDRs
+              ;; of the alist pairs - are small, positive fixnums.
+              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
+                (clear-gf-dispatch-table dt)
+                (cond ((null (cdr alist))
+                       ;; Method is only applicable to a single class.
+                       (destructuring-bind (class . location) (car alist)
+                         (setf (%svref dt %gf-dispatch-table-first-data) class
+                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
+                               (gf.dcode f) #'singleton-reader-dcode)))
+                      ((dolist (other (cdr alist) t)
+                         (unless (eq (cdr other) loc)
+                           (return)))
+                       ;; All classes have the slot in the same location,
+                       ;; by luck or design.
+                       (setf (%svref dt %gf-dispatch-table-first-data)
+                             (mapcar #'car alist)
+                             (%svref dt (1+ %gf-dispatch-table-first-data))
+                             loc
+                             (gf.dcode f) #'reader-constant-location-dcode))
+                      (t
+                       ;; Multiple classes; the slot's location varies.
+                       (setf (%svref dt %gf-dispatch-table-first-data)
+                             alist
+                             (gf.dcode f) #'reader-variable-location-dcode)))))))))))
+;;; Iterate over all known GFs; try to optimize their dcode in cases
+;;; involving reader methods.
+(defun snap-reader-methods (&key known-sealed-world (check-conflicts t))
+  (declare (ignore check-conflicts))
+  (unless known-sealed-world
+    (cerror "Proceed, if it's known that no new classes or methods will be defined."
+            "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
+  (let* ((ngf 0)
+         (nwin 0))
+    (dolist (f (population.data %all-gfs%))
+      (incf ngf)
+      (when (%snap-reader-method f)
+        (incf nwin)))
+    (values ngf nwin 0)))

branches/working-0711/ccl/level-1/l1-error-system.lisp

-                      r7126
+                      r7624
              (format s "Current process ~s does not own lock ~s"
                      *current-process* (slot-value c 'lock)))))
+(define-condition not-locked (lock-protocol-error)
+  ()
+  (:report (lambda (c s)
+             (format s "Lock ~s isn't locked." (slot-value c 'lock)))))
+(define-condition deadlock (lock-protocol-error)
+  ()
+  (:report (lambda (c s)
+             (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock)))))
 (define-condition package-error (error)
 …
   "Make an instance of a condition object using the specified initargs."
   (declare (dynamic-extent init-list))
+  (let ((class (or (and (symbolp name) (find-class name nil))
+                   name)))
+    (if (condition-p (class-prototype class))
+        (apply #'make-instance class init-list)
+        (error "~S is not a defined condition type name" name))))
+  (if (subtypep name 'condition)
+    (apply #'make-instance name init-list)
+    (error "~S is not a defined condition type name" name)))
 (defmethod print-object ((c condition) stream)

branches/working-0711/ccl/level-1/l1-lisp-threads.lisp

-                      r7610
+                      r7624
+(defmacro with-self-bound-io-control-vars (&body body)
+  `(let (; from CLtL2, table 22-7:
+         (*package* *package*)
+         (*print-array* *print-array*)
+         (*print-base* *print-base*)
+         (*print-case* *print-case*)
+         (*print-circle* *print-circle*)
+         (*print-escape* *print-escape*)
+         (*print-gensym* *print-gensym*)
+         (*print-length* *print-length*)
+         (*print-level* *print-level*)
+         (*print-lines* *print-lines*)
+         (*print-miser-width* *print-miser-width*)
+         (*print-pprint-dispatch* *print-pprint-dispatch*)
+         (*print-pretty* *print-pretty*)
+         (*print-radix* *print-radix*)
+         (*print-readably* *print-readably*)
+         (*print-right-margin* *print-right-margin*)
+         (*read-base* *read-base*)
+         (*read-default-float-format* *read-default-float-format*)
+         (*read-eval* *read-eval*)
+         (*read-suppress* *read-suppress*)
+         (*readtable* *readtable*))
+     ,@body))
 …
 (defvar *termination-population*
+(defstatic *termination-population*
   (%cons-terminatable-alist))
 (defvar *termination-population-lock* (make-lock))
+(defstatic *termination-population-lock* (make-lock))
 …
 or releasing of resources which needs to happen when a certain object is
 no longer being used."
   (let ((new-cell (list (cons object function)))
+  (let ((new-cell (cons object function))
         (population *termination-population*))
     (without-interrupts
      (with-lock-grabbed (*termination-population-lock*)
+       (setf (cdr new-cell) (population-data population)
+             (population-data population) new-cell)))
+       (atomic-push-uvector-cell population population.data new-cell)))
     function))
 …
 (defun drain-termination-queue ()
+  (let ((cell nil)
+        (population *termination-population*))
+    (loop
+    (without-interrupts
+     (with-lock-grabbed (*termination-population-lock*)
+       (without-gcing
+        (let ((list (population-termination-list population)))
+          (unless list (return))
+          (setf cell (car list)
+                (population-termination-list population) (cdr list))))))
+      (funcall (cdr cell) (car cell)))))
+  (with-lock-grabbed (*termination-population-lock*)
+    (let* ((population *termination-population*))
+      (loop
+        (multiple-value-bind (cell existed)
+            (atomic-pop-uvector-cell population population.termination-list)
+          (if (not existed)
+            (return)
+          (funcall (cdr cell) (car cell))))))))
 (defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
+  (let ((found-it? nil))
+    (flet ((test (object cell)
+             (and (eq object (car cell))
+                  (or (not function-p)
+                      (eq function (cdr cell)))
+                  (setq found-it? t))))
+      (declare (dynamic-extent #'test))
+      (without-interrupts
+       (with-lock-grabbed (*termination-population-lock*)
+         (setf (population-data *termination-population*)
+               (delete object (population-data *termination-population*)
+                       :test #'test
+                       :count 1))))
+      found-it?)))
+  (let* ((found nil))
+    (with-lock-grabbed (*termination-population-lock*)
+      ;; Have to defer GCing, e.g., defer responding to a GC
+      ;; suspend request here (that also defers interrupts)
+      ;; We absolutely, positively can't take an exception
+      ;; in here, so don't even bother to typecheck on
+      ;; car/cdr etc.
+      (with-deferred-gc
+          (do ((spine (population-data *termination-population*) (cdr spine))
+               (prev nil spine))
+              ((null spine))
+            (declare (optimize (speed 3) (safety 0)))
+            (let* ((head (car spine))
+                   (tail (cdr spine))
+                   (o (car head))
+                   (f (cdr head)))
+              (when (and (eq o object)
+                         (or (null function-p)
+                             (eq function f)))
+                (if prev
+                  (setf (cdr prev) tail)
+                  (setf (population-data *termination-population*) tail))
+                (setq found t)
+                (return)))))
+      found)))
 (defun termination-function (object)

branches/working-0711/ccl/level-1/l1-numbers.lisp

-                      r6027
+                      r7624
       nil)))
+(defun %cons-random-state (seed-1 seed-2)
+  #+32-bit-target
+  (gvector :istuct
+           'random-state
+           seed-1
+           seed-2)
+  #+64-bit-target
+  (gvector :istruct
+           'random-state
+           (the fixnum (+ (the fixnum seed-2)
+                          (the fixnum (ash (the fixnum seed-1) 16))))))
 ;;; random associated stuff except for the print-object method which
 ;;; is still in "lib;numbers.lisp"
 …
   (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000))
     (report-bad-arg seed-2 '(unsigned-byte 16)))
+    (gvector :istruct
+             'random-state
+             seed-1
+             seed-2))
+    (%cons-random-state seed-1 seed-2))
 (defun make-random-state (&optional state)
 …
         (setq state (require-type (or state *random-state*) 'random-state))
         (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state))))
     (gvector :istruct 'random-state seed-1 seed-2)))
+    (%cons-random-state seed-1 seed-2)))
 (defun random-state-p (thing) (istruct-typep thing 'random-state))

branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

-                      r7225
+                      r7624
     (if frame-sp
       (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
+(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
+  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
+    (when frame-sp
+      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
+        (when (and lfun pc)
+          (let* ((unavailable (cons nil nil)))
+            (declare (dynamic-extent unavailable))
+            (let* ((value (arg-value nil frame-sp lfun pc unavailable name)))
+              (if (eq value unavailable)
+                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
+                (toplevel-print (list value))))))))))
+(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
+  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
+    (when frame-sp
+      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
+        (when (and lfun pc)
+          (or (set-arg-value nil frame-sp lfun pc name new)
+              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
+(define-toplevel-command :break local (name frame-number) "Return value of local denoted by <name> in frame <frame-number> <name> can either be a symbol - in which case the most recent
+binding of that symbol is used - or an integer index into the frame's set of local bindings."
+  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
+    (when frame-sp
+      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
+        (when (and lfun pc)
+          (let* ((unavailable (cons nil nil)))
+            (declare (dynamic-extent unavailable))
+            (let* ((value (local-value nil frame-sp lfun pc unavailable name)))
+              (if (eq value unavailable)
+                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
+                (toplevel-print (list value))))))))))
+(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted <name> (see :LOCAL) in frame <frame-number> to value <new>."
+  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
+    (when frame-sp
+      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
+        (when (and lfun pc)
+          (or (set-local-value nil frame-sp lfun pc name new)
+              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
 (define-toplevel-command :break form (frame-number)
 …
                           (cons keyword params)
                           keyword)))
                     (params param)))))))))))
+                    (params (eval param))))))))))))
 ;;; Read a form from the specified stream.
 …
     (dolist (x bogus-globals)
       (set x (funcall (pop newvals))))
     (when (and *debugger-hook* *break-on-errors*)
+    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
       (let ((hook *debugger-hook*)
             (*debugger-hook* nil))
 …
               (format s "~s" oldval))
             (format s ", was reset to ~s ." (symbol-value bogusness)))))
       (if *break-on-errors*
+      (if (and *break-on-errors* (not *batch-flag*))
         (break-loop condition error-pointer)
+        (abort)))))
+        (if *batch-flag*
+          (quit -1)
+          (abort))))))
 (defun break (&optional string &rest args)

branches/working-0711/ccl/level-1/l1-sockets.lisp

-                      r6914
+                      r7624
             "WITH-OPEN-SOCKET"))
 (eval-when (:compile-toplevel)
+(eval-when (:compile-toplevel :execute)
   #+linuxppc-target
   (require "PPC-LINUX-SYSCALLS")
 …
 (define-condition socket-creation-error (simple-error)
   ((code :initarg :code :reader socket-creation-error-code)
    (identifier :initform :unknown :initarg :identifier :reader socket-creationg-error-identifier)
+   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
    (situation :initarg :situation :reader socket-creation-error-situation)))
 …
                     local-port local-host backlog class out-of-band-inline
                     local-filename remote-filename sharing basic
                     external-format)
+                    external-format (auto-close t))
   "Create and return a new socket."
   (declare (dynamic-extent keys))
 …
                    keepalive reuse-address nodelay broadcast linger
                    local-port local-host backlog class out-of-band-inline
+                   local-filename remote-filename sharing basic external-format))
+                   local-filename remote-filename sharing basic external-format
+                   auto-close))
   (ecase address-family
     ((:file) (apply #'make-file-socket keys))
 …
 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) &allow-other-keys)
+(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) &allow-other-keys)
   (let* ((external-format (normalize-external-format :socket external-format)))
     (let ((element-type (ecase format
 …
                       :encoding (external-format-character-encoding external-format)
                       :line-termination (external-format-line-termination external-format)
+                      :basic basic))))
+(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic &allow-other-keys)
+                      :basic basic
+                      :auto-close auto-close))))
+(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic (auto-close t) &allow-other-keys)
   (let* ((external-format (normalize-external-format :socket external-format)))
 …
                       :sharing sharing
                       :character-p (not (eq format :binary))
+                      :basic basic))))
+                      :basic basic
+                      :auto-close auto-close))))
 (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
 …
           (pref addr :in_addr.s_addr))))))
 (defun c_socket (domain type protocol)
+(defun c_socket_1 (domain type protocol)
   #-linuxppc-target
   (syscall syscalls::socket domain type protocol)
 …
           (paref params (:* :unsigned-long) 2) protocol)
     (syscall syscalls::socketcall 1 params)))
+(defun c_socket (domain type protocol)
+  (let* ((fd (c_socket_1 domain type protocol)))
+    (when (or (eql fd (- #$EMFILE))
+              (eql fd (- #$ENFILE)))
+      (gc)
+      (drain-termination-queue)
+      (setq fd (c_socket_1 domain type protocol)))
+    fd))
 (defun init-unix-sockaddr (addr path)

branches/working-0711/ccl/level-1/l1-streams.lisp

-                      r7444
+                      r7624
+(defun optimal-buffer-size (fd)
+  (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
 ;;; Note that we can get "bivalent" streams by specifiying :character-p t
 …
                           (direction :input)
                           (interactive t)
                           (elements-per-buffer *elements-per-buffer*)
+                          (elements-per-buffer (optimal-buffer-size fd))
                           (element-type 'character)
                           (class 'fd-stream)
 …
                           (basic nil)
                           encoding
+                          line-termination)
+                          line-termination
+                          auto-close)
   (when line-termination
     (setq line-termination
 …
          (out-p (member direction '(:io :output)))
          (class-name (select-stream-class class in-p out-p character-p))
+         (class (find-class class-name)))
+    (make-ioblock-stream class
+                         :insize (if in-p elements-per-buffer)
+                         :outsize (if out-p elements-per-buffer)
+                         :device fd
+                         :interactive interactive
+                         :element-type element-type
+                         :advance-function (if in-p
+                                             (select-stream-advance-function class direction))
+                         :listen-function (if in-p 'fd-stream-listen)
+                         :eofp-function (if in-p 'fd-stream-eofp)
+                         :force-output-function (if out-p
+                                                  (select-stream-force-output-function class direction))
+                         :close-function 'fd-stream-close
+                         :sharing sharing
+                         :character-p character-p
+                         :encoding encoding
+                         :line-termination line-termination)))
+         (class (find-class class-name))
+         (stream
+          (make-ioblock-stream class
+                               :insize (if in-p elements-per-buffer)
+                               :outsize (if out-p elements-per-buffer)
+                               :device fd
+                               :interactive interactive
+                               :element-type element-type
+                               :advance-function (if in-p
+                                                    (select-stream-advance-function class direction))
+                               :listen-function (if in-p 'fd-stream-listen)
+                               :eofp-function (if in-p 'fd-stream-eofp)
+                               :force-output-function (if out-p
+                                                         (select-stream-force-output-function class direction))
+                               :close-function 'fd-stream-close
+                               :sharing sharing
+                               :character-p character-p
+                               :encoding encoding
+                               :line-termination line-termination)))
+    (if auto-close
+       (terminate-when-unreachable stream
+                                   (lambda (stream)
+                                     (close stream :abort t))))
+    stream))
 ;;;  Fundamental streams.
 …
     s))
+(defmethod %stream-ioblock ((s basic-stream))
+  (basic-stream.state s))
 (defmethod (setf stream-ioblock) (ioblock (s basic-stream))
 …
 (defun stream-ioblock (stream error-if-nil)
+  (or (%stream-ioblock stream)
+  (or (if (typep stream 'basic-stream)
+        (basic-stream.state stream)
+        (%stream-ioblock stream))
       (when error-if-nil
         (stream-is-closed stream))))
 …
 (defmethod stream-surrounding-characters ((stream basic-character-input-stream))
     (let* ((ioblock (stream-ioblock stream nil)))
+    (let* ((ioblock (basic-stream.state stream)))
       (and ioblock (%ioblock-surrounding-characters ioblock))))
 …
 (defun fd-stream-close (s ioblock)
+  (cancel-terminate-when-unreachable s)
   (when (ioblock-dirty ioblock)
     (stream-finish-output s))
 …
 (defmethod stream-external-format ((s basic-character-stream))
   (%ioblock-external-format (stream-ioblock s t)))
+  (%ioblock-external-format (basic-stream-ioblock s)))
 (defmethod (setf stream-external-format) (new (s basic-character-stream))
   (setf (%ioblock-external-format (stream-ioblock s t))
+  (setf (%ioblock-external-format (basic-stream-ioblock s))
         (normalize-external-format (stream-domain s) new)))

branches/working-0711/ccl/level-1/l1-unicode.lisp

-                      r7307
+                      r7624
                (setf (schar string i) (or char #\Replacement_Character)))))))
     :memory-encode-function
+    (nfunction
+     utf-8-memory-encode
+     (lambda (string pointer idx start end)
+       (declare (fixnum idx))
+       (do* ((i start (1+ i)))
+            ((>= i end) idx)
+         (let* ((code (char-code (schar string i))))
+           (declare (type (mod #x110000) code))
+           (cond ((< code #x80)
+                  (setf (%get-unsigned-byte pointer idx) code)
+                  (incf idx))
+                 ((< code #x800)
+                  (setf (%get-unsigned-byte pointer idx)
+                        (logior #xc0 (the fixnum (ash code -6))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                        (logior #x80 (the fixnum (logand code #x3f))))
+                  (incf idx 2))
+                 ((< code #x10000)
+                  (setf (%get-unsigned-byte pointer idx)
+                        (logior #xe0 (the fixnum (ash code -12))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                        (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                        (logior #x80 (the fixnum (logand code #x3f))))
+                  (incf idx 3))
+                 (t
+                  (setf (%get-unsigned-byte pointer idx)
+                        (logior #xf0
+                                (the fixnum (logand #x7 (the fixnum (ash code -18))))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                        (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                        (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+                  (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
+                        (logand #x3f code))
+                  (incf idx 4)))))))
+    #'utf-8-memory-encode
     :memory-decode-function
+    (nfunction
+     utf-8-memory-decode
+     (lambda (pointer noctets idx string)
+       (declare (fixnum noctets idx))
+       (do* ((i 0 (1+ i))
+             (end (+ idx noctets))
+             (index idx (1+ index)))
+            ((>= index end) (if (= index end) index 0))
+         (let* ((1st-unit (%get-unsigned-byte pointer index)))
+           (declare (type (unsigned-byte 8) 1st-unit))
+           (let* ((char (if (< 1st-unit #x80)
+                          (code-char 1st-unit)
+                          (if (>= 1st-unit #xc2)
+                            (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
+                              (declare (type (unsigned-byte 8) 2nd-unit))
+                              (if (< 1st-unit #xe0)
+                                (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                  (code-char
+                                   (logior
+                                    (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
+                                    (the fixnum (logxor 2nd-unit #x80)))))
+                                (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
+                                  (declare (type (unsigned-byte 8) 3rd-unit))
+                                  (if (< 1st-unit #xf0)
+                                    (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                             (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                             (or (>= 1st-unit #xe1)
+                                                 (>= 2nd-unit #xa0)))
+                                      (code-char (the fixnum
+                                                   (logior (the fixnum
+                                                             (ash (the fixnum (logand 1st-unit #xf))
+))
+                                                           (the fixnum
+                                                             (logior
+                                                              (the fixnum
+                                                                (ash (the fixnum (logand 2nd-unit #x3f))
+))
+                                                              (the fixnum (logand 3rd-unit #x3f))))))))
+                                    (if (< 1st-unit #xf8)
+                                      (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
+                                        (declare (type (unsigned-byte 8) 4th-unit))
+                                        (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                                 (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                                 (< (the fixnum (logxor 4th-unit #x80)) #x40)
+                                                 (or (>= 1st-unit #xf1)
+                                                     (>= 2nd-unit #x90)))
+                                          (code-char
+                                           (logior
+                                            (the fixnum
+                                              (logior
+                                               (the fixnum
+                                                 (ash (the fixnum (logand 1st-unit 7)) 18))
+                                               (the fixnum
+                                                 (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
+                                            (the fixnum
+                                              (logior
+                                               (the fixnum
+                                                 (ash (the fixnum (logxor 3rd-unit #x80)) 6))
+                                               (the fixnum (logxor 4th-unit #x80)))))))))))))))))
+             (setf (schar string i) (or char #\Replacement_Character)))))))
+    #'utf-8-memory-decode
     :octets-in-string-function
+    (nfunction
+     utf-8-octets-in-string
+     (lambda (string start end)
+       (if (>= end start)
+         (do* ((noctets 0)
+               (i start (1+ i)))
+              ((= i end) noctets)
+           (declare (fixnum noctets))
+           (let* ((code (char-code (schar string i))))
+             (declare (type (mod #x110000) code))
+             (incf noctets
+                   (if (< code #x80)
+                     (if (< code #x800)
+                       (if (< code #x10000)
+))))))
+)))
+    #'utf-8-octets-in-string
     :length-of-vector-encoding-function
     (nfunction
 …
              (setq nchars (1+ nchars) i nexti))))))
     :length-of-memory-encoding-function
+    (nfunction
+     utf-8-length-of-memory-encoding
+     (lambda (pointer noctets start)
+       (do* ((i start)
+             (end (+ start noctets))
+             (nchars 0 (1+ nchars)))
+            ((= i end) (values nchars i))
+         (let* ((code (%get-unsigned-byte pointer i))
+                (nexti (+ i (cond ((< code #x80) 1)
+                                  ((< code #xe0) 2)
+                                  ((< code #xf0) 3)
+                                  (t 4)))))
+           (declare (type (unsigned-byte 8) code))
+           (if (> nexti end)
+             (return (values nchars i))
+             (setq i nexti))))))
+    #'utf-8-length-of-memory-encoding
     :decode-literal-code-unit-limit #x80
     :encode-literal-char-code-limit #x80
 …
                  data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s))))))))
+;;; This is an array of 256 integers, that (sparsely) encodes 64K bits.
+;;; (There might be as many as 256 significant bits in some of entries
+;;; in this table.)
+(defstatic *bmp-combining-bitmap*
+    #(
+        #x00
+        #x00
+        #x00
+        #xFFFF0000FFFFFFFFFFFFFFFFFFFF
+        #x37800000000000000000000000000000000
+        #x16BBFFFFFBFFFE000000000000000000000000000000000000
+        #x3D9FFFC00000000000000000000000010000003FF8000000000000000000
+        #x1FFC00000000000000000000007FFFFFF000000020000
+        #x00
+        #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E
+        #x3BBFD00000000000000E0003000000003987D000000000000004
+        #x803DC7C0000000000000040000000000C0398FD00000000000000E
+        #x603DDFC00000000000000C0000000000603DDFC00000000000000E
+        #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C
+        #x3F001BF20000000000000000000000007F8007F2000000000000
+        #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000
+        #x3C0000003C7F00000000000
+        #x7FFFFFF0000000000003FFFFE000000000000000000000000
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000
+        #x2000000000000000000000000000000000000003800
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x7FFFFFF0000000000000000000000000000000000000000000000000000
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x600000000000000000000000000FC0000000000
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x00
+        #x40000000
+        #x00
+        #x00
+        #xF0000FFFF
+        #x00))
+(defun is-combinable (char)
+  (let* ((code (char-code char)))
+    (declare (type (mod #x110000) code))
+    (when (< code #x1000)
+      (logbitp (ldb (byte 8 0) code)
+               (svref *bmp-combining-bitmap* (ldb (byte 8 8) code))))))
+(defstatic *bmp-combining-chars*
+  #(#\Combining_Grave_Accent
+    #\Combining_Acute_Accent
+    #\Combining_Circumflex_Accent
+    #\Combining_Tilde
+    #\Combining_Macron
+    #\Combining_Breve
+    #\Combining_Dot_Above
+    #\Combining_Diaeresis
+    #\Combining_Hook_Above
+    #\Combining_Ring_Above
+    #\Combining_Double_Acute_Accent
+    #\Combining_Caron
+    #\Combining_Double_Grave_Accent
+    #\Combining_Inverted_Breve
+    #\Combining_Comma_Above
+    #\Combining_Reversed_Comma_Above
+    #\Combining_Horn
+    #\Combining_Dot_Below
+    #\Combining_Diaeresis_Below
+    #\Combining_Ring_Below
+    #\Combining_Comma_Below
+    #\Combining_Cedilla
+    #\Combining_Ogonek
+    #\Combining_Circumflex_Accent_Below
+    #\Combining_Breve_Below
+    #\Combining_Tilde_Below
+    #\Combining_Macron_Below
+    #\Combining_Long_Solidus_Overlay
+    #\Combining_Greek_Perispomeni
+    #\Combining_Greek_Ypogegrammeni
+    #\Arabic_Maddah_Above
+    #\Arabic_Hamza_Above
+    #\Arabic_Hamza_Below
+    #\U+093C
+    #\U+09BE
+    #\U+09D7
+    #\U+0B3E
+    #\U+0B56
+    #\U+0B57
+    #\U+0BBE
+    #\U+0BD7
+    #\U+0C56
+    #\U+0CC2
+    #\U+0CD5
+    #\U+0CD6
+    #\U+0D3E
+    #\U+0D57
+    #\U+0DCA
+    #\U+0DCF
+    #\U+0DDF
+    #\U+102E
+    #\U+3099
+    #\U+309A))
+(defstatic *bmp-combining-base-chars*
+  #(
+    ;; #\Combining_Grave_Accent
+    #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y
+      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
+      #\Latin_Capital_Letter_E_With_Circumflex
+      #\Latin_Capital_Letter_O_With_Circumflex
+      #\Latin_Capital_Letter_U_With_Diaeresis
+      #\Latin_Small_Letter_A_With_Circumflex
+      #\Latin_Small_Letter_E_With_Circumflex
+      #\Latin_Small_Letter_O_With_Circumflex
+      #\Latin_Small_Letter_U_With_Diaeresis
+      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
+      #\Latin_Capital_Letter_E_With_Macron
+      #\Latin_Small_Letter_E_With_Macron
+      #\Latin_Capital_Letter_O_With_Macron
+      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn
+      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
+      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
+      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
+      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
+      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
+      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
+      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
+      #\Greek_Small_Letter_Upsilon_With_Dialytika
+      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I
+      #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01
+      #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20
+      #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39
+      #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59
+      #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
+    ;; #\Combining_Acute_Accent
+    #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z
+      #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z
+      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
+      #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae
+      #\Latin_Capital_Letter_C_With_Cedilla
+      #\Latin_Capital_Letter_E_With_Circumflex
+      #\Latin_Capital_Letter_I_With_Diaeresis
+      #\Latin_Capital_Letter_O_With_Circumflex
+      #\Latin_Capital_Letter_O_With_Tilde
+      #\Latin_Capital_Letter_O_With_Stroke
+      #\Latin_Capital_Letter_U_With_Diaeresis
+      #\Latin_Small_Letter_A_With_Circumflex
+      #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae
+      #\Latin_Small_Letter_C_With_Cedilla
+      #\Latin_Small_Letter_E_With_Circumflex
+      #\Latin_Small_Letter_I_With_Diaeresis
+      #\Latin_Small_Letter_O_With_Circumflex
+      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke
+      #\Latin_Small_Letter_U_With_Diaeresis
+      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
+      #\Latin_Capital_Letter_E_With_Macron
+      #\Latin_Small_Letter_E_With_Macron
+      #\Latin_Capital_Letter_O_With_Macron
+      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde
+      #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn
+      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
+      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
+      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
+      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
+      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
+      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
+      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
+      #\Greek_Small_Letter_Upsilon_With_Dialytika
+      #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe
+      #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe
+      #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09
+      #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28
+      #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41
+      #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
+      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
+    ;; #\Combining_Circumflex_Accent
+    #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g
+      #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8
+      #\U+1EB9 #\U+1ECC #\U+1ECD)
+    ;; #\Combining_Tilde
+    #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y
+      #\Latin_Capital_Letter_A_With_Circumflex
+      #\Latin_Capital_Letter_E_With_Circumflex
+      #\Latin_Capital_Letter_O_With_Circumflex
+      #\Latin_Small_Letter_A_With_Circumflex
+      #\Latin_Small_Letter_E_With_Circumflex
+      #\Latin_Small_Letter_O_With_Circumflex
+      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
+      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
+      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
+    ;; #\Combining_Macron
+    #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y
+      #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae
+      #\Latin_Capital_Letter_O_With_Tilde
+      #\Latin_Capital_Letter_O_With_Diaeresis
+      #\Latin_Capital_Letter_U_With_Diaeresis
+      #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae
+      #\Latin_Small_Letter_O_With_Tilde
+      #\Latin_Small_Letter_O_With_Diaeresis
+      #\Latin_Small_Letter_U_With_Diaeresis
+      #\Latin_Capital_Letter_O_With_Ogonek
+      #\Latin_Small_Letter_O_With_Ogonek
+      #\Latin_Capital_Letter_A_With_Dot_Above
+      #\Latin_Small_Letter_A_With_Dot_Above
+      #\Latin_Capital_Letter_O_With_Dot_Above
+      #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha
+      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I
+      #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I
+      #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B)
+    ;; #\Combining_Breve
+    #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u
+      #\Latin_Capital_Letter_E_With_Cedilla
+      #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha
+      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A
+      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe
+      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U
+      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
+      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I
+      #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1)
+    ;; #\Combining_Dot_Above
+    #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W
+      #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s
+      #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute
+      #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron
+      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62
+      #\U+1E63)
+    ;; #\Combining_Diaeresis
+    #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w
+      #\x #\y #\Latin_Capital_Letter_O_With_Tilde
+      #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron
+      #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota
+      #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol
+      #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I
+      #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie
+      #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze
+      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O
+      #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che
+      #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E
+      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
+      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze
+      #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O
+      #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che
+      #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E
+      #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I
+      #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa
+      #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O)
+    ;; #\Combining_Hook_Above
+    #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y
+      #\Latin_Capital_Letter_A_With_Circumflex
+      #\Latin_Capital_Letter_E_With_Circumflex
+      #\Latin_Capital_Letter_O_With_Circumflex
+      #\Latin_Small_Letter_A_With_Circumflex
+      #\Latin_Small_Letter_E_With_Circumflex
+      #\Latin_Small_Letter_O_With_Circumflex
+      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
+      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
+      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
+    ;; #\Combining_Ring_Above
+    #(#\A #\U #\a #\u #\w #\y)
+    ;; #\Combining_Double_Acute_Accent
+    #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U
+      #\Cyrillic_Small_Letter_U)
+    ;; #\Combining_Caron
+    #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a
+      #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z
+      #\Latin_Capital_Letter_U_With_Diaeresis
+      #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh
+      #\Latin_Small_Letter_Ezh)
+    ;; #\Combining_Double_Grave_Accent
+    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u
+      #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa)
+    ;; #\Combining_Inverted_Breve
+    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u)
+    ;; #\Combining_Comma_Above
+    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
+      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
+      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
+      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
+      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
+    ;; #\Combining_Reversed_Comma_Above
+    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
+      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
+      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho
+      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
+      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
+      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
+      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
+      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
+    ;; #\Combining_Horn
+    #(#\O #\U #\o #\u)
+    ;; #\Combining_Dot_Below
+    #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W
+      #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u
+      #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn
+      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
+      #\Latin_Small_Letter_U_With_Horn)
+    ;; #\Combining_Diaeresis_Below
+    #(#\U #\u)
+    ;; #\Combining_Ring_Below
+    #(#\A #\a)
+    ;; #\Combining_Comma_Below
+    #(#\S #\T #\s #\t)
+    ;; #\Combining_Cedilla
+    #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k
+      #\l #\n #\r #\s #\t)
+    ;; #\Combining_Ogonek
+    #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u)
+    ;; #\Combining_Circumflex_Accent_Below
+    #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u)
+    ;; #\Combining_Breve_Below
+    #(#\H #\h)
+    ;; #\Combining_Tilde_Below
+    #(#\E #\I #\U #\e #\i #\u)
+    ;; #\Combining_Macron_Below
+    #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z)
+    ;; #\Combining_Long_Solidus_Overlay
+    #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4
+      #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243
+      #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272
+      #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D
+      #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2
+      #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5)
+    ;; #\Combining_Greek_Perispomeni
+    #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta
+      #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon
+      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
+      #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08
+      #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31
+      #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
+      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
+    ;; #\Combining_Greek_Ypogegrammeni
+    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta
+      #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos
+      #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha
+      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega
+      #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02
+      #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09
+      #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20
+      #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27
+      #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E
+      #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65
+      #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C
+      #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6
+      #\U+1FC6 #\U+1FF6)
+    ;; #\Arabic_Maddah_Above
+    #(#\Arabic_Letter_Alef)
+    ;; #\Arabic_Hamza_Above
+    #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh
+      #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree
+      #\Arabic_Letter_Ae)
+    ;; #\Arabic_Hamza_Below
+    #(#\Arabic_Letter_Alef)
+    ;; #\U+093C
+    #(#\U+0928 #\U+0930 #\U+0933)
+    ;; #\U+09BE
+    #(#\U+09C7)
+    ;; #\U+09D7
+    #(#\U+09C7)
+    ;; #\U+0B3E
+    #(#\U+0B47)
+    ;; #\U+0B56
+    #(#\U+0B47)
+    ;; #\U+0B57
+    #(#\U+0B47)
+    ;; #\U+0BBE
+    #(#\U+0BC6 #\U+0BC7)
+    ;; #\U+0BD7
+    #(#\U+0B92 #\U+0BC6)
+    ;; #\U+0C56
+    #(#\U+0C46)
+    ;; #\U+0CC2
+    #(#\U+0CC6)
+    ;; #\U+0CD5
+    #(#\U+0CBF #\U+0CC6 #\U+0CCA)
+    ;; #\U+0CD6
+    #(#\U+0CC6)
+    ;; #\U+0D3E
+    #(#\U+0D46 #\U+0D47)
+    ;; #\U+0D57
+    #(#\U+0D46)
+    ;; #\U+0DCA
+    #(#\U+0DD9 #\U+0DDC)
+    ;; #\U+0DCF
+    #(#\U+0DD9)
+    ;; #\U+0DDF
+    #(#\U+0DD9)
+    ;; #\U+102E
+    #(#\U+1025)
+    ;; #\U+3099
+    #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055
+      #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064
+      #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B
+      #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3
+      #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1
+      #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8
+      #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD)
+    ;; #\U+309A
+    #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2
+      #\U+30D5 #\U+30D8 #\U+30DB)
+    ))
+(defstatic *bmp-precombined-chars*
+  #(
+    ;; #\Combining_Grave_Accent
+    #(#\Latin_Capital_Letter_A_With_Grave
+      #\Latin_Capital_Letter_E_With_Grave
+      #\Latin_Capital_Letter_I_With_Grave
+      #\Latin_Capital_Letter_N_With_Grave
+      #\Latin_Capital_Letter_O_With_Grave
+      #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2
+      #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave
+      #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave
+      #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave
+      #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2
+      #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1
+      #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0
+      #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD
+      #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8
+      #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78
+      #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2
+      #\Cyrillic_Capital_Letter_Ie_With_Grave
+      #\Cyrillic_Capital_Letter_I_With_Grave
+      #\Cyrillic_Small_Letter_Ie_With_Grave
+      #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A
+      #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23
+      #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42
+      #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62
+      #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD)
+    ;; #\Combining_Acute_Accent
+    #(#\Latin_Capital_Letter_A_With_Acute
+      #\Latin_Capital_Letter_C_With_Acute
+      #\Latin_Capital_Letter_E_With_Acute
+      #\Latin_Capital_Letter_G_With_Acute
+      #\Latin_Capital_Letter_I_With_Acute #\U+1E30
+      #\Latin_Capital_Letter_L_With_Acute #\U+1E3E
+      #\Latin_Capital_Letter_N_With_Acute
+      #\Latin_Capital_Letter_O_With_Acute #\U+1E54
+      #\Latin_Capital_Letter_R_With_Acute
+      #\Latin_Capital_Letter_S_With_Acute
+      #\Latin_Capital_Letter_U_With_Acute #\U+1E82
+      #\Latin_Capital_Letter_Y_With_Acute
+      #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute
+      #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute
+      #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute
+      #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F
+      #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute
+      #\U+1E55 #\Latin_Small_Letter_R_With_Acute
+      #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute
+      #\U+1E83 #\Latin_Small_Letter_Y_With_Acute
+      #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4
+      #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute
+      #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E
+      #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute
+      #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5
+      #\Latin_Small_Letter_A_With_Ring_Above_And_Acute
+      #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1
+      #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute
+      #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF
+      #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA
+      #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos
+      #\Greek_Capital_Letter_Epsilon_With_Tonos
+      #\Greek_Capital_Letter_Eta_With_Tonos
+      #\Greek_Capital_Letter_Iota_With_Tonos
+      #\Greek_Capital_Letter_Omicron_With_Tonos
+      #\Greek_Capital_Letter_Upsilon_With_Tonos
+      #\Greek_Capital_Letter_Omega_With_Tonos
+      #\Greek_Small_Letter_Alpha_With_Tonos
+      #\Greek_Small_Letter_Epsilon_With_Tonos
+      #\Greek_Small_Letter_Eta_With_Tonos
+      #\Greek_Small_Letter_Iota_With_Tonos
+      #\Greek_Small_Letter_Omicron_With_Tonos
+      #\Greek_Small_Letter_Upsilon_With_Tonos
+      #\Greek_Small_Letter_Omega_With_Tonos
+      #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos
+      #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos
+      #\Greek_Upsilon_With_Acute_And_Hook_Symbol
+      #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje
+      #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04
+      #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D
+      #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C
+      #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55
+      #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE)
+    ;; #\Combining_Circumflex_Accent
+    #(#\Latin_Capital_Letter_A_With_Circumflex
+      #\Latin_Capital_Letter_C_With_Circumflex
+      #\Latin_Capital_Letter_E_With_Circumflex
+      #\Latin_Capital_Letter_G_With_Circumflex
+      #\Latin_Capital_Letter_H_With_Circumflex
+      #\Latin_Capital_Letter_I_With_Circumflex
+      #\Latin_Capital_Letter_J_With_Circumflex
+      #\Latin_Capital_Letter_O_With_Circumflex
+      #\Latin_Capital_Letter_S_With_Circumflex
+      #\Latin_Capital_Letter_U_With_Circumflex
+      #\Latin_Capital_Letter_W_With_Circumflex
+      #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90
+      #\Latin_Small_Letter_A_With_Circumflex
+      #\Latin_Small_Letter_C_With_Circumflex
+      #\Latin_Small_Letter_E_With_Circumflex
+      #\Latin_Small_Letter_G_With_Circumflex
+      #\Latin_Small_Letter_H_With_Circumflex
+      #\Latin_Small_Letter_I_With_Circumflex
+      #\Latin_Small_Letter_J_With_Circumflex
+      #\Latin_Small_Letter_O_With_Circumflex
+      #\Latin_Small_Letter_S_With_Circumflex
+      #\Latin_Small_Letter_U_With_Circumflex
+      #\Latin_Small_Letter_W_With_Circumflex
+      #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD
+      #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9)
+    ;; #\Combining_Tilde
+    #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC
+      #\Latin_Capital_Letter_I_With_Tilde
+      #\Latin_Capital_Letter_N_With_Tilde
+      #\Latin_Capital_Letter_O_With_Tilde
+      #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8
+      #\Latin_Small_Letter_A_With_Tilde #\U+1EBD
+      #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde
+      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde
+      #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5
+      #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF)
+    ;; #\Combining_Macron
+    #(#\Latin_Capital_Letter_A_With_Macron
+      #\Latin_Capital_Letter_E_With_Macron #\U+1E20
+      #\Latin_Capital_Letter_I_With_Macron
+      #\Latin_Capital_Letter_O_With_Macron
+      #\Latin_Capital_Letter_U_With_Macron
+      #\Latin_Capital_Letter_Y_With_Macron
+      #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron
+      #\U+1E21 #\Latin_Small_Letter_I_With_Macron
+      #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron
+      #\Latin_Small_Letter_Y_With_Macron
+      #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron
+      #\Latin_Capital_Letter_Ae_With_Macron
+      #\Latin_Capital_Letter_O_With_Tilde_And_Macron
+      #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron
+      #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron
+      #\Latin_Small_Letter_A_With_Diaeresis_And_Macron
+      #\Latin_Small_Letter_Ae_With_Macron
+      #\Latin_Small_Letter_O_With_Tilde_And_Macron
+      #\Latin_Small_Letter_O_With_Diaeresis_And_Macron
+      #\Latin_Small_Letter_U_With_Diaeresis_And_Macron
+      #\Latin_Capital_Letter_O_With_Ogonek_And_Macron
+      #\Latin_Small_Letter_O_With_Ogonek_And_Macron
+      #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron
+      #\Latin_Small_Letter_A_With_Dot_Above_And_Macron
+      #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron
+      #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9
+      #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1
+      #\Cyrillic_Capital_Letter_I_With_Macron
+      #\Cyrillic_Capital_Letter_U_With_Macron
+      #\Cyrillic_Small_Letter_I_With_Macron
+      #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C
+      #\U+1E5D)
+    ;; #\Combining_Breve
+    #(#\Latin_Capital_Letter_A_With_Breve
+      #\Latin_Capital_Letter_E_With_Breve
+      #\Latin_Capital_Letter_G_With_Breve
+      #\Latin_Capital_Letter_I_With_Breve
+      #\Latin_Capital_Letter_O_With_Breve
+      #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve
+      #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve
+      #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve
+      #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8
+      #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0
+      #\Cyrillic_Capital_Letter_A_With_Breve
+      #\Cyrillic_Capital_Letter_Ie_With_Breve
+      #\Cyrillic_Capital_Letter_Zhe_With_Breve
+      #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U
+      #\Cyrillic_Small_Letter_A_With_Breve
+      #\Cyrillic_Small_Letter_Ie_With_Breve
+      #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I
+      #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7)
+    ;; #\Combining_Dot_Above
+    #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02
+      #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A
+      #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E
+      #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22
+      #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44
+      #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60
+      #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E
+      #\Latin_Capital_Letter_Z_With_Dot_Above
+      #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03
+      #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B
+      #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F
+      #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45
+      #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61
+      #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F
+      #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66
+      #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69)
+    ;; #\Combining_Diaeresis
+    #(#\Latin_Capital_Letter_A_With_Diaeresis
+      #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26
+      #\Latin_Capital_Letter_I_With_Diaeresis
+      #\Latin_Capital_Letter_O_With_Diaeresis
+      #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C
+      #\Latin_Capital_Letter_Y_With_Diaeresis
+      #\Latin_Small_Letter_A_With_Diaeresis
+      #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27
+      #\Latin_Small_Letter_I_With_Diaeresis
+      #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97
+      #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D
+      #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A
+      #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika
+      #\Greek_Capital_Letter_Upsilon_With_Dialytika
+      #\Greek_Small_Letter_Iota_With_Dialytika
+      #\Greek_Small_Letter_Upsilon_With_Dialytika
+      #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol
+      #\Cyrillic_Capital_Letter_Yi
+      #\Cyrillic_Capital_Letter_A_With_Diaeresis
+      #\Cyrillic_Capital_Letter_Io
+      #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis
+      #\Cyrillic_Capital_Letter_Ze_With_Diaeresis
+      #\Cyrillic_Capital_Letter_I_With_Diaeresis
+      #\Cyrillic_Capital_Letter_O_With_Diaeresis
+      #\Cyrillic_Capital_Letter_U_With_Diaeresis
+      #\Cyrillic_Capital_Letter_Che_With_Diaeresis
+      #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis
+      #\Cyrillic_Capital_Letter_E_With_Diaeresis
+      #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io
+      #\Cyrillic_Small_Letter_Zhe_With_Diaeresis
+      #\Cyrillic_Small_Letter_Ze_With_Diaeresis
+      #\Cyrillic_Small_Letter_I_With_Diaeresis
+      #\Cyrillic_Small_Letter_O_With_Diaeresis
+      #\Cyrillic_Small_Letter_U_With_Diaeresis
+      #\Cyrillic_Small_Letter_Che_With_Diaeresis
+      #\Cyrillic_Small_Letter_Yeru_With_Diaeresis
+      #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi
+      #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis
+      #\Cyrillic_Small_Letter_Schwa_With_Diaeresis
+      #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis
+      #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis)
+    ;; #\Combining_Hook_Above
+    #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3
+      #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2
+      #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE
+      #\U+1EDF #\U+1EEC #\U+1EED)
+    ;; #\Combining_Ring_Above
+    #(#\Latin_Capital_Letter_A_With_Ring_Above
+      #\Latin_Capital_Letter_U_With_Ring_Above
+      #\Latin_Small_Letter_A_With_Ring_Above
+      #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99)
+    ;; #\Combining_Double_Acute_Accent
+    #(#\Latin_Capital_Letter_O_With_Double_Acute
+      #\Latin_Capital_Letter_U_With_Double_Acute
+      #\Latin_Small_Letter_O_With_Double_Acute
+      #\Latin_Small_Letter_U_With_Double_Acute
+      #\Cyrillic_Capital_Letter_U_With_Double_Acute
+      #\Cyrillic_Small_Letter_U_With_Double_Acute)
+    ;; #\Combining_Caron
+    #(#\Latin_Capital_Letter_A_With_Caron
+      #\Latin_Capital_Letter_C_With_Caron
+      #\Latin_Capital_Letter_D_With_Caron
+      #\Latin_Capital_Letter_E_With_Caron
+      #\Latin_Capital_Letter_G_With_Caron
+      #\Latin_Capital_Letter_H_With_Caron
+      #\Latin_Capital_Letter_I_With_Caron
+      #\Latin_Capital_Letter_K_With_Caron
+      #\Latin_Capital_Letter_L_With_Caron
+      #\Latin_Capital_Letter_N_With_Caron
+      #\Latin_Capital_Letter_O_With_Caron
+      #\Latin_Capital_Letter_R_With_Caron
+      #\Latin_Capital_Letter_S_With_Caron
+      #\Latin_Capital_Letter_T_With_Caron
+      #\Latin_Capital_Letter_U_With_Caron
+      #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron
+      #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron
+      #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron
+      #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron
+      #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron
+      #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron
+      #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron
+      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron
+      #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron
+      #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron
+      #\Latin_Small_Letter_U_With_Diaeresis_And_Caron
+      #\Latin_Capital_Letter_Ezh_With_Caron
+      #\Latin_Small_Letter_Ezh_With_Caron)
+    ;; #\Combining_Double_Grave_Accent
+    #(#\Latin_Capital_Letter_A_With_Double_Grave
+      #\Latin_Capital_Letter_E_With_Double_Grave
+      #\Latin_Capital_Letter_I_With_Double_Grave
+      #\Latin_Capital_Letter_O_With_Double_Grave
+      #\Latin_Capital_Letter_R_With_Double_Grave
+      #\Latin_Capital_Letter_U_With_Double_Grave
+      #\Latin_Small_Letter_A_With_Double_Grave
+      #\Latin_Small_Letter_E_With_Double_Grave
+      #\Latin_Small_Letter_I_With_Double_Grave
+      #\Latin_Small_Letter_O_With_Double_Grave
+      #\Latin_Small_Letter_R_With_Double_Grave
+      #\Latin_Small_Letter_U_With_Double_Grave
+      #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent
+      #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent)
+    ;; #\Combining_Inverted_Breve
+    #(#\Latin_Capital_Letter_A_With_Inverted_Breve
+      #\Latin_Capital_Letter_E_With_Inverted_Breve
+      #\Latin_Capital_Letter_I_With_Inverted_Breve
+      #\Latin_Capital_Letter_O_With_Inverted_Breve
+      #\Latin_Capital_Letter_R_With_Inverted_Breve
+      #\Latin_Capital_Letter_U_With_Inverted_Breve
+      #\Latin_Small_Letter_A_With_Inverted_Breve
+      #\Latin_Small_Letter_E_With_Inverted_Breve
+      #\Latin_Small_Letter_I_With_Inverted_Breve
+      #\Latin_Small_Letter_O_With_Inverted_Breve
+      #\Latin_Small_Letter_R_With_Inverted_Breve
+      #\Latin_Small_Letter_U_With_Inverted_Breve)
+    ;; #\Combining_Comma_Above
+    #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00
+      #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60)
+    ;; #\Combining_Reversed_Comma_Above
+    #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59
+      #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5
+      #\U+1F51 #\U+1F61)
+    ;; #\Combining_Horn
+    #(#\Latin_Capital_Letter_O_With_Horn
+      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn
+      #\Latin_Small_Letter_U_With_Horn)
+    ;; #\Combining_Dot_Below
+    #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32
+      #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C
+      #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05
+      #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43
+      #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F
+      #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1)
+    ;; #\Combining_Diaeresis_Below
+    #(#\U+1E72 #\U+1E73)
+    ;; #\Combining_Ring_Below
+    #(#\U+1E00 #\U+1E01)
+    ;; #\Combining_Comma_Below
+    #(#\Latin_Capital_Letter_S_With_Comma_Below
+      #\Latin_Capital_Letter_T_With_Comma_Below
+      #\Latin_Small_Letter_S_With_Comma_Below
+      #\Latin_Small_Letter_T_With_Comma_Below)
+    ;; #\Combining_Cedilla
+    #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10
+      #\Latin_Capital_Letter_E_With_Cedilla
+      #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28
+      #\Latin_Capital_Letter_K_With_Cedilla
+      #\Latin_Capital_Letter_L_With_Cedilla
+      #\Latin_Capital_Letter_N_With_Cedilla
+      #\Latin_Capital_Letter_R_With_Cedilla
+      #\Latin_Capital_Letter_S_With_Cedilla
+      #\Latin_Capital_Letter_T_With_Cedilla
+      #\Latin_Small_Letter_C_With_Cedilla #\U+1E11
+      #\Latin_Small_Letter_E_With_Cedilla
+      #\Latin_Small_Letter_G_With_Cedilla #\U+1E29
+      #\Latin_Small_Letter_K_With_Cedilla
+      #\Latin_Small_Letter_L_With_Cedilla
+      #\Latin_Small_Letter_N_With_Cedilla
+      #\Latin_Small_Letter_R_With_Cedilla
+      #\Latin_Small_Letter_S_With_Cedilla
+      #\Latin_Small_Letter_T_With_Cedilla)
+    ;; #\Combining_Ogonek
+    #(#\Latin_Capital_Letter_A_With_Ogonek
+      #\Latin_Capital_Letter_E_With_Ogonek
+      #\Latin_Capital_Letter_I_With_Ogonek
+      #\Latin_Capital_Letter_O_With_Ogonek
+      #\Latin_Capital_Letter_U_With_Ogonek
+      #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek
+      #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek
+      #\Latin_Small_Letter_U_With_Ogonek)
+    ;; #\Combining_Circumflex_Accent_Below
+    #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13
+      #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77)
+    ;; #\Combining_Breve_Below
+    #(#\U+1E2A #\U+1E2B)
+    ;; #\Combining_Tilde_Below
+    #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75)
+    ;; #\Combining_Macron_Below
+    #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E
+      #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49
+      #\U+1E5F #\U+1E6F #\U+1E95)
+    ;; #\Combining_Long_Solidus_Overlay
+    #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD
+      #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226
+      #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270
+      #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281
+      #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2
+      #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB
+      #\U+22EC #\U+22ED)
+    ;; #\Combining_Greek_Perispomeni
+    #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7
+      #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27
+      #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56
+      #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF
+      #\U+1FDF)
+    ;; #\Combining_Greek_Ypogegrammeni
+    #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3
+      #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84
+      #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B
+      #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92
+      #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99
+      #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0
+      #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7
+      #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE
+      #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7)
+    ;; #\Arabic_Maddah_Above
+    #(#\Arabic_Letter_Alef_With_Madda_Above)
+    ;; #\Arabic_Hamza_Above
+    #(#\Arabic_Letter_Alef_With_Hamza_Above
+      #\Arabic_Letter_Waw_With_Hamza_Above
+      #\Arabic_Letter_Yeh_With_Hamza_Above
+      #\Arabic_Letter_Heh_Goal_With_Hamza_Above
+      #\Arabic_Letter_Yeh_Barree_With_Hamza_Above
+      #\Arabic_Letter_Heh_With_Yeh_Above)
+    ;; #\Arabic_Hamza_Below
+    #(#\Arabic_Letter_Alef_With_Hamza_Below)
+    ;; #\U+093C
+    #(#\U+0929 #\U+0931 #\U+0934)
+    ;; #\U+09BE
+    #(#\U+09CB)
+    ;; #\U+09D7
+    #(#\U+09CC)
+    ;; #\U+0B3E
+    #(#\U+0B4B)
+    ;; #\U+0B56
+    #(#\U+0B48)
+    ;; #\U+0B57
+    #(#\U+0B4C)
+    ;; #\U+0BBE
+    #(#\U+0BCA #\U+0BCB)
+    ;; #\U+0BD7
+    #(#\U+0B94 #\U+0BCC)
+    ;; #\U+0C56
+    #(#\U+0C48)
+    ;; #\U+0CC2
+    #(#\U+0CCA)
+    ;; #\U+0CD5
+    #(#\U+0CC0 #\U+0CC7 #\U+0CCB)
+    ;; #\U+0CD6
+    #(#\U+0CC8)
+    ;; #\U+0D3E
+    #(#\U+0D4A #\U+0D4B)
+    ;; #\U+0D57
+    #(#\U+0D4C)
+    ;; #\U+0DCA
+    #(#\U+0DDA #\U+0DDD)
+    ;; #\U+0DCF
+    #(#\U+0DDC)
+    ;; #\U+0DDF
+    #(#\U+0DDE)
+    ;; #\U+102E
+    #(#\U+1026)
+    ;; #\U+3099
+    #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056
+      #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065
+      #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C
+      #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4
+      #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2
+      #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9
+      #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE)
+    ;; #\U+309A
+    #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4
+      #\U+30D7 #\U+30DA #\U+30DD)
+    ))
+(defun search-char-vector (vector char)
+  ;; vector is a SIMPLE-VECTOR of chars sorted by char-code.
+  ;; return the index of char in vector or NIL if not found
+  (let* ((left 0)
+         (right (1- (length vector))))
+    (declare (fixnum left right))
+    (if (and (char>= char (svref vector left))
+             (char<= char (svref vector right)))
+      (do* ()
+           ((> left right))
+        (let* ((mid (ash (the fixnum (+ left right)) -1))
+               (midch (svref vector mid)))
+          (declare (fixnum mid))
+          (if (eql char midch)
+            (return mid)
+            (if (char< char midch)
+              (setq right (1- mid))
+              (setq left (1+ mid)))))))))
+(defconstant HANGUL-SBASE #xAC00)
+(defconstant HANGUL-LBASE #x1100)
+(defconstant HANGUL-VBASE #x1161)
+(defconstant HANGUL-TBASE #x11A7)
+(defconstant HANGUL-SCOUNT 11172)
+(defconstant HANGUL-LCOUNT 19)
+(defconstant HANGUL-VCOUNT 21)
+(defconstant HANGUL-TCOUNT 28)
+(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT))
+(defun combine-bmp-chars (base combiner)
+  (if (and (char>= combiner (code-char hangul-vbase))
+           (char< combiner (code-char (+ hangul-tbase hangul-tcount))))
+    (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount)))
+             (char>= base (code-char hangul-lbase))
+             (char< base (code-char (+ hangul-lbase hangul-lcount))))
+      (return-from combine-bmp-chars
+        (code-char (+ hangul-lbase
+                      (* hangul-ncount (- (char-code base) hangul-lbase))
+                      (* hangul-tcount (- (char-code combiner) hangul-vbase))))))
+    (if (and (char> combiner (code-char hangul-tbase))
+             (char>= base (code-char hangul-sbase))
+             (char< base (code-char (+ hangul-sbase hangul-scount))))
+      (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount))))
+        (return-from combine-bmp-chars nil)
+        (return-from combine-bmp-chars
+          (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase)))))))
+  (let* ((idx (search-char-vector *bmp-combining-chars* combiner))
+         (base-table (if idx (svref *bmp-combining-base-chars* idx))))
+    (if base-table
+      (let* ((combined-idx (search-char-vector base-table base)))
+        (if combined-idx
+          (svref (svref *bmp-precombined-chars* idx) combined-idx))))))
+(defun precompose-simple-string (s)
+  (let* ((n (length s)))
+    (or (dotimes (i n s)
+          (when (is-combinable (schar s i))
+            (return nil)))
+        (let* ((new (make-string n)))
+          (declare (dynamic-extent new))
+          (do* ((i 0 (1+ i))
+                (nout -1)
+                (lastch nil))
+               ((= i n) (subseq new 0 (1+ nout)))
+            (declare (fixnum nout i))
+            (let* ((ch (schar s i)))
+              (if (or (not lastch)
+                      (not (is-combinable ch)))
+                (setf lastch ch
+                      (schar new (incf nout)) ch)
+                (let* ((combined (combine-bmp-chars lastch ch)))
+                  (if combined
+                    (setf (schar new nout) (setq lastch combined))
+                    (setf lastch ch
+                      (schar new (incf nout)) ch))))))))))

branches/working-0711/ccl/level-1/linux-files.lisp

-                      r7517
+                      r7624
+  )
+(defun get-foreign-namestring (pointer)
+  ;; On Darwin, foreign namestrings are encoded in UTF-8 and
+  ;; are canonically decomposed (NFD).  Use PRECOMPOSE-SIMPLE-STRING
+  ;; to ensure that the string is "precomposed" (NFC), like the
+  ;; rest of the world and most sane people would expect.
+  #+darwin-target
+  (precompose-simple-string (%get-utf-8-cstring pointer))
+  ;; On some other platforms, the namestring is assumed to
+  ;; be encoded according to the current locale's character
+  ;; encoding (though FreeBSD seems to be moving towards
+  ;; precomposed UTF-8.).
+  ;; In any case, the use if %GET-CSTRING here is wrong ...
+  #-darwin-target
+  (%get-cstring pointer))
 (defun nanoseconds (n)
 …
                      ((< len bufsize)
                       (setf (%get-unsigned-byte buf len) 0)
                       (values (%get-cstring buf) len))
+                      (values (get-foreign-namestring buf) len))
                      (t (values nil len)))))))
     (do* ((string nil)
 …
 (defun %chdir (dirname)
   (with-cstrs ((dirname dirname))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname))
     (syscall syscalls::chdir dirname)))
 (defun %mkdir (name mode)
   (let* ((last (1- (length name))))
     (with-cstrs ((name name))
       (when (and (>= last 0)
                  (eql (%get-byte name last) (char-code #\/)))
         (setf (%get-byte name last) 0))
     (syscall syscalls::mkdir name mode))))
+  (let* ((name name)
+         (len (length name)))
+    (when (and (> len 0) (eql (char name (1- len)) #\/))
+      (setq name (subseq name 0 (1- len))))
+    (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name))
+      (syscall syscalls::mkdir name mode))))
 (defun %rmdir (name)
   (let* ((last (1- (length name))))
     (with-cstrs ((name name))
+    (#+darwin-target with-utf8-cstrs #-darwin-target with-cstrs ((name name))
       (when (and (>= last 0)
                  (eql (%get-byte name last) (char-code #\/)))
         (setf (%get-byte name last) 0))
     (syscall syscalls::rmdir name))))
 (defun getenv (key)
 …
 (defun %%stat (name stat)
   (with-cstrs ((cname name))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
     (%stat-values
      #+linux-target
 …
 (defun %%lstat (name stat)
   (with-cstrs ((cname name))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
     (%stat-values
      #+linux-target
 …
     (setq namestring (current-directory-name)))
   (%stack-block ((resultbuf #$PATH_MAX))
     (with-cstrs ((name (tilde-expand namestring)))
+    (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#))
       (let* ((result (#_realpath name resultbuf)))
         (declare (dynamic-extent result))
         (unless (%null-ptr-p result)
           (%get-cstring result))))))
+          (get-foreign-namestring result))))))
 ;;; Return fully resolved pathname & file kind, or (values nil nil)
 …
 (defun %utimes (namestring)
   (with-cstrs ((cnamestring namestring))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring))
     (let* ((err (#_utimes cnamestring (%null-ptr))))
       (declare (fixnum err))
 …
 (defun %open-dir (namestring)
   (with-cstrs ((name namestring))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring))
     (let* ((DIR (#_opendir name)))
       (unless (%null-ptr-p DIR)
 …
 (defun %read-dir (dir)
   (let* ((res (#_readdir dir)))
     (unless (%null-ptr-p res)
       (%get-cstring (pref res :dirent.d_name)))))
+    (unless (%null-ptr-p res)
+      (get-foreign-namestring (pref res :dirent.d_name)))))
 (defun tcgetpgrp (fd)
 …
         (let* ((err (#_getpwuid_r userid pwd buf buflen result)))
           (if (eql 0 err)
             (return (%get-cstring (pref pwd :passwd.pw_dir)))
+            (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
             (unless (eql err #$ERANGE)
               (return nil))))))))
 …
+#+linux-target
+(defun pipe ()
+  (%stack-block ((pipes 8))
+    (let* ((status (syscall syscalls::pipe pipes)))
+      (if (= 0 status)
+        (values (%get-long pipes 0) (%get-long pipes 4))
+        (%errno-disp status)))))
 ;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
 ;;; Use libc's interface.
-#+(or darwin-target freebsd-target)
 (defun pipe ()
+  ;;  (rlet ((filedes (:array :int 2)))
   (%stack-block ((filedes 8))
+    (let* ((status (#_pipe filedes)))
+    (let* ((status (#_pipe filedes))
+           (errno (if (eql status 0) 0 (%get-errno))))
+      (unless (zerop status)
+        (when (or (eql errno (- #$EMFILE))
+                  (eql errno (- #$ENFILE)))
+          (gc)
+          (drain-termination-queue)
+          (setq status (#_pipe filedes)
+                errno (if (zerop status) 0 (%get-errno)))))
       (if (zerop status)
         (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
         (%errno-disp (%get-errno))))))
+        (%errno-disp errno)))))
 …
                                   :element-type element-type
                                   :interactive nil
+                                  :basic t)
+                                  :basic t
+                                  :auto-close t)
                   (cons read-pipe close-in-parent)
                   (cons write-pipe close-on-error)))
 …
                                   :element-type element-type
                                   :interactive nil
+                                  :basic t)
+                                  :basic t
+                                  :auto-close t)
                   (cons write-pipe close-in-parent)
                   (cons read-pipe close-on-error)))
 …
   (if (eql 1 (cpu-count))
     (%defglobal '*spin-lock-tries* 1)
+    (%defglobal '*spin-lock-tries* 1024)))
+    (%defglobal '*spin-lock-tries* 1024))
+  (%defglobal '*spin-lock-timeouts* 0))
 (defun yield ()

branches/working-0711/ccl/level-1/sysutils.lisp

-                      r7247
+                      r7624
     (%kernel-restart $xwrongtype arg type)))
 ; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
+;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
 (defun %require-type (arg predsym)
     (if (funcall predsym arg)
+  (if (funcall predsym arg)
     arg
     (%kernel-restart $xwrongtype arg `(satisfies ,predsym))))
+    (%kernel-restart $xwrongtype arg (type-for-predicate predsym))))
 (defun %require-type-builtin (arg type-cell)
 …
+;;; In lieu of an inverted mapping, at least try to find cases involving
+;;; builtin numeric types and predicates associated with them.
+(defun type-for-predicate (pred)
+  (or (block find
+        (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype)
+                                                   (eq (numeric-ctype-predicate ctype)
+                                                       pred))
+                                          (return-from find type)))
+                 *builtin-type-info*))
+      `(satisfies ,pred)))

branches/working-0711/ccl/lib/backtrace.lisp

-                      r7594
+                      r7624
               value)))))))
+;;; Returns non-nil on success (not newval)
+(defun set-map-entry-value (context cfp lfun pc idx newval)
+  (declare (fixnum pc idx))
+  (let* ((unavailable (cons nil nil))
+         (value (map-entry-value context cfp lfun pc idx unavailable)))
+    (if (eq value unavailable)
+      nil
+      (if (typep value 'value-cell)
+        (progn (setf (uvref value 0) newval) t)
+        (let* ((addrs (cdr (function-symbol-map lfun)))
+               (addr (svref addrs (the fixnum (* 3 idx)))))
+          (declare (fixnum  addr))
+          (if (= #o77 (ldb (byte 6 0) addr))
+            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
+            (set-register-argument-value context cfp addr newval))
+          t)))))
 (defun argument-value (context cfp lfun pc name &optional (quote t))
   (declare (fixnum pc))
 …
 (defun raw-frame-ref (cfp context index bad)
   (%raw-frame-ref cfp context index bad))
+(defun raw-frame-set (cfp context index new)
+  (%raw-frame-set cfp context index new))
 (defun find-register-argument-value (context cfp regval bad)
   (%find-register-argument-value context cfp regval bad))
+(defun set-register-argument-value (context cfp regval newval)
+  (%set-register-argument-value context cfp regval newval))
 …
                   (push i indices)
                   (push (svref names i) vars))))))))))
+(defun arg-value (context cfp lfun pc unavailable name)
+  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
+    (multiple-value-bind (valid req opt rest keys)
+        (arg-names-from-map lfun pc)
+      (if valid
+        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
+               (pos (position name vars)))
+          (if (and pos (< pos nargs))
+            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
+            unavailable))
+        unavailable))))
+(defun local-value (context cfp lfun pc unavailable name)
+  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
+    (multiple-value-bind (valid req opt rest keys)
+        (arg-names-from-map lfun pc)
+      (if valid
+        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
+               (names (nthcdr nargs vars))
+               (indices (nthcdr nargs map-indices))
+               (pos (if (typep name 'unsigned-byte)
+                      name
+                      (position name names :from-end t))))
+          (if (and pos (< pos nargs))
+            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
+            unavailable))
+        unavailable))))
+(defun set-arg-value (context cfp lfun pc name new)
+  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
+    (multiple-value-bind (valid req opt rest keys)
+        (arg-names-from-map lfun pc)
+      (if valid
+        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
+               (pos (position name vars)))
+          (when (and pos (< pos nargs))
+            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
+(defun set-local-value (context cfp lfun pc name new)
+  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
+    (multiple-value-bind (valid req opt rest keys)
+        (arg-names-from-map lfun pc)
+      (if valid
+        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
+               (names (nthcdr nargs vars))
+               (indices (nthcdr nargs map-indices))
+               (pos (if (typep name 'unsigned-byte)
+                      name
+                      (position name names :from-end t))))
+          (if (and pos (< pos nargs))
+            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
 (defun arguments-and-locals (context cfp lfun pc &optional unavailable)
 …
       (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
         (setq oldest db)))))
+(defun (setf oldest-binding-frame-value) (new context frame)
+  (let* ((oldest nil)
+         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
+    (do* ((db (db-link context) (%fixnum-ref db 0)))
+         ((eq frame db)
+          (if oldest
+            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
+            (let* ((symbol (binding-index-symbol binding-index)))
+              (if context
+                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
+                (%set-sym-value symbol new)))))
+      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
+        (setq oldest db)))))

branches/working-0711/ccl/lib/ccl-export-syms.lisp

-                      r7330
+                      r7624
      ensure-class-using-class
      ensure-generic-function-using-class
+     eql-specializer
      eql-specializer-object
      extract-lambda-list
 …
      specializer-direct-generic-functions
      copy-instance
+     override-one-method-one-arg-dcode
+     optimize-generic-function-dispatching
      ;; Not MOP
 …
    "ENSURE-CLASS-USING-CLASS"
    "ENSURE-GENERIC-FUNCTION-USING-CLASS"
+   "EQL-SPECIALIZER"
    "EQL-SPECIALIZER-OBJECT"
    "EXTRACT-LAMBDA-LIST"

branches/working-0711/ccl/lib/compile-ccl.lisp

r6979	r7624
193	193	arglist
194	194	edit-callers
195		~~hash-cons~~
196	195	describe
197	196	asdf

branches/working-0711/ccl/lib/describe.lisp

-                      r7554
+                      r7624
                                      *backtrace-internal-functions*))
    (break-condition :accessor break-condition
+                    :initarg :break-condition)))
+                    :initarg :break-condition)
+   (unavailable-value-marker :initform (cons nil nil)
+                             :accessor unavailable-value-marker)))
 …
 (defmethod compute-frame-info ((f error-frame) n)
   (let* ((frame (svref (addresses f) n))
+         (context (context f)))
+         (context (context f))
+         (marker (unavailable-value-marker f)))
     (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame)
       (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc)
+      (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker)
         (list (ccl::arglist-from-map lfun) args locals)))))

branches/working-0711/ccl/lib/foreign-types.lisp

r6503	r7624
1700	1700	(canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
1701	1701	(canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
	1702	(canonicalize-foreign-type-ordinal '(:array :int 2))
1702	1703	)))
1703	1704

branches/working-0711/ccl/lib/hash.lisp

-                      r2584
+                      r7624
             ':test (hash-table-test table)
             (hash-table-count table)
+            (hash-table-size table))))
+            (hash-table-size table))
+    (when (readonly-hash-table-p table)
+      (format stream " (Readonly)"))))
 …
 (defun start-hash-table-iterator (hash state)
   (let (vector)
+  (let (vector locked)
     (unless (hash-table-p hash)
       (setf (hti.hash-table state) nil)         ; for finish-hash-table-iterator
 …
     (without-interrupts
      (setf (hti.hash-table state) hash)
      (lock-hash-table hash)
      (%lock-gc-lock)
+     (setf (hti.lock state) (setq locked (not (eq :readonly (lock-hash-table-for-map hash)))))
+     (when locked (%lock-gc-lock))
      (setq vector (nhash.vector hash))
      (setf (hti.vector state) vector)
 …
 (defun finish-hash-table-iterator (state)
   (without-interrupts
+   (let ((hash (hti.hash-table state)))
+   (let ((hash (hti.hash-table state))
+         (locked (hti.lock state)))
      (when hash
        (setf (hti.hash-table state) nil)
+       (unlock-hash-table hash)
+       (%unlock-gc-lock)
+       (when locked
+         (unlock-hash-table hash nil)
+         (%unlock-gc-lock))
        (when (eq state (nhash.iterator hash))
          (setf (nhash.iterator hash) (hti.prev-iterator state)))

branches/working-0711/ccl/lib/macros.lisp

-                      r7449
+                      r7624
        ,@body)))
+(defmacro with-self-bound-io-control-vars (&body body)
+  `(let (
+         (*print-array* *print-array*)
+         (*print-base* *print-base*)
+         (*print-case* *print-case*)
+         (*print-circle* *print-circle*)
+         (*print-escape* *print-escape*)
+         (*print-gensym* *print-gensym*)
+         (*print-length* *print-length*)
+         (*print-level* *print-level*)
+         (*print-lines* *print-lines*)
+         (*print-miser-width* *print-miser-width*)
+         (*print-pprint-dispatch* *print-pprint-dispatch*)
+         (*print-pretty* *print-pretty*)
+         (*print-radix* *print-radix*)
+         (*print-readably* *print-readably*)
+         (*print-right-margin* *print-right-margin*)
+         (*read-base* *read-base*)
+         (*read-default-float-format* *read-default-float-format*)
+         (*read-eval* *read-eval*)
+         (*read-suppress* *read-suppress*)
+         (*readtable* *readtable*))
+     ,@body))
 (defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms)
   "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
 …
                 `(%cstr-pointer ,strname ,sym))
              ,@body))))))
+(defmacro with-utf-8-cstr ((sym str) &body body)
+  (let* ((data (gensym))
+         (offset (gensym))
+         (string (gensym))
+         (len (gensym))
+         (noctets (gensym))
+         (end (gensym)))
+    `(let* ((,string ,str)
+            (,len (length ,string)))
+      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
+        (let* ((,end (+ ,offset ,len))
+               (,noctets (utf-8-octets-in-string ,data ,offset ,end)))
+          (%stack-block ((,sym (1+ ,noctets)))
+            (utf-8-memory-encode ,data ,sym 0 ,offset ,end)
+            (setf (%get-unsigned-byte ,sym ,noctets) 0)
+            ,@body))))))
 …
         (setf (,accessor ,dst ,i) (,accessor ,src ,i))))))
+(defmacro assert-pointer-type (pointer type)
+  "Assert that the pointer points to an instance of the specified foreign type.
+Return the pointer."
+  (let* ((ptr (gensym)))
+    `(let* ((,ptr ,pointer))
+      (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type))))
+      ,ptr)))
 …
       ,@body)
     (%unlock-gc-lock)))
+(defmacro with-deferred-gc (&body body)
+  "Execute BODY without responding to the signal used to suspend
+threads for GC.  BODY must be very careful not to do anything which
+could cause an exception (note that attempting to allocate lisp memory
+may cause an exception.)"
+  `(let* ((*interrupt-level* -2))
+    ,@body))
+(defmacro allowing-deferred-gc (&body body)
+  "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC."
+  `(let* ((*interrupt-level* -1))
+    (%check-deferred-gc)
+    ,@body))
 (defmacro with-pointer-to-ivector ((ptr ivector) &body body)

branches/working-0711/ccl/lib/misc.lisp

-                      r7278
+                      r7624
             (when (and line (parse-integer line :junk-allowed t) )
               (return-from local-svn-revision line)))))))))
+;;; Scan the heap, collecting infomation on the primitive object types
+;;; found.  Report that information.
+(defun heap-utilization (&key (stream *debug-io*)
+                              (gc-first t))
+  (let* ((nconses 0)
+         (nvectors (make-array 256))
+         (vector-sizes (make-array 256))
+         (array-size-function (arch::target-array-data-size-function
+                               (backend-target-arch *host-backend*))))
+    (declare (type (simple-vector 256) nvectors vector-sizes)
+             (dynamic-extent nvectors vector-sizes))
+    (when gc-first (gc))
+    (%map-areas (lambda (thing)
+                  (if (consp thing)
+                    (incf nconses)
+                    (let* ((typecode (typecode thing)))
+                      (incf (aref nvectors typecode))
+                      (incf (aref vector-sizes typecode)
+                            (funcall array-size-function typecode (uvsize thing)))))))
+    (report-heap-utilization stream nconses nvectors vector-sizes)
+    (values)))
+#+x8664-target
+(progn
+  (defvar *x8664-vector-type-names*
+    (let* ((a (make-array 256)))
+      (dotimes (i 256 a)
+        (let* ((fulltag (logand i x8664::fulltagmask))
+               (names-vector
+                (cond ((= fulltag x8664::fulltag-nodeheader-0)
+                       *nodeheader-0-types*)
+                      ((= fulltag x8664::fulltag-nodeheader-1)
+                       *nodeheader-1-types*)
+                      ((= fulltag x8664::fulltag-immheader-0)
+                       *immheader-0-types*)
+                      ((= fulltag x8664::fulltag-immheader-1)
+                       *immheader-1-types*)
+                      ((= fulltag x8664::fulltag-immheader-2)
+                       *immheader-2-types*)))
+               (name (if names-vector
+                       (aref names-vector (ash i -4)))))
+          ;; Special-case a few things ...
+          (if (eq name 'symbol-vector)
+            (setq name 'symbol)
+            (if (eq name 'function-vector)
+              (setq name 'function)))
+          (setf (aref a i) name)))))
+(defun report-heap-utilization (out nconses nvectors vector-sizes)
+  (format out "~&Object type~42tCount~50tTotal Size in Bytes")
+  (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size))
+  (dotimes (i (length nvectors))
+    (let* ((count (aref nvectors i))
+           (sizes (aref vector-sizes i)))
+      (unless (zerop count)
+        (format out "~&~a~36t~12d~48t~16d" (aref *x8664-vector-type-names* i)  count sizes)))))
+)
+#-x8664-target
+(eval-when (:compile-toplevel)
+  (warn "Need PPC versions of REPORT-HEAP-UTILIZATION"))

branches/working-0711/ccl/lib/numbers.lisp

-                      r6012
+                      r7624
 (defparameter a-short-float 1.0s0)
+#+32-bit-target
 (defmethod print-object ((rs random-state) stream)
   (format stream "#.(~S ~S ~S)"         ;>> #.GAG!!!
           'ccl::initialize-random-state
+          (%svref rs 1)
+          (%svref rs 2)))
+          (random.seed-1 rs)
+          (random.seed-2 rs)))
+#+64-bit-target
+(defmethod print-object ((rs random-state) stream)
+  (let* ((s1 (random.seed-1 rs)))
+    (format stream "#.(~S ~S ~S)"       ;>> #.GAG!!!
+            'ccl::initialize-random-state
+            (ldb (byte 16 16) s1)
+            (ldb (byte 16 0) s1))))

branches/working-0711/ccl/lib/ppc-backtrace.lisp

-                      r6925
+                      r7624
     (get-register-value nil last-catch index)))
+(defun %set-register-argument-value (context cfp regval new)
+  (let* ((last-catch (last-catch-since cfp context))
+         (index (register-number->saved-register-index regval)))
+    (do* ((frame cfp
+                 (child-frame frame context))
+          (first t))
+         ((null frame))
+      (if (fake-stack-frame-p frame)
+        (return-from %set-register-argument-value
+          (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new))
+        (if first
+          (setq first nil)
+          (multiple-value-bind (lfun pc)
+              (cfp-lfun frame)
+            (when lfun
+              (multiple-value-bind (mask where)
+                  (registers-used-by lfun pc)
+                (when (if mask (logbitp index mask))
+                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
+                  (return-from
+                   %set-register-argument-value
+                    (raw-frame-set frame context where new)))))))))
+    (set-register-value new nil last-catch index)))
 (defun %raw-frame-ref (cfp context idx bad)
   (declare (fixnum idx))
 …
         bad))))
+(defun %raw-frame-set (cfp context idx new)
+  (declare (fixnum idx))
+  (multiple-value-bind (frame base)
+      (vsp-limits cfp context)
+    (let* ((raw-size (- base frame)))
+      (declare (fixnum frame base raw-size))
+      (if (and (>= idx 0)
+               (< idx raw-size))
+        (let* ((addr (- (the fixnum (1- base))
+                        idx)))
+          (multiple-value-bind (db-count first-db last-db)
+              (count-db-links-in-frame frame base context)
+            (let* ((is-db-link
+                    (unless (zerop db-count)
+                      (do* ((last last-db (previous-db-link last first-db)))
+                           ((null last))
+                        (when (= addr last)
+                          (return t))))))
+              (if is-db-link
+                (setf (oldest-binding-frame-value context addr) new)
+                (setf (%fixnum-ref addr) new))))
+          t)))))
 ;;; Used for printing only.
 (defun index->address (p)

branches/working-0711/ccl/lib/systems.lisp

-                      r5738
+                      r7624
     (edit-callers          "ccl:bin;edit-callers"   ("ccl:lib;edit-callers.lisp"))
     (hash-cons        "ccl:library;hash-cons"    ("ccl:library;hash-cons.lisp"))
 ; (step             "ccl:bin;step"           ("ccl:lib;step.lisp"))
+    ;; (hash-cons        "ccl:library;hash-cons"    ("ccl:library;hash-cons.lisp"))
+    ;; (step             "ccl:bin;step"           ("ccl:lib;step.lisp"))
     (ccl-export-syms  "ccl:bin;ccl-export-syms"  ("ccl:lib;ccl-export-syms.lisp"))
     (systems          "ccl:bin;systems"        ("ccl:lib;systems.lisp"))

branches/working-0711/ccl/lib/x86-backtrace.lisp

-                      r7224
+                      r7624
       bad)))
+(defun %raw-frame-set (frame context idx new)
+  (declare (fixnum frame idx))
+  (let* ((base (parent-frame frame context))
+         (raw-size (- base frame)))
+    (declare (fixnum base raw-size))
+    (if (and (>= idx 0)
+             (< idx raw-size))
+      (let* ((addr (- (the fixnum (1- base))
+                      idx)))
+        (multiple-value-bind (db-count first-db last-db)
+            (count-db-links-in-frame frame base context)
+          (let* ((is-db-link
+                  (unless (zerop db-count)
+                    (do* ((last last-db (previous-db-link last first-db)))
+                         ((null last))
+                      (when (= addr last)
+                        (return t))))))
+            (if is-db-link
+              (setf (oldest-binding-frame-value context addr) new)
+              (setf (%fixnum-ref addr) new))))))))
 (defun %stack< (index1 index2 &optional context)
   (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
 …
     (get-register-value nil last-catch index)))
+(defun %set-register-argument-value (context cfp regval new)
+  (let* ((last-catch (last-catch-since cfp context))
+         (index (register-number->saved-register-index regval)))
+    (do* ((frame cfp (child-frame frame context))
+          (first t))
+         ((null frame))
+      (if (xcf-p frame)
+        (with-macptrs (xp)
+          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
+          (return-from %set-register-argument-value
+            (setf (encoded-gpr-lisp xp regval) new)))
+        (progn
+          (unless first
+            (multiple-value-bind (lfun pc)
+                (cfp-lfun frame)
+              (when lfun
+                (multiple-value-bind (mask where)
+                    (registers-used-by lfun pc)
+                  (when (if mask (logbitp index mask))
+                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
+                    (return-from %set-register-argument-value
+                      (raw-frame-set frame context where new)))))))
+          (setq first nil))))
+    (set-register-value new nil last-catch index)))
 ;;; Used for printing only.
 (defun index->address (p)

branches/working-0711/ccl/library/lispequ.lisp

r6913	r7624
1223	1223	nhash.find ; function: find vector-index
1224	1224	nhash.find-new ; function: find vector-index on put
	1225	nhash.read-only ; boolean: true when read-only
1225	1226	)
1226	1227

branches/working-0711/ccl/library/x8664-linux-syscalls.lisp

r4052	r7624
150	150
151	151
	152	(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::futex 202 (:address :signed-fullword :signed-fullword :address :address :signed-fullword) :signed-fullword )
152	153
153	154	#+notdefinedyet

branches/working-0711/ccl/lisp-kernel/Threads.h

-                      r6260
+                      r7624
 #include "gc.h"
+#ifdef USE_FUTEX
+#include <linux/futex.h>
+#include <sys/syscall.h>
+#endif
+#include <syslog.h>
 Boolean extern threads_initialized;
+Boolean extern log_tcr_info;
+#define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr)
+#define RELEASE_SPINLOCK(x) (x)=0
 #define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS))
 …
 #define SEM_WAIT(s) sem_wait((SEMAPHORE)s)
 #define SEM_RAISE(s) sem_post((SEMAPHORE)s)
+#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0)
 #define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t)
 #endif
 …
 #define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s)
 #define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s)
+#define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s)
 #define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t)
 #endif
 …
 Boolean resume_tcr(TCR *);
-typedef struct _rwquentry
+{
-  struct _rwquentry *prev;
-  struct _rwquentry *next;
-  TCR *tcr;
-  int count;
-} rwquentry;
 typedef struct
+{
+  rwquentry head;
+  int state;                    /* sum of all counts on queue */
+  pthread_mutex_t *lock;        /* lock access to this data structure */
+  pthread_cond_t *reader_signal;
+  pthread_cond_t *writer_signal;
+  int write_wait_count;
+  int read_wait_count;
+  int dying;
+  rwquentry freelist;
+  signed_natural spin; /* need spin lock to change fields */
+  signed_natural state; /* 0 = free, positive if writer, negative if readers; */
+  natural blocked_writers;
+  natural blocked_readers;
+  TCR  *writer;
+#ifdef USE_FUTEX
+  natural reader_signal;
+  natural writer_signal;
+#else
+  void * reader_signal;
+  void * writer_signal;
+#endif
+  void *malloced_ptr;
 } rwlock;
-#define RWLOCK_WRITER(rw) rw->head.tcr
-#define RWLOCK_WRITE_COUNT(rw) rw->head.count
 rwlock * rwlock_new(void);
 int rwlock_destroy(rwlock *);
+void rwlock_destroy(rwlock *);
 int rwlock_rlock(rwlock *, TCR *, struct timespec *);
 int rwlock_wlock(rwlock *, TCR *, struct timespec *);
 int rwlock_try_wlock(rwlock *, TCR *);
+int rwlock_try_rlock(rwlock *, TCR *);
 int rwlock_unlock(rwlock *, TCR *);

branches/working-0711/ccl/lisp-kernel/errors.s

r6899	r7624
25	25	error_excised_function_call = 6
26	26	error_too_many_values = 7
	27	error_propagate_suspend = 10
27	28	error_cant_call = 17
28	29

branches/working-0711/ccl/lisp-kernel/gc.h

-                      r7137
+                      r7624
 #define GC_TRAP_FUNCTION_EGC_CONTROL 32
 #define GC_TRAP_FUNCTION_CONFIGURE_EGC 64
+#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128
+#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 /* deprecated */
+#define GC_TRAP_FUNCTION_FREEZE 129
+#define GC_TRAP_FUNCTION_THAW 130
 #endif                          /* __GC_H__ */

branches/working-0711/ccl/lisp-kernel/image.c

-                      r6215
+                      r7624
     a->static_dnodes = sect->static_dnodes;
-    if (a->static_dnodes) {
-      natural pages_size = (align_to_power_of_2((align_to_power_of_2(a->static_dnodes,
-                                                                     log2_nbits_in_word)>>3),
-                                                log2_page_size));
-      lseek(fd,pos+mem_size, SEEK_SET);
-      pos = seek_to_next_page(fd);
-      addr = mmap(NULL,
-                  pages_size,
-                  PROT_READ | PROT_WRITE,
-                  MAP_PRIVATE,
-                  fd,
-                  pos);
-      if (addr == MAP_FAILED) {
-        return;
+      }
-      a->static_used = addr;
-      advance = pages_size;
+    }
     sect->area = a;
     break;
 …
 #endif
   areas[0] = readonly_area;
   areas[1] = nilreg_area;
   areas[2] = active_dynamic_area;
+  areas[0] = nilreg_area;
+  areas[1] = active_dynamic_area;
+  areas[2] = readonly_area;
   areas[3] = managed_static_area;
   for (i = 0; i < NUM_IMAGE_SECTIONS; i++) {
 …
     case FWDNUM:
     case GC_NUM:
     case DELETED_STATIC_PAIRS:
+    case STATIC_CONSES:
       break;
     default:
 …
         return errno;
+      }
-      if (nstatic) {
-        /* Need to write the static_used bitmap */
-        natural static_used_size_in_bytes =
-          (align_to_power_of_2((align_to_power_of_2(nstatic, log2_nbits_in_word)>>3),
-                               log2_page_size));
-        seek_to_next_page(fd);
-        if (write(fd, tenured_area->static_used, static_used_size_in_bytes)
-            != static_used_size_in_bytes) {
-          return errno;
+        }
+      }
+    }
+  }

branches/working-0711/ccl/lisp-kernel/lisp-errors.h

-                      r5529
+                      r7624
 #define __ERRORS_X 1
-/*
-/22/96 bill error_too_many_values
---- 4.0 ---
-/12/96  gb  conditionalize on __ERRORS_X to avoid conflict with <errors.h>
---- 3.9 ---
-/10/96  gb  error_memory_full
-/09/96  gb  error_excised_function_call
-/01/96  gb  FPU exceptions
-/22/96  gb  add/rename error_alloc_failed, error_stack_overflow
-/13/95  gb  add error_alloc_fail, error_throw_tag_missing.
-/09/95  gb  in synch with %type-error-types%.
-*/
 #define error_reg_regnum 0
 …
 #define error_excised_function_call 6
 #define error_too_many_values 7
+#define error_propagate_suspend 10
 #define error_cant_call 17

branches/working-0711/ccl/lisp-kernel/lisp_globals.h

r6901	r7624
33	33	#define TCR_AREA_LOCK (-11) /* all_areas/tcr queue lock */
34	34	#define EXCEPTION_LOCK (-12) /* serialize exception handling */
35		#define ~~DELETED_STATIC_PAIRS (-13) /* for hash-consing */~~
	35	#define STATIC_CONSES (-13)
36	36	#define DEFAULT_ALLOCATION_QUANTUM (-14)
37	37	#define INTFLAG (-15)

branches/working-0711/ccl/lisp-kernel/ppc-constants.h

r3493	r7624
68	68	#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4)
69	69	#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5)
	70	#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6)
	71	#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7)
70	72
71	73	#define TCR_STATE_FOREIGN (1)

branches/working-0711/ccl/lisp-kernel/ppc-constants32.s

-                      r5783
+                      r7624
 TCR_FLAG_BIT_FOREIGN = fixnum_shift
 TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
+TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2)
+TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3)
+TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4)
+TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5)
+TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6)
+TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7)
 r0 = 0

branches/working-0711/ccl/lisp-kernel/ppc-constants64.s

-                      r5783
+                      r7624
 TCR_FLAG_BIT_FOREIGN = fixnum_shift
+TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
+TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
+TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2)
+TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3)
+TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4)
+TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5)
+TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6)
+TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7)

branches/working-0711/ccl/lisp-kernel/ppc-exceptions.c

-                      r7137
+                      r7624
   case UUO_INTERR:
+    status = handle_error(xp, errnum, rb, 0,  where);
+    if (errnum == error_propagate_suspend) {
+      status = 0;
+    } else {
+      status = handle_error(xp, errnum, rb, 0,  where);
+    }
     break;
 …
     old_valence = prepare_to_wait_for_exception_lock(tcr, context);
+  }
+  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
+    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
+    pthread_kill(pthread_self(), thread_suspend_signal);
+  }
   wait_for_exception_lock_in_handler(tcr, context, &xframe_link);

branches/working-0711/ccl/lisp-kernel/ppc-gc.c

r7137	r7624
1597	1597
1598	1598	case xmacptr_flag_rwlock:
	1599	rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
1599	1600	break;
1600	1601

branches/working-0711/ccl/lisp-kernel/ppc-macros.s

-                      r6515
+                      r7624
 define([aligned_bignum_size],[((~(dnode_size-1)&(node_size+(dnode_size-1)+(4*$1))))])
+define([suspend_now],[
+        uuo_interr(error_propagate_suspend,rzero)
+])

branches/working-0711/ccl/lisp-kernel/ppc-spentry.s

-                      r6903
+                      r7624
 /* any interrupt polling  */
+_spentry(unbind_interrupt_level)
+        __(ldr(imm2,tcr.tlb_pointer(rcontext)))
+_spentry(unbind_interrupt_level)
+        __(ldr(imm0,tcr.flags(rcontext)))
+        __(ldr(imm2,tcr.tlb_pointer(rcontext)))
+        __(andi. imm0,imm0,1<<TCR_FLAG_BIT_PENDING_SUSPEND)
         __(ldr(imm1,tcr.db_link(rcontext)))
         __(ldr(temp1,INTERRUPT_LEVEL_BINDING_INDEX(imm2)))
+        __(cmpri(cr1,temp1,0))
+        __(bne 5f)
+:      __(cmpri(cr1,temp1,0))
         __(ldr(temp1,binding.val(imm1)))
         __(ldr(imm1,binding.link(imm1)))
 …
         __(mr nargs,imm2)
         __(blr)
+:       /* Missed a suspend request; force suspend now if we're restoring
+          interrupt level to -1 or greater */
+        __(cmpri(temp1,-2<<fixnumshift))
+        __(bne 0b)
+        __(ldr(imm0,binding.val(imm1)))
+        __(cmpr(imm0,temp1))
+        __(beq 0b)
+        __(li imm0,1<<fixnumshift)
+        __(str(imm0,INTERRUPT_LEVEL_BINDING_INDEX(imm2)))
+        __(suspend_now())
+        __(b 0b)
 /* arg_x = array, arg_y = i, arg_z = j. Typecheck everything.

branches/working-0711/ccl/lisp-kernel/thread_manager.c

<

-                      r6904
+                      r7624
 atomic_swap(signed_natural*, signed_natural);
+#ifdef USE_FUTEX
+#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val)
+#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n)
+#define FUTEX_AVAIL (0)
+#define FUTEX_LOCKED (1)
+#define FUTEX_CONTENDED (2)
+#endif
 int
 …
+#ifndef USE_FUTEX
 int spin_lock_tries = 1;
 …
+  }
+}
+#endif
+#ifndef USE_FUTEX
 int
 lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
 …
+  }
   while (1) {
     get_spin_lock(&(m->spinlock),tcr);
+    LOCK_SPINLOCK(m->spinlock,tcr);
     ++m->avail;
     if (m->avail == 1) {
       m->owner = tcr;
       m->count = 1;
       m->spinlock = 0;
+      RELEASE_SPINLOCK(m->spinlock);
       break;
+    }
     m->spinlock = 0;
+    RELEASE_SPINLOCK(m->spinlock);
     SEM_WAIT_FOREVER(m->signal);
+  }
 …
+}
+#else /* USE_FUTEX */
+static void inline
+lock_futex(natural *p)
+{
+  while (1) {
+    if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) {
+      return;
+    }
+    while (1) {
+      if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) {
+        return;
+      }
+      futex_wait(p,FUTEX_CONTENDED);
+    }
+  }
+}
+static void inline
+unlock_futex(natural *p)
+{
+  if (atomic_decf(p) != FUTEX_AVAIL) {
+    *p = FUTEX_AVAIL;
+    futex_wake(p,INT_MAX);
+  }
+}
+int
+lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
+{
+  natural val;
+  if (tcr == NULL) {
+    tcr = get_tcr(true);
+  }
+  if (m->owner == tcr) {
+    m->count++;
+    return 0;
+  }
+  lock_futex(&m->avail);
+  m->owner = tcr;
+  m->count = 1;
+  return 0;
+}
+#endif /* USE_FUTEX */
+#ifndef USE_FUTEX
 int
 unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
 …
     --m->count;
     if (m->count == 0) {
       get_spin_lock(&(m->spinlock),tcr);
+      LOCK_SPINLOCK(m->spinlock,tcr);
       m->owner = NULL;
       pending = m->avail-1 + m->waiting;     /* Don't count us */
 …
         m->waiting = 0;
+      }
       m->spinlock = 0;
+      RELEASE_SPINLOCK(m->spinlock);
       if (pending >= 0) {
         SEM_RAISE(m->signal);
 …
   return ret;
+}
+#else /* USE_FUTEX */

Context Navigation

Legend: