Changeset 7624


Ignore:
Timestamp:
Nov 10, 2007, 5:22:11 AM (12 years ago)
Author:
gb
Message:

Merge changes form working-0710 branch.

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

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/PPC/PPC32/ppc32-arch.lisp

    r6456 r7624  
    470470  malloced-ptr
    471471  spinlock)
     472
     473(define-storage-layout rwlock 0
     474  spin
     475  state
     476  blocked-writers
     477  blocked-readers
     478  writer
     479  reader-signal
     480  writer-signal
     481  malloced-ptr
     482  )
    472483
    473484;;; 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  
    548548  malloced-ptr
    549549  spinlock)
     550
     551(define-storage-layout rwlock 0
     552  spin
     553  state
     554  blocked-writers
     555  blocked-readers
     556  writer
     557  reader-signal
     558  writer-signal
     559  malloced-ptr
     560  )
    550561
    551562;;; For the eabi port: mark this stack frame as Lisp's (since EABI
  • branches/working-0711/ccl/compiler/PPC/ppc-lapmacros.lisp

    r5096 r7624  
    175175   (:ppc32 `(slwi ,@args))
    176176   (:ppc64 `(sldi ,@args))))
     177
     178(defppclapmacro slri. (&rest args)
     179  (target-arch-case
     180   (:ppc32 `(slwi. ,@args))
     181   (:ppc64 `(sldi. ,@args))))
    177182
    178183(defppclapmacro srr (&rest args)
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-arch.lisp

    r6462 r7624  
    213213(defx86reg save3 r11)
    214214(defx86reg save3.l r11d)
    215 (defx86reg save3.w r10w)
    216 (defx86reg save3.b r10b)
     215(defx86reg save3.w r11w)
     216(defx86reg save3.b r11b)
    217217
    218218(defx86reg save2 r12)
     
    724724  malloced-ptr
    725725  spinlock)
     726
     727(define-storage-layout rwlock 0
     728  spin
     729  state
     730  blocked-writers
     731  blocked-readers
     732  writer
     733  reader-signal
     734  writer-signal
     735  malloced-ptr
     736  )
    726737
    727738(defmacro define-header (name element-count subtag)
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp

    r7376 r7624  
    489489                    (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
    490490                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
    491                     (dynamic-extent-names name))
     491                         (dynamic-extent-names name))
    492492                  (progn
    493493                    (rlets (list name (foreign-record-type-name argtype)))
     
    511511                               (:unsigned-byte '%get-unsigned-byte)
    512512                               (:address
    513                                 ;(dynamic-extent-names name)
     513                                #+nil
     514                                (dynamic-extent-names name)
    514515                                '%get-ptr))
    515516                             ,stack-ptr
  • branches/working-0711/ccl/compiler/X86/x86-arch.lisp

    r6930 r7624  
    4040    area-lock                           ; serialize access to gc
    4141    exception-lock                      ; serialize exception handling
    42     deleted-static-pairs                ; hash-consing
     42    static-conses                       ; when FREEZE is in effect
    4343    default-allocation-quantum          ; log2_heap_segment_size, as a fixnum.
    4444    intflag                             ; interrupt-pending flag
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r6996 r7624  
    826826
    827827(defun nop-fixup (ds bytemode sizeflag)
    828   (declare (ignore bytemode sizeflag))
     828  (declare (ignore bytemode sizeflag)
     829           (ignorable ds))
     830  #+nothing
    829831  (if (logtest (x86-ds-prefixes ds) +prefix-repz+)
    830832    (break "should be PAUSE")))
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r7443 r7624  
    36443644                     (case src-mode
    36453645                       (#.hard-reg-class-gpr-mode-node
    3646                         (! unbox-u32 dest src))
     3646                        (if *x862-reckless*
     3647                          (! %unbox-u32 dest src)
     3648                          (! unbox-u32 dest src)))
    36473649                       ((#.hard-reg-class-gpr-mode-u32
    36483650                         #.hard-reg-class-gpr-mode-s32)
     
    36603662                     (case src-mode
    36613663                       (#.hard-reg-class-gpr-mode-node
    3662                         (! unbox-u16 dest src))
     3664                        (if *x862-reckless*
     3665                          (! %unbox-u16 dest src)
     3666                          (! unbox-u16 dest src)))
    36633667                       ((#.hard-reg-class-gpr-mode-u8
    36643668                         #.hard-reg-class-gpr-mode-s8)
  • branches/working-0711/ccl/compiler/arch.lisp

    r5529 r7624  
    2828(defconstant tcr-flag-bit-foreign 0)
    2929(defconstant tcr-flag-bit-awaiting-preset 1)
     30(defconstant tcr-flag-bit-alt-suspend 2)
     31(defconstant tcr-flag-bit-propagate-exception 3)
     32(defconstant tcr-flag-bit-suspend-ack-pending 4)
     33(defconstant tcr-flag-bit-pending-exception 5)
     34(defconstant tcr-flag-bit-foreign-exception 6)
     35(defconstant tcr-flag-bit-pending-suspend 7)       
    3036
    3137
     
    5258(defconstant error-cant-take-car 8)
    5359(defconstant error-cant-take-cdr 9)
     60(defconstant error-propagate-suspend 10)
    5461(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
    5562(eval-when (:compile-toplevel :load-toplevel :execute)
     
    323330(defconstant gc-trap-function-configure-egc 64)
    324331(defconstant gc-trap-function-set-hons-area-size 128)
     332(defconstant gc-trap-function-freeze 129)
     333(defconstant gc-trap-function-thaw 130)
     334
    325335
    326336
  • branches/working-0711/ccl/compiler/nx1.lisp

    r6175 r7624  
    16611661     (%nx1-operator %immediate-set-xxx)
    16621662     (case op
    1663        (%%set-signed-longlong (logior 32 8))
    1664        (t 8))
     1663       (%%set-signed-longlong 8)
     1664       (t (logior 32 8)))
    16651665     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
    16661666     (nx1-form offset)
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r6473 r7624  
    135135    t))
    136136
    137 ;;; return new form if no keys (or if keys constant and specify :TEST
    138 ;;; {#'eq, #'eql} only.)
    139 (defun eq-eql-call (x l keys eq-fn  eql-fn env)
    140   (flet ((eql-to-eq ()
    141            (or (eql-iff-eq-p x env)
    142                (and (or (quoted-form-p l) (null l))
    143                     (dolist (elt (%cadr l) t)
    144                       (when (eq eq-fn 'assq) (setq elt (car elt)))
    145                       (when (and (numberp elt) (not (fixnump elt)))
    146                         (return nil)))))))
    147     (if (null keys)
    148       (list (if (eql-to-eq) eq-fn eql-fn) x l)
    149       (if (constant-keywords-p keys)
     137(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly)
     138  (if (null keys)
     139    `(,default ,item ,list)
     140     (if (constant-keywords-p keys)
    150141        (destructuring-bind (&key (test nil test-p)
    151142                                  (test-not nil test-not-p)
    152143                                  (key nil key-p))
    153144                            keys
    154           (declare (ignore test-not key))
     145          (declare (ignore test-not))
    155146          (if (and test-p
    156                    (not test-not-p)
    157                    (not key-p)
     147                   (not test-not-p)
     148                   (or (not key-p)
     149                       (and (consp key)
     150                            (consp (%cdr key))
     151                            (null (%cddr key))
     152                            (or (eq (%car key) 'function)
     153                                (eq (%car key) 'quote))
     154                            (eq (%cadr key) 'identity)))
    158155                   (consp test)
    159156                   (consp (%cdr test))
     
    161158                   (or (eq (%car test) 'function)
    162159                       (eq (%car test) 'quote)))
    163             (let ((testname (%cadr test)))
    164               (if (or (eq testname 'eq)
    165                       (and (eq testname 'eql)
    166                            (eql-to-eq)))
    167                 (list eq-fn x l)
    168                 (if (and eql-fn (eq testname 'eql))
    169                   (list eql-fn x l))))))))))
     160            (let* ((testname (%cadr test))
     161                   (reduced (cdr (assoc testname alist))))
     162              (if reduced
     163                `(,reduced ,item ,list)
     164                `(,testonly ,item ,list ,test))))))))
     165
    170166
    171167(defun eql-iff-eq-p (thing env)
     
    174170    (if (not (self-evaluating-p thing))
    175171        (return-from eql-iff-eq-p
    176                      (nx-form-typep thing
    177                                      '(or fixnum
    178                                        #+64-bit-target single-float
    179                                        character symbol
    180                                        (and (not number) (not macptr))) env))))
     172          (or (nx-form-typep thing  'symbol env)
     173              (nx-form-typep thing 'character env)
     174              (nx-form-typep thing
     175                             '(or fixnum
     176                               #+64-bit-target single-float
     177                               symbol character
     178                               (and (not number) (not macptr))) env)))))
    181179  (or (fixnump thing) #+64-bit-target (typep thing 'single-float)
     180      (symbolp thing) (characterp thing)
    182181      (and (not (numberp thing)) (not (macptrp thing)))))
     182
     183(defun equal-iff-eql-p (thing env)
     184  (if (quoted-form-p thing)
     185    (setq thing (%cadr thing))
     186    (if (not (self-evaluating-p thing))
     187      (return-from equal-iff-eql-p
     188        (nx-form-typep thing
     189                       '(and (not cons) (not string) (not bit-vector) (not pathname)) env))))
     190  (not (typep thing '(or cons string bit-vector pathname))))
     191
    183192
    184193(defun fold-constant-subforms (call env)
     
    330339
    331340
    332 (define-compiler-macro assoc (&whole call &environment env item list &rest keys)
    333   (or (eq-eql-call item list keys 'assq 'asseql env)
     341(define-compiler-macro assoc (&whole call item list &rest keys)
     342  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test)
    334343      call))
    335344
     345(define-compiler-macro assequal (&whole call &environment env item list)
     346  (if (or (equal-iff-eql-p item env)
     347          (and (quoted-form-p list)
     348               (proper-list-p (%cadr list))
     349               (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list))))
     350    `(asseql ,item ,list)
     351    call))
     352 
     353(define-compiler-macro asseql (&whole call &environment env item list)
     354  (if (or (eql-iff-eq-p item env)
     355          (and (quoted-form-p list)
     356               (proper-list-p (%cadr list))
     357               (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list))))
     358    `(assq ,item ,list)
     359    call))
     360
     361(define-compiler-macro assq (item list)
     362  (let* ((itemx (gensym))
     363         (listx (gensym))
     364         (pair (gensym)))
     365    `(let* ((,itemx ,item)
     366            (,listx ,list))
     367      (dolist (,pair ,listx)
     368        (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair))))))
    336369
    337370(define-compiler-macro caar (form)
     
    785818           (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var)))))))))
    786819
    787 (define-compiler-macro member (&whole call &environment env item list &rest keys)
    788   (or (eq-eql-call item list keys 'memq 'memeql env)
     820(define-compiler-macro member (&whole call item list &rest keys)
     821  (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test)
    789822      call))
    790823
     824(define-compiler-macro memequal (&whole call &environment env item list)
     825  (if (or (equal-iff-eql-p item env)
     826          (and (quoted-form-p list)
     827               (proper-list-p (%cadr list))
     828               (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list))))
     829    `(memeql ,item ,list)
     830    call))
     831 
     832(define-compiler-macro memeql (&whole call &environment env item list)
     833  (if (or (eql-iff-eq-p item env)
     834          (and (quoted-form-p list)
     835               (proper-list-p (%cadr list))
     836               (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list))))
     837    `(memq ,item ,list)
     838    call))
     839
    791840(define-compiler-macro memq (&whole call &environment env item list)
    792    ;(memq x '(y)) => (if (eq x 'y) '(y))
    793    ;Would it be worth making a two elt list into an OR?  Maybe if
    794    ;optimizing for speed...
     841  ;;(memq x '(y)) => (if (eq x 'y) '(y))
     842  ;;Would it be worth making a two elt list into an OR?  Maybe if
     843  ;;optimizing for speed...
    795844   (if (and (or (quoted-form-p list)
    796845                (null list))
    797846            (null (cdr (%cadr list))))
    798847     (if list `(if (eq ,item ',(%caadr list)) ,list))
    799      call))
     848     (let* ((x (gensym))
     849            (tail (gensym)))
     850       `(do* ((,x ,item)
     851              (,tail ,list (cdr (the list ,tail))))
     852         ((null ,tail))
     853         (if (eq (car ,tail) ,x) (return ,tail))))))
    800854
    801855(define-compiler-macro minusp (x)
     
    815869            (%i< count 3))
    816870     `(,(svref '#(car cadr caddr) count) ,list)
    817      call))
     871     `(car (nthcdr ,count ,list))))
    818872
    819873(define-compiler-macro nthcdr (&whole call &environment env count list)
     
    822876           (%i< count 4)) 
    823877     (if (%izerop count)
    824        list
     878       `(require-type ,list 'list)
    825879       `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list))
    826      call))
     880    (let* ((i (gensym))
     881           (n (gensym))                 ; evaluation order
     882           (tail (gensym)))
     883      `(let* ((,n (require-type ,count 'unsigned-byte))
     884              (,tail (require-type ,list 'list)))
     885        (dotimes (,i ,n ,tail)
     886          (unless (setq ,tail (cdr ,tail))
     887            (return nil)))))))
    827888
    828889(define-compiler-macro plusp (x)
     
    18141875      `(float ,thing 0.0d0)
    18151876      call)))
    1816                      
     1877
     1878(define-compiler-macro equal (&whole call x y &environment env)
     1879  (if (or (equal-iff-eql-p x env)
     1880          (equal-iff-eql-p y env))
     1881    `(eql ,x ,y)
     1882    call))
    18171883
    18181884(provide "OPTIMIZERS")
  • branches/working-0711/ccl/level-0/PPC/ppc-misc.lisp

    r7343 r7624  
    551551  (blr))
    552552
    553 ;;; Return true iff we were able to increment a non-negative
    554 ;;; lock._value
    555 (defppclapfunction %try-read-lock-rwlock ((lock arg_z))
    556   (check-nargs 1)
    557   (li imm1 target::lock._value)
    558   @try
    559   (lrarx imm0 lock imm1)
    560   (cmpri imm0 0)
    561   (blt @fail)                           ; locked for writing
    562   (addi imm0 imm0 '1)
    563   (strcx. imm0 lock imm1)
    564   (bne @try)                            ; lost reservation, try again
    565   (isync)
    566   (blr)                                 ; return the lock
    567 @fail
    568   (li imm0 target::reservation-discharge)
    569   (strcx. rzero rzero imm0)
    570   (li arg_z nil)
    571   (blr))
    572 
    573 
    574 
    575 (defppclapfunction unlock-rwlock ((lock arg_z))
    576   (ldr imm2 target::lock._value lock)
    577   (cmpri imm2 0)
    578   (li imm1 target::lock._value)
    579   (ble @unlock-write)
    580   @unlock-read
    581   (lrarx imm0 lock imm1)
    582   (subi imm0 imm0 '1)
    583   (strcx. imm0 lock imm1)
    584   (bne @unlock-read)
    585   (isync)
    586   (blr)
    587   @unlock-write
    588   ;;; If we aren't the writer, return NIL.
    589   ;;; If we are and the value's about to go to 0, clear the writer field.
    590   (ldr imm0 target::lock.writer lock)
    591   (cmpr imm0 target::rcontext)
    592   (ldrx imm0 lock imm1)
    593   (cmpri cr1 imm0 '-1)
    594   (addi imm0 imm0 '1)
    595   (bne @fail)
    596   (bne cr1 @noclear)
    597   (str rzero target::lock.writer lock)
    598   @noclear
    599   (str imm0 target::lock._value lock)
    600   (blr)
    601   @fail
    602   (li arg_z nil)
    603   (blr))
     553
    604554
    605555(defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
     
    1022972  (blr))
    1023973
     974(defppclapfunction %check-deferred-gc ()
     975  (ldr imm0 target::tcr.flags target::rcontext)
     976  (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)))
     977  (li arg_z nil)
     978  (bgelr)
     979  (uuo_interr arch::error-propagate-suspend rzero)
     980  (li arg_z t)
     981  (blr))
     982 
    1024983
    1025984; end of ppc-misc.lisp
  • branches/working-0711/ccl/level-0/X86/x86-array.lisp

    r6476 r7624  
    2626
    2727
    28 
    29 
    30 ;; rewrite in LAP someday (soon).
     28#+x8664-target
     29(progn
     30;;; None of the stores in here can be intergenerational; the vector
     31;;; is known to be younger than the initial value
     32(defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z))
     33  (jmp @test)
     34  @loop
     35  (movq (% value) (@ x8664::misc-data-offset (% vector) (% len)))
     36  @test
     37  (subq ($ x8664::fixnumone) (% len))
     38  (jns @loop)
     39  (single-value-return))
     40
     41;;; "val" is either a fixnum or a uvector with 64-bits of data
     42;;; (small bignum, DOUBLE-FLOAT).
     43(defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z))
     44  (unbox-fixnum value imm0)
     45  (testb ($ x8664::fixnummask) (%b value))
     46  (je @test)
     47  (movq (@ x8664::misc-data-offset (% value)) (% imm0))
     48  (jmp @test)
     49  @loop
     50  (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len)))
     51  @test
     52  (subq ($ x8664::fixnumone) (% len))
     53  (jns @loop)
     54  (single-value-return))
     55
     56(defun %init-ivector64 (typecode len val uvector)
     57  (declare (type (mod 256) typecode))
     58  (%%init-ivector64 len
     59                    (case typecode
     60                      (#.x8664::subtag-fixnum-vector
     61                       (require-type val 'fixnum))
     62                      (#.x8664::subtag-double-float-vector
     63                       (if (typep val 'double-float)
     64                         val
     65                         (require-type val 'double-float)))
     66                      (#.x8664::subtag-s64-vector
     67                       (require-type val '(signed-byte 64)))
     68                      (#.x8664::subtag-u64-vector
     69                       (require-type val '(unsigned-byte 64)))
     70                      (t (report-bad-arg uvector
     71                                         '(or (simple-array fixnum (*))
     72                                           (simple-array double-float (*))
     73                                           (simple-array (signed-byte 64) (*))
     74                                           (simple-array (unsigned-byte 64) (*))))))
     75                    uvector))
     76 
     77
     78(eval-when (:compile-toplevel :execute)
     79  (declaim (inline %init-ivector-u32)))
     80
     81(defun %init-ivector-u32 (len u32val uvector)
     82  (declare (type index len)
     83           (type (unsigned-byte 32) u32val)
     84           (type (simple-array (unsigned-byte 32) (*)) uvector)
     85           (optimize (speed 3) (safety 0)))
     86  (dotimes (i len uvector)
     87    (setf (aref uvector i) u32val)))
     88
     89(eval-when (:compile-toplevel :execute)
     90  (declaim (inline %init-ivector-u16)))
     91
     92(defun %init-ivector-u16 (len val uvector)
     93  (declare (type index len)
     94           (type (unsigned-byte 16) val)
     95           (type (simple-array (unsigned-byte 16) (*)) uvector)
     96           (optimize (speed 3) (safety 0)))
     97  (dotimes (i len uvector)
     98    (setf (aref uvector i) val)))
     99
     100                             
     101
     102(defun %init-ivector32 (typecode len val uvector)
     103  (declare (type (unsigned-byte 32) typecode)
     104           (type index len))
     105  (let* ((u32val (case typecode
     106                   (#.x8664::subtag-s32-vector
     107                    (logand (the (signed-byte 32)
     108                              (require-type val '(signed-byte 32)))
     109                            #xffffffff))
     110                   (#.x8664::subtag-single-float-vector
     111                    (single-float-bits (require-type val 'single-float)))
     112                   (#.x8664::subtag-simple-base-string
     113                    (char-code val))
     114                   (t
     115                    (require-type val '(unsigned-byte 32))))))
     116    (declare (type (unsigned-byte 32) u32val))
     117    (%init-ivector-u32 len u32val uvector)))
     118
     119(defun %init-misc (val uvector)
     120  (let* ((len (uvsize uvector))
     121         (typecode (typecode uvector))
     122         (fulltag (logand x8664::fulltagmask typecode)))
     123    (declare (type index len)
     124             (type (unsigned-byte 8) typecode)
     125             (type (mod 16) fulltag))
     126    (if (or (= fulltag x8664::fulltag-nodeheader-0)
     127            (= fulltag x8664::fulltag-nodeheader-1))
     128      (%init-gvector len val uvector)
     129      (if (= fulltag x8664::ivector-class-64-bit)
     130        (%init-ivector64 typecode len val uvector)
     131        (if (= fulltag x8664::ivector-class-32-bit)
     132          (%init-ivector32 typecode len val uvector)
     133          ;; Value must be a fixnum, 1, 8, 16 bits
     134          (case typecode
     135            (#.x8664::subtag-u16-vector
     136             (%init-ivector-u16 len
     137                                (require-type val '(unsigned-byte 16))
     138                                uvector))
     139            (#.x8664::subtag-s16-vector
     140             (%init-ivector-u16 len
     141                                (logand (the (signed-byte 16)
     142                                          (require-type val '(unsigned-byte 16)))
     143                                        #xffff)
     144                                uvector))
     145            (#.x8664::subtag-u8-vector
     146             (let* ((v0 (require-type val '(unsigned-byte 8)))
     147                    (l0 (ash (the fixnum (1+ len)) -1)))
     148               (declare (type (unsigned-byte 8) v0)
     149                        (type index l0))
     150               (%init-ivector-u16 l0
     151                                  (logior (the (unsigned-byte 16) (ash v0 8))
     152                                          v0)
     153                                  uvector)))
     154            (#.x8664::subtag-s8-vector
     155             (let* ((v0 (logand #xff
     156                                (the (signed-byte 8)
     157                                  (require-type val '(signed-byte 8)))))
     158                    (l0 (ash (the fixnum (1+ len)) -1)))
     159               (declare (type (unsigned-byte 8) v0)
     160                        (type index l0))
     161               (%init-ivector-u16 l0
     162                                  (logior (the (unsigned-byte 16) (ash v0 8))
     163                                          v0)
     164                                  uvector)))
     165            (#.x8664::subtag-bit-vector
     166             (if (eql 0 val)
     167               uvector
     168               (let* ((v0 (case val
     169                            (1 -1)
     170                            (t (report-bad-arg val 'bit))))
     171                      (l0 (ash (the fixnum (+ len 64)) -6)))
     172                 (declare (type (unsigned-byte 8) v0)
     173                          (type index l0))
     174                 (%%init-ivector64  l0 v0 uvector))))
     175            (t (report-bad-arg uvector
     176                               '(or simple-bit-vector
     177                                   (simple-array (signed-byte 8) (*))
     178                                   (simple-array (unsigned-byte 8) (*))
     179                                   (simple-array (signed-byte 16) (*))
     180                                   (simple-array (unsigned-byte 16) (*)))))))))))
     181             
     182
     183)
     184
     185#-x8664-target
    31186(defun %init-misc (val uvector)
    32187  (dotimes (i (uvsize uvector) uvector)
    33188    (setf (uvref uvector i) val)))
    34 
     189         
    35190
    36191;;; 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  
    3535  (shrq ($ x8664::word-shift) (% imm1))
    3636  (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
    37   (shlq ($ x8664::word-shift) (% imm1))
    3837  @have-table-index
    3938  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))
  • branches/working-0711/ccl/level-0/X86/x86-misc.lisp

    r7343 r7624  
    393393;;; Return true iff we were able to increment a non-negative
    394394;;; lock._value
    395 (defx86lapfunction %try-read-lock-rwlock ((lock arg_z))
    396   (check-nargs 1)
    397   @try
    398   (movq (@ x8664::lock._value (% lock)) (% rax))
    399   (movq (% rax) (% imm1))
    400   (addq ($ '1) (% imm1))
    401   (jle @fail)
    402   (lock)
    403   (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
    404   (jne @try)
    405   (single-value-return)                                 ; return the lock
    406 @fail
    407   (movl ($ x8664::nil-value) (%l arg_z))
    408   (single-value-return))
    409 
    410 
    411 
    412 (defx86lapfunction unlock-rwlock ((lock arg_z))
    413   (cmpq ($ 0) (@ x8664::lock._value (% lock)))
    414   (jle @unlock-write)
    415   @unlock-read
    416   (movq (@ x8664::lock._value (% lock)) (% rax))
    417   (lea (@ '-1 (% imm0)) (% imm1))
    418   (lock)
    419   (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
    420   (jne @unlock-read)
    421   (single-value-return)
    422   @unlock-write
    423   ;;; If we aren't the writer, return NIL.
    424   ;;; If we are and the value's about to go to 0, clear the writer field.
    425   (movq (@ x8664::lock.writer (% lock)) (% imm0))
    426   (cmpq (% imm0) (@ (% :rcontext) x8664::tcr.linear))
    427   (jne @fail)
    428   (cmpq ($ '-1) (@ x8664::lock._value (% lock)))
    429   (jne @still-owner)
    430   (movsd (% fpzero) (@ x8664::lock.writer (% lock)))
    431   @still-owner
    432   (addq ($ '1) (@ x8664::lock._value (% lock)))
    433   (single-value-return)
    434   @fail
    435   (movl ($ x8664::nil-value) (%l arg_z))
    436   (single-value-return))
     395
     396
     397
    437398
    438399(defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
     
    535496    (movq (% imm0) (% arg_z))
    536497    (single-value-return)))
     498
     499(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z))
     500  (unbox-fixnum newval imm0)
     501  (macptr-ptr ptr arg_y)                ; had better be aligned
     502  (lock)                                ; implicit ?
     503  (xchgl (% imm0.l) (@ (% arg_y)))
     504  (box-fixnum imm0 arg_z)
     505  (single-value-return))
     506 
     507                         
    537508
    538509
     
    750721;;; it still called ?
    751722
     723(defx86lapfunction %check-deferred-gc ()
     724  (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (@ (% :rcontext) x8664::tcr.flags))
     725  (movl ($ x8664::nil-value) (% arg_z.l))
     726  (jae @done)
     727  (ud2a)
     728  (:byte 3)
     729  (movl ($ x8664::t-value) (% arg_z.l))
     730  @done
     731  (single-value-return))
     732
     733(defx86lapfunction %get-spin-lock ((p arg_z))
     734  (check-nargs 1)
     735  (save-simple-frame)
     736  @again
     737  (macptr-ptr arg_z imm1)
     738  (movq (@ '*spin-lock-tries* (% fn)) (% temp0))
     739  (movq (@ target::symbol.vcell (% temp0)) (% temp0))
     740  (movq (@ (% :rcontext) x8664::tcr.linear) (% arg_y))
     741  @try-swap
     742  (xorq (% rax) (% rax))
     743  (lock)
     744  (cmpxchgq (% arg_y) (@ (% imm1)))
     745  (je @done)
     746  (pause)
     747  (subq ($ '1) (% temp0))
     748  (jne @try-swap)
     749  (pushq (% arg_z))
     750  (call-symbol yield 0)
     751  (popq (% arg_z))
     752  (jmp @again)
     753  @done
     754  (restore-simple-frame)
     755  (single-value-return))
     756 
    752757
    753758;;; end of x86-misc.lisp
  • branches/working-0711/ccl/level-0/X86/x86-utils.lisp

    r6483 r7624  
    443443  (single-value-return))
    444444
     445(defx86lapfunction freeze ()
     446  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
     447  (movq ($ arch::gc-trap-function-freeze) (% imm0))
     448  (uuo-gc-trap)
     449  (jmp-subprim .SPmakeu64))
     450
     451 
     452 
    445453
    446454
  • branches/working-0711/ccl/level-0/l0-aprims.lisp

    r7451 r7624  
    2222;;; This weak list is used to track semaphores as well as locks.
    2323(defvar %system-locks% nil)
    24 (setf %system-locks% (%cons-population nil))
     24
    2525
    2626(defun record-system-lock (l)
     
    7171        (when nul-terminated
    7272          (setf (%get-byte pointer n) 0)))
    73       nil)
    74     (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)))
     73      nil))
     74  (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
    7575
    7676(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
     
    123123             :address))))
    124124
    125 
     125(defun %make-rwlock-ptr ()
     126  (record-system-lock
     127   (%setf-macptr
     128    (make-gcable-macptr $flags_DisposeRwLock)
     129    (ff-call (%kernel-import target::kernel-import-rwlock-new)
     130             :address))))
    126131 
    127132(defun make-recursive-lock ()
     
    142147    (report-bad-arg r 'recursive-lock)))
    143148
    144 
     149(defun read-write-lock-ptr (rw)
     150  (if (and (eq target::subtag-lock (typecode rw))
     151           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
     152    (%svref rw target::lock._value-cell)
     153    (report-bad-arg rw 'read-write-lock)))
    145154
    146155(defun make-read-write-lock ()
    147156  "Create and return a read-write lock, which can be used for
    148157synchronization between threads."
    149   (gvector :lock 0 'read-write-lock 0 nil))
     158  (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil))
    150159
    151160
  • branches/working-0711/ccl/level-0/l0-bignum64.lisp

    r5837 r7624  
    20682068
    20692069
     2070(defun %bignum-random (number state)
     2071  (let* ((ndigits (%bignum-length number))
     2072         (sign-index (1- ndigits)))
     2073    (declare (fixnum ndigits sign-index))
     2074    (with-bignum-buffers ((bignum ndigits))
     2075      (dotimes (i sign-index)
     2076        (setf (bignum-ref bignum i) (%next-random-seed state)))
     2077      (setf (bignum-ref bignum sign-index)
     2078            (logand #x7fffffff (the (unsigned-byte 32)
     2079                                 (%next-random-seed state))))
     2080      (let* ((result (mod bignum number)))
     2081        (if (eq result bignum)
     2082          (copy-uvector bignum)
     2083          result)))))
     2084
     2085
     2086
    20702087(defun logbitp (index integer)
    20712088  "Predicate returns T if bit index of integer is a 1."
  • branches/working-0711/ccl/level-0/l0-hash.lisp

    r6918 r7624  
    187187   find                                 ; nhash.find
    188188   find-new                             ; nhash.find-new
     189   nil                                  ; hhash.read-only
    189190   ))
    190191
     
    567568
    568569
    569 
    570 
    571 
     570(defvar *continue-from-readonly-hashtable-lock-error* nil)
     571
     572(defun signal-read-only-hash-table-error (hash write-p)
     573  (cond (*continue-from-readonly-hashtable-lock-error*
     574         (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
     575                 "Hash-table ~s is readonly" hash)
     576         (assert-hash-table-writeable hash)
     577         (lock-hash-table hash write-p))
     578        (t (error "Hash-table ~s is readonly" hash))))
     579
     580(defun lock-hash-table (hash write-p)
     581  (if (nhash.read-only hash)
     582    (if write-p
     583        (signal-read-only-hash-table-error hash write-p)
     584      :readonly)
     585    (let* ((lock (nhash.exclusion-lock hash)))
     586      (if lock
     587        (write-lock-rwlock lock)
     588        (progn (unless (eq (nhash.owner hash) *current-process*)
     589                 (error "Not owner of hash table ~s" hash)))))))
     590
     591(defun lock-hash-table-for-map (hash)
     592  (if (nhash.read-only hash)
     593    :readonly
     594    (let* ((lock (nhash.exclusion-lock hash)))
     595      (if lock
     596        (write-lock-rwlock lock)
     597        (progn (unless (eq (nhash.owner hash) *current-process*)
     598                 (error "Not owner of hash table ~s" hash)))))))
     599
     600
     601(defun unlock-hash-table (hash was-readonly)
     602  (unless was-readonly
     603    (let* ((lock (nhash.exclusion-lock hash)))
     604      (if lock
     605        (unlock-rwlock lock)))))
    572606
    573607
     
    579613    (report-bad-arg hash 'hash-table))
    580614  (without-interrupts
    581    (lock-hash-table hash)
     615   (lock-hash-table hash t)
    582616   (let* ((vector (nhash.vector hash))
    583617          (size (nhash.vector-size vector))
     
    600634           (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
    601635                                               (nhash.vector.flags vector))))
    602    (unlock-hash-table hash)
     636   (unlock-hash-table hash nil)
    603637   hash))
    604638
     
    654688
    655689
    656 (defun lock-hash-table (hash)
    657   (let* ((lock (nhash.exclusion-lock hash)))
    658     (if lock
    659       (write-lock-rwlock lock)
    660       (progn (unless (eq (nhash.owner hash) *current-process*)
    661                (error "Not owner of hash table ~s" hash))))))
    662 
    663 (defun unlock-hash-table (hash)
    664   (let* ((lock (nhash.exclusion-lock hash)))
    665     (if lock
    666       (unlock-rwlock lock))))
    667690
    668691(defun gethash (key hash &optional default)
     
    675698         (vector-key nil)
    676699         (gc-locked nil)
     700         (readonly nil)
    677701         (foundp nil))
    678702    (without-interrupts
    679      (lock-hash-table hash)
     703     (setq readonly (eq (lock-hash-table hash nil) :readonly))
    680704     (let* ((vector (nhash.vector hash)))
    681705       (if (and (eq key (nhash.vector.cache-key vector))
     
    694718             (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
    695719                                      (not (eq vector-key deleted-hash-key-marker))))
     720                    #+no
    696721                    (setf (nhash.vector.cache-key vector) vector-key
    697722                          (nhash.vector.cache-value vector) value
     
    705730               (t (return)))))))
    706731     (when gc-locked (%unlock-gc-lock))
    707      (unlock-hash-table hash))
     732     (unlock-hash-table hash readonly))
    708733    (if foundp
    709734      (values value t)
     
    717742  (let* ((foundp nil))
    718743    (without-interrupts
    719      (lock-hash-table hash)
     744     (lock-hash-table hash t)
    720745     (%lock-gc-lock)
    721746     (when (%needs-rehashing-p hash)
     
    728753             (unless (= (the fixnum (hti.index iterator))
    729754                        (the fixnum (nhash.vector.cache-idx vector)))
    730                (unlock-hash-table hash)
     755               (unlock-hash-table hash nil)
    731756               (%unlock-gc-lock)
    732757               (error "Can't remove key ~s during iteration on hash-table ~s"
     
    749774               (unless (= (the fixnum (hti.index iterator))
    750775                          (the fixnum (vector-index->index vector-index)))
    751                  (unlock-hash-table hash)
     776                 (unlock-hash-table hash nil)
    752777                 (%unlock-gc-lock)
    753778                 (error "Can't remove key ~s during iteration on hash-table ~s"
     
    782807     ;; Return T if we deleted something
    783808     (%unlock-gc-lock)
    784      (unlock-hash-table hash))
     809     (unlock-hash-table hash nil))
    785810    foundp))
    786811
     
    792817   (block protected
    793818     (tagbody
    794         (lock-hash-table hash)
     819        (lock-hash-table hash t)
    795820        AGAIN
    796821        (%lock-gc-lock)
     
    805830            (when (and (< index (the fixnum (uvsize vector)))
    806831                       (not (funcall test (%svref vector index) key)))
    807               (unlock-hash-table hash)
     832              (unlock-hash-table hash nil)
    808833              (%unlock-gc-lock)
    809834              (error "Can't add key ~s during iteration on hash-table ~s"
     
    850875                  (nhash.vector.cache-value vector) value)))))
    851876   (%unlock-gc-lock)
    852    (unlock-hash-table hash))
     877   (unlock-hash-table hash nil))
    853878  value)
    854879
     
    16801705    vector))
    16811706
     1707(defun assert-hash-table-readonly (hash)
     1708  (unless (hash-table-p hash)
     1709    (report-bad-arg hash 'hash-table))
     1710  (or (nhash.read-only hash)
     1711      (without-interrupts
     1712       (lock-hash-table hash t)
     1713       (let* ((flags (nhash.vector.flags (nhash.vector hash))))
     1714         (declare (fixnum flags))
     1715         (when (or (logbitp $nhash_track_keys_bit flags)
     1716                   (logbitp $nhash_component_address_bit flags))
     1717           (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
     1718           (unlock-hash-table hash nil)
     1719           (return-from assert-hash-table-readonly nil))
     1720         (setf (nhash.read-only hash) t)
     1721         (unlock-hash-table hash nil)
     1722         t))))
     1723
     1724;; This is dangerous, if multiple threads are accessing a read-only
     1725;; hash table. Use it responsibly.
     1726(defun assert-hash-table-writeable (hash)
     1727  (unless (hash-table-p hash)
     1728    (report-bad-arg hash 'hash-table))
     1729  (when (nhash.read-only hash)
     1730    (setf (nhash.read-only hash) nil)
     1731    t))
     1732
     1733(defun readonly-hash-table-p (hash)
     1734  (unless (hash-table-p hash)
     1735    (report-bad-arg hash 'hash-table))
     1736  (nhash.read-only hash))
  • branches/working-0711/ccl/level-0/l0-io.lisp

    r6181 r7624  
    3131
    3232
    33 ; write nbytes bytes from buffer buf to file-descriptor fd.
     33(defun utf-8-octets-in-string (string start end)
     34  (if (>= end start)
     35    (do* ((noctets 0)
     36          (i start (1+ i)))
     37         ((= i end) noctets)
     38      (declare (fixnum noctets))
     39      (let* ((code (char-code (schar string i))))
     40        (declare (type (mod #x110000) code))
     41        (incf noctets
     42              (if (< code #x80)
     43                1
     44                (if (< code #x800)
     45                  2
     46                  (if (< code #x10000)
     47                    3
     48                    4))))))
     49    0))
     50
     51(defun utf-8-memory-encode (string pointer idx start end)
     52  (declare (fixnum idx))
     53  (do* ((i start (1+ i)))
     54       ((>= i end) idx)
     55    (let* ((code (char-code (schar string i))))
     56      (declare (type (mod #x110000) code))
     57      (cond ((< code #x80)
     58             (setf (%get-unsigned-byte pointer idx) code)
     59             (incf idx))
     60            ((< code #x800)
     61             (setf (%get-unsigned-byte pointer idx)
     62                   (logior #xc0 (the fixnum (ash code -6))))
     63             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     64                   (logior #x80 (the fixnum (logand code #x3f))))
     65             (incf idx 2))
     66            ((< code #x10000)
     67             (setf (%get-unsigned-byte pointer idx)
     68                   (logior #xe0 (the fixnum (ash code -12))))
     69             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     70                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     71             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     72                   (logior #x80 (the fixnum (logand code #x3f))))
     73             (incf idx 3))
     74            (t
     75             (setf (%get-unsigned-byte pointer idx)
     76                   (logior #xf0
     77                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
     78             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     79                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
     80             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     81                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     82             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
     83                   (logand #x3f code))
     84             (incf idx 4))))))
     85
     86(defun utf-8-memory-decode (pointer noctets idx string)
     87  (declare (fixnum noctets idx))
     88  (do* ((i 0 (1+ i))
     89        (end (+ idx noctets))
     90        (index idx (1+ index)))
     91       ((>= index end) (if (= index end) index 0))
     92    (let* ((1st-unit (%get-unsigned-byte pointer index)))
     93      (declare (type (unsigned-byte 8) 1st-unit))
     94      (let* ((char (if (< 1st-unit #x80)
     95                     (code-char 1st-unit)
     96                     (if (>= 1st-unit #xc2)
     97                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
     98                         (declare (type (unsigned-byte 8) 2nd-unit))
     99                         (if (< 1st-unit #xe0)
     100                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     101                             (code-char
     102                              (logior
     103                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
     104                               (the fixnum (logxor 2nd-unit #x80)))))
     105                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
     106                             (declare (type (unsigned-byte 8) 3rd-unit))
     107                             (if (< 1st-unit #xf0)
     108                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     109                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     110                                        (or (>= 1st-unit #xe1)
     111                                            (>= 2nd-unit #xa0)))
     112                                 (code-char (the fixnum
     113                                              (logior (the fixnum
     114                                                        (ash (the fixnum (logand 1st-unit #xf))
     115                                                             12))
     116                                                      (the fixnum
     117                                                        (logior
     118                                                         (the fixnum
     119                                                           (ash (the fixnum (logand 2nd-unit #x3f))
     120                                                                6))
     121                                                         (the fixnum (logand 3rd-unit #x3f))))))))
     122                               (if (< 1st-unit #xf8)
     123                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
     124                                   (declare (type (unsigned-byte 8) 4th-unit))
     125                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     126                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     127                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
     128                                            (or (>= 1st-unit #xf1)
     129                                                (>= 2nd-unit #x90)))
     130                                     (code-char
     131                                      (logior
     132                                       (the fixnum
     133                                         (logior
     134                                          (the fixnum
     135                                            (ash (the fixnum (logand 1st-unit 7)) 18))
     136                                          (the fixnum
     137                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
     138                                       (the fixnum
     139                                         (logior
     140                                          (the fixnum
     141                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
     142                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
     143        (setf (schar string i) (or char #\Replacement_Character))))))
     144
     145(defun utf-8-length-of-memory-encoding (pointer noctets start)
     146  (do* ((i start)
     147        (end (+ start noctets))
     148        (nchars 0 (1+ nchars)))
     149       ((= i end) (values nchars i))
     150    (let* ((code (%get-unsigned-byte pointer i))
     151           (nexti (+ i (cond ((< code #x80) 1)
     152                             ((< code #xe0) 2)
     153                             ((< code #xf0) 3)
     154                             (t 4)))))
     155      (declare (type (unsigned-byte 8) code))
     156      (if (> nexti end)
     157        (return (values nchars i))
     158        (setq i nexti)))))
     159
     160
     161
     162;;; write nbytes bytes from buffer buf to file-descriptor fd.
    34163(defun fd-write (fd buf nbytes)
    35164  (syscall syscalls::write fd buf nbytes))
     
    42171
    43172(defun fd-open (path flags &optional (create-mode #o666))
    44   (with-cstrs ((p path))
    45     (syscall syscalls::open p flags create-mode)))
     173  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
     174    (let* ((fd (syscall syscalls::open p flags create-mode)))
     175      (declare (fixnum fd))
     176      (when (or (= fd (- #$EMFILE))
     177                (= fd (- #$EMFILE)))
     178        (gc)
     179        (drain-termination-queue)
     180        (setq fd (syscall syscalls::open p flags create-mode)))
     181      fd)))
    46182
    47183(defun fd-chmod (fd mode)
  • branches/working-0711/ccl/level-0/l0-misc.lisp

    r6917 r7624  
    1616
    1717(in-package "CCL")
     18
     19;;; Bootstrapping for futexes
     20#+(and linuxx8664-target)
     21(eval-when (:compile-toplevel :execute)
     22  (pushnew :futex *features*))
     23
     24#+futex
     25(eval-when (:compile-toplevel :execute)
     26  ;; We only need a few constants from <linux/futex.h>, which may
     27  ;; not have been included in the :libc .cdb files.
     28  (defconstant FUTEX-WAIT 0)
     29  (defconstant FUTEX-WAKE 1)
     30  (defconstant futex-avail 0)
     31  (defconstant futex-locked 1)
     32  (defconstant futex-contended 2)
     33  (require "X8664-LINUX-SYSCALLS")
     34  (declaim (inline %lock-futex %unlock-futex)))
    1835
    1936; Miscellany.
     
    129146  t)
    130147
    131 
     148(defun frozen-space-dnodes ()
     149  "Returns the current size of the frozen area."
     150  (%fixnum-ref-natural (%get-kernel-global 'tenured-area)
     151                       target::area.static-dnodes))
    132152(defun %usedbytes ()
    133153  (%normalize-areas)
     
    147167                (incf library bytes)
    148168                (incf static bytes))))))
    149       (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))
    150         (decf dynamic hons-size)
    151         (values dynamic static library hons-size))))
     169      (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift)))
     170        (decf dynamic frozen-size)
     171        (values dynamic static library frozen-size))))
    152172
    153173
     
    199219
    200220
    201 ; Returns six values.
    202 ;   sp free
    203 ;   sp used
    204 ;   vsp free
    205 ;   vsp used
    206 ;   tsp free
    207 ;   tsp used
     221;;; Returns six values.
     222;;;   sp free
     223;;;   sp used
     224;;;   vsp free
     225;;;   vsp used
     226;;;   tsp free
     227;;;   tsp used
    208228(defun %thread-stack-space (&optional (thread *current-lisp-thread*))
    209229  (when (eq thread *current-lisp-thread*)
     
    267287         (static-used nil)
    268288         (staticlib-used nil)
    269          (hons-space-size nil)
     289         (frozen-space-size nil)
    270290         (lispheap nil)
    271291         (reserved nil)
     
    275295         (stack-free)
    276296         (stack-used-by-thread nil))
    277     (with-other-threads-suspended
    278         (without-gcing
    279          (setq freebytes (%freebytes))
    280          (when verbose
    281            (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
    282              (%usedbytes))
    283            (setq lispheap (+ freebytes usedbytes)
    284                  reserved (%reservedbytes)
    285                  static (+ static-used staticlib-used hons-space-size))
    286            (multiple-value-setq (stack-total stack-used stack-free)
    287              (%stack-space))
    288            (unless (eq verbose :default)
    289              (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
     297    (progn
     298      (progn
     299        (setq freebytes (%freebytes))
     300        (when verbose
     301          (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size)
     302            (%usedbytes))
     303          (setq lispheap (+ freebytes usedbytes)
     304                reserved (%reservedbytes)
     305                static (+ static-used staticlib-used frozen-space-size))
     306          (multiple-value-setq (stack-total stack-used stack-free)
     307            (%stack-space))
     308          (unless (eq verbose :default)
     309            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
    290310    (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
    291311    (when verbose
     
    305325                0 0
    306326                static (k static))
    307         (when (and hons-space-size (not (zerop hons-space-size)))
    308           (format t "~&~,3f MB of static memory reserved for hash consing."
    309                   (/ hons-space-size (float (ash 1 20)))))
     327        (when (and frozen-space-size (not (zerop frozen-space-size)))
     328          (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory"
     329                  (/ frozen-space-size (float (ash 1 20)))))
    310330        (format t "~&~,3f MB reserved for heap expansion."
    311331                (/ reserved (float (ash 1 20))))
     
    390410    (declare (fixnum end))))
    391411
     412(defun %get-utf-8-cstring (pointer)
     413  (do* ((end 0 (1+ end)))
     414       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
     415        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
     416               (string (make-string len)))
     417          (utf-8-memory-decode pointer end 0 string)
     418          string))
     419    (declare (fixnum end))))
     420
    392421;;; This is mostly here so we can bootstrap shared libs without
    393422;;; having to bootstrap #_strcmp.
     
    467496
    468497(defparameter *spin-lock-tries* 1)
    469 
     498(defparameter *spin-lock-timeouts* 0)
     499
     500#+(and (not futex) (not x86-target))
    470501(defun %get-spin-lock (p)
    471502  (let* ((self (%current-tcr))
     
    476507        (when (eql 0 (%ptr-store-fixnum-conditional p 0 self))
    477508          (return-from %get-spin-lock t)))
     509      (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell)
    478510      (yield))))
    479511
     512#-futex
    480513(defun %lock-recursive-lock (lock &optional flag)
    481514  (with-macptrs ((p)
     
    505538      (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock"))))
    506539
     540#+futex
     541(defun futex-wait (p val)
     542  (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0))
     543
     544#+futex
     545(defun futex-wake (p n)
     546  (syscall syscalls::futex p FUTEX-WAKE n (%null-ptr) (%null-ptr) 0))
     547
     548#+futex
     549(defun %lock-futex (p wait-level)
     550  (let* ((val (%ptr-store-conditional p futex-avail futex-locked)))
     551    (declare (fixnum val))
     552    (or (eql val futex-avail)
     553        (loop
     554          (if (eql val futex-contended)
     555            (let* ((*interrupt-level* wait-level))
     556              (futex-wait p val))
     557            (setq val futex-contended))
     558          (when (eql futex-avail (xchgl val p))
     559            (return t))))))
     560
     561#+futex
     562(defun %unlock-futex (p)
     563  (unless (eql futex-avail (%atomic-decf-ptr p))
     564    (setf (%get-natural p target::lockptr.avail) futex-avail)
     565    (futex-wake p #$INT_MAX)))
     566
     567
     568#+futex
     569(defun %lock-recursive-lock (lock &optional flag)
     570  (if (istruct-typep flag 'lock-acquisition)
     571    (setf (lock-acquisition.status flag) nil)
     572    (if flag (report-bad-arg flag 'lock-acquisition)))
     573  (let* ((self (%current-tcr))
     574         (level *interrupt-level*))
     575    (declare (fixnum self val))
     576    (without-interrupts
     577     (cond ((eql self (%get-object lock target::lockptr.owner))
     578            (incf (%get-natural lock target::lockptr.count)))
     579           (t (%lock-futex lock level)
     580              (%set-object lock target::lockptr.owner self)
     581              (setf (%get-natural lock target::lockptr.count) 1)))
     582     (when flag
     583       (setf (lock-acquisition.status flag) t))
     584     t)))
     585
     586         
    507587
    508588;;; Locking the exception lock to inhibit GC (from other threads)
     
    522602    (%unlock-recursive-lock lock)))
    523603
     604#-futex
    524605(defun %try-recursive-lock (lock &optional flag)
    525606  (with-macptrs ((p)
     
    546627              win))))))
    547628
    548 
     629#+futex
     630(defun %try-recursive-lock (lock &optional flag)
     631  (let* ((self (%current-tcr)))
     632    (declare (fixnum self))
     633    (if flag
     634      (if (istruct-typep flag 'lock-acquisition)
     635        (setf (lock-acquisition.status flag) nil)
     636        (report-bad-arg flag 'lock-acquisition)))
     637    (without-interrupts
     638     (cond ((eql (%get-object lock target::lockptr.owner) self)
     639            (incf (%get-natural lock target::lockptr.count))
     640            (if flag (setf (lock-acquisition.status flag) t))
     641            t)
     642           (t
     643            (when (eql 0 (%ptr-store-conditional lock futex-avail futex-locked))
     644              (%set-object lock target::lockptr.owner self)
     645              (setf (%get-natural lock target::lockptr.count) 1)
     646              (if flag (setf (lock-acquisition.status flag) t))
     647              t))))))
     648
     649
     650
     651#-futex
    549652(defun %unlock-recursive-lock (lock)
    550653  (with-macptrs ((signal (%get-ptr lock target::lockptr.signal))
     
    571674    nil)
    572675
     676#+futex
     677(defun %unlock-recursive-lock (lock)
     678  (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr))
     679    (error 'not-lock-owner :lock lock))
     680  (without-interrupts
     681   (when (eql 0 (decf (the fixnum
     682                        (%get-natural lock target::lockptr.count))))
     683     (setf (%get-natural lock target::lockptr.owner) 0)
     684     (%unlock-futex lock)))
     685    nil)
     686
     687
     688
    573689
    574690(defun %%lock-owner (lock)
     
    616732          (return cell))))))
    617733
     734(defun atomic-pop-uvector-cell (v i)
     735  (let* ((offset (+ target::misc-data-offset (ash i target::word-shift))))
     736    (loop
     737      (let* ((old (%svref v i)))
     738        (if (null old)
     739          (return (values nil nil))
     740          (let* ((tail (cdr old)))
     741            (when (%store-node-conditional offset v old tail)
     742              (return (values (car old) t)))))))))
     743
     744
    618745(defun store-gvector-conditional (index gvector old new)
    619746  (%store-node-conditional (+ target::misc-data-offset
     
    640767(defun %atomic-incf-symbol-value (s &optional (by 1))
    641768  (setq s (require-type s 'symbol))
    642   (let* ((binding-address (%symbol-binding-address s)))
    643     (declare (fixnum binding-address))
    644     (if (zerop binding-address)
    645       (%atomic-incf-node by s target::symbol.vcell-cell)
    646       (%atomic-incf-node by binding-address (* 2 target::node-size)))))
    647 
    648 (defun write-lock-rwlock (lock)
    649   (let* ((context (%current-tcr)))
    650     (if (eq (%svref lock target::lock.writer-cell) context)
    651       (progn
    652         (decf (%svref lock target::lock._value-cell))
    653         lock)
    654       (loop
    655         (when (%store-immediate-conditional target::lock._value lock 0 -1)
    656           (setf (%svref lock target::lock.writer-cell) context)
    657           (return lock))
    658         (%nanosleep 0 *ns-per-tick*)))))
    659 
    660 
    661 (defun read-lock-rwlock (lock)
    662   (loop
    663     (when (%try-read-lock-rwlock lock)
    664       (return lock))
    665     (%nanosleep 0 *ns-per-tick*)))
     769  (multiple-value-bind (base offset) (%symbol-binding-address s)
     770    (%atomic-incf-node by base offset)))
     771
     772;;; What happens if there are some pending readers and another writer,
     773;;; and we abort out of the semaphore wait ?  If the writer semaphore is
     774;;; signaled before we abandon interest in it
     775#-futex
     776(defun %write-lock-rwlock-ptr (ptr &optional flag)
     777  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
     778    (if (istruct-typep flag 'lock-acquisition)
     779      (setf (lock-acquisition.status flag) nil)
     780      (if flag (report-bad-arg flag 'lock-acquisition)))
     781    (let* ((level *interrupt-level*)
     782           (tcr (%current-tcr)))
     783      (declare (fixnum tcr))
     784      (without-interrupts
     785       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     786       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     787         (progn
     788           (incf (%get-signed-natural ptr target::rwlock.state))
     789           (setf (%get-natural ptr target::rwlock.spin) 0)
     790           (if flag
     791             (setf (lock-acquisition.status flag) t))
     792           t)
     793         (do* ()
     794              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
     795               ;; That wasn't so bad, was it ?  We have the spinlock now.
     796               (setf (%get-signed-natural ptr target::rwlock.state) 1
     797                     (%get-natural ptr target::rwlock.spin) 0)
     798               (%set-object ptr target::rwlock.writer tcr)
     799               (if flag
     800                 (setf (lock-acquisition.status flag) t))
     801               t)
     802           (incf (%get-natural ptr target::rwlock.blocked-writers))
     803           (setf (%get-natural ptr target::rwlock.spin) 0)
     804           (let* ((*interrupt-level* level))
     805                  (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait"))
     806           (%get-spin-lock ptr)))))))
     807#+futex
     808(defun %write-lock-rwlock-ptr (ptr &optional flag)
     809  (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) )
     810    (if (istruct-typep flag 'lock-acquisition)
     811      (setf (lock-acquisition.status flag) nil)
     812      (if flag (report-bad-arg flag 'lock-acquisition)))
     813    (let* ((level *interrupt-level*)
     814           (tcr (%current-tcr)))
     815      (declare (fixnum tcr))
     816      (without-interrupts
     817       (%lock-futex ptr level)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     818       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     819         (progn
     820           (incf (%get-signed-natural ptr target::rwlock.state))
     821           (%unlock-futex ptr)
     822           (if flag
     823             (setf (lock-acquisition.status flag) t))
     824           t)
     825         (do* ()
     826              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
     827               ;; That wasn't so bad, was it ?  We have the spinlock now.
     828               (setf (%get-signed-natural ptr target::rwlock.state) 1)
     829               (%unlock-futex ptr)
     830               (%set-object ptr target::rwlock.writer tcr)
     831               (if flag
     832                 (setf (lock-acquisition.status flag) t))
     833               t)
     834           (incf (%get-natural ptr target::rwlock.blocked-writers))
     835           (let* ((waitval (%get-natural write-signal 0)))
     836             (%unlock-futex ptr)
     837             (let* ((*interrupt-level* level))
     838               (futex-wait write-signal waitval)))
     839           (%lock-futex ptr level)
     840           (decf (%get-natural ptr target::rwlock.blocked-writers))))))))
     841
     842
     843
     844(defun write-lock-rwlock (lock &optional flag)
     845  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag))
     846
     847#-futex
     848(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
     849  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
     850    (if (istruct-typep flag 'lock-acquisition)
     851      (setf (lock-acquisition.status flag) nil)
     852      (if flag (report-bad-arg flag 'lock-acquisition)))
     853    (let* ((level *interrupt-level*)
     854           (tcr (%current-tcr)))
     855      (declare (fixnum tcr))
     856      (without-interrupts
     857       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
     858       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     859         (progn
     860           (setf (%get-natural ptr target::rwlock.spin) 0)
     861           (error 'deadlock :lock lock))
     862         (do* ((state
     863                (%get-signed-natural ptr target::rwlock.state)
     864                (%get-signed-natural ptr target::rwlock.state)))
     865              ((<= state 0)
     866               ;; That wasn't so bad, was it ?  We have the spinlock now.
     867               (setf (%get-signed-natural ptr target::rwlock.state)
     868                     (the fixnum (1- state))
     869                     (%get-natural ptr target::rwlock.spin) 0)
     870               (if flag
     871                 (setf (lock-acquisition.status flag) t))
     872               t)
     873           (declare (fixnum state))
     874           (incf (%get-natural ptr target::rwlock.blocked-readers))
     875           (setf (%get-natural ptr target::rwlock.spin) 0)
     876           (let* ((*interrupt-level* level))
     877             (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait"))
     878           (%get-spin-lock ptr)))))))
     879
     880#+futex
     881(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
     882  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)))
     883    (if (istruct-typep flag 'lock-acquisition)
     884      (setf (lock-acquisition.status flag) nil)
     885      (if flag (report-bad-arg flag 'lock-acquisition)))
     886    (let* ((level *interrupt-level*)
     887           (tcr (%current-tcr)))
     888      (declare (fixnum tcr))
     889      (without-interrupts
     890       (%lock-futex ptr level)
     891       (if (eq (%get-object ptr target::rwlock.writer) tcr)
     892         (progn
     893           (%unlock-futex ptr)
     894           (error 'deadlock :lock lock))
     895         (do* ((state
     896                (%get-signed-natural ptr target::rwlock.state)
     897                (%get-signed-natural ptr target::rwlock.state)))
     898              ((<= state 0)
     899               ;; That wasn't so bad, was it ?  We have the spinlock now.
     900               (setf (%get-signed-natural ptr target::rwlock.state)
     901                     (the fixnum (1- state)))
     902               (%unlock-futex ptr)
     903               (if flag
     904                 (setf (lock-acquisition.status flag) t))
     905               t)
     906           (declare (fixnum state))
     907           (incf (%get-natural ptr target::rwlock.blocked-readers))
     908           (let* ((waitval (%get-natural reader-signal 0)))
     909             (%unlock-futex ptr)
     910             (let* ((*interrupt-level* level))
     911               (futex-wait reader-signal waitval)))
     912           (%lock-futex ptr level)
     913           (decf (%get-natural ptr target::rwlock.blocked-readers))))))))
     914
     915
     916
     917(defun read-lock-rwlock (lock &optional flag)
     918  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
     919
     920;;; If the current thread already owns the lock for writing, increment
     921;;; the lock's state.  Otherwise, try to lock the lock for reading.
     922(defun %ensure-at-least-read-locked (lock &optional flag)
     923  (if (istruct-typep flag 'lock-acquisition)
     924    (setf (lock-acquisition.status flag) nil)
     925    (if flag (report-bad-arg flag 'lock-acquisition)))
     926  (let* ((ptr (read-write-lock-ptr lock))
     927         (tcr (%current-tcr))
     928         #+futex (level *interrupt-level*))
     929    (declare (fixnum tcr))
     930    (or
     931     (without-interrupts
     932      #+futex
     933      (%lock-futex ptr level)
     934      #-futex
     935      (%get-spin-lock ptr)
     936      (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     937        (declare (fixnum state))
     938        (let ((win
     939               (cond ((<= state 0)
     940                      (setf (%get-signed-natural ptr target::rwlock.state)
     941                            (the fixnum (1- state)))
     942                      t)
     943                     ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr)
     944                      (setf (%get-signed-natural ptr target::rwlock.state)
     945                            (the fixnum (1+ state)))
     946                      t))))
     947          #+futex
     948          (%unlock-futex ptr)
     949          #-futex
     950          (setf (%get-natural ptr target::rwlock.spin) 0)
     951          (when win
     952            (if flag
     953              (setf (lock-acquisition.status flag) t))
     954            t))))
     955       (%read-lock-rwlock-ptr ptr lock flag))))
     956
     957#-futex
     958(defun %unlock-rwlock-ptr (ptr lock)
     959  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
     960                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
     961    (without-interrupts
     962     (%get-spin-lock ptr)
     963     (let* ((state (%get-signed-natural ptr target::rwlock.state))
     964            (tcr (%current-tcr)))
     965       (declare (fixnum state tcr))
     966       (cond ((> state 0)
     967              (unless (eql tcr (%get-object ptr target::rwlock.writer))
     968                (setf (%get-natural ptr target::rwlock.spin) 0)
     969                (error 'not-lock-owner :lock lock))
     970              (decf state))
     971             ((< state 0) (incf state))
     972             (t (setf (%get-natural ptr target::rwlock.spin) 0)
     973                (error 'not-locked :lock lock)))
     974       (setf (%get-signed-natural ptr target::rwlock.state) state)
     975       (when (zerop state)
     976         ;; We want any thread waiting for a lock semaphore to
     977         ;; be able to wait interruptibly.  When a thread waits,
     978         ;; it increments either the "blocked-readers" or "blocked-writers"
     979         ;; field, but since it may get interrupted before obtaining
     980         ;; the semaphore that's more of "an expression of interest"
     981         ;; in taking the lock than it is "a firm commitment to take it."
     982         ;; It's generally (much) better to signal the semaphore(s)
     983         ;; too often than it would be to not signal them often
     984         ;; enough; spurious wakeups are better than deadlock.
     985         ;; So: if there are blocked writers, the writer-signal
     986         ;; is raised once for each apparent blocked writer.  (At most
     987         ;; one writer will actually succeed in taking the lock.)
     988         ;; If there are blocked readers, the reader-signal is raised
     989         ;; once for each of them.  (It's possible for both the
     990         ;; reader and writer semaphores to be raised on the same
     991         ;; unlock; the writer semaphore is raised first, so in that
     992         ;; sense, writers still have priority but it's not guaranteed.)
     993         ;; Both the "blocked-writers" and "blocked-readers" fields
     994         ;; are cleared here (they can't be changed from another thread
     995         ;; until this thread releases the spinlock.)
     996         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
     997         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     998                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
     999           (declare (fixnum nreaders nwriters))
     1000           (when (> nwriters 0)
     1001             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
     1002             (dotimes (i nwriters)
     1003               (%signal-semaphore-ptr writer-signal)))
     1004           (when (> nreaders 0)
     1005             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
     1006             (dotimes (i nreaders)
     1007               (%signal-semaphore-ptr reader-signal)))))
     1008       (setf (%get-natural ptr target::rwlock.spin) 0)
     1009       t))))
     1010
     1011#+futex
     1012(defun %unlock-rwlock-ptr (ptr lock)
     1013  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))
     1014                 (writer-signal (%INC-ptr ptr target::rwlock.writer-signal)))
     1015    (let* ((signal nil)
     1016           (wakeup 0))
     1017    (without-interrupts
     1018     (%lock-futex ptr -1)
     1019     (let* ((state (%get-signed-natural ptr target::rwlock.state))
     1020            (tcr (%current-tcr)))
     1021       (declare (fixnum state tcr))
     1022       (cond ((> state 0)
     1023              (unless (eql tcr (%get-object ptr target::rwlock.writer))
     1024                (%unlock-futex ptr)
     1025                (error 'not-lock-owner :lock lock))
     1026              (decf state))
     1027             ((< state 0) (incf state))
     1028             (t (%unlock-futex ptr)
     1029                (error 'not-locked :lock lock)))
     1030       (setf (%get-signed-natural ptr target::rwlock.state) state)
     1031       (when (zerop state)
     1032         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
     1033         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
     1034                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
     1035           (declare (fixnum nreaders nwriters))
     1036           (if (> nwriters 0)
     1037             (setq signal writer-signal wakeup 1)
     1038             (if (> nreaders 0)
     1039               (setq signal reader-signal wakeup #$INT_MAX)))))
     1040       (when signal (incf (%get-signed-natural signal 0)))
     1041       (%unlock-futex ptr)
     1042       (when signal (futex-wake signal wakeup))
     1043       t)))))
     1044
     1045
     1046(defun unlock-rwlock (lock)
     1047  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
     1048
     1049;;; There are all kinds of ways to lose here.
     1050;;; The caller must have read access to the lock exactly once,
     1051;;; or have write access.
     1052;;; there's currently no way to detect whether the caller has
     1053;;; read access at all.
     1054;;; If we have to block and get interrupted, cleanup code may
     1055;;; try to unlock a lock that we don't hold. (It might be possible
     1056;;; to circumvent that if we use the same notifcation object here
     1057;;; that controls that cleanup process.)
     1058
     1059(defun %promote-rwlock (lock &optional flag)
     1060  (let* ((ptr (read-write-lock-ptr lock)))
     1061    (if (istruct-typep flag 'lock-acquisition)
     1062      (setf (lock-acquisition.status flag) nil)
     1063      (if flag (report-bad-arg flag 'lock-acquisition)))
     1064    (let* ((level *interrupt-level*)
     1065           (tcr (%current-tcr)))
     1066      (without-interrupts
     1067       #+futex
     1068       (%lock-futex ptr level)
     1069       #-futex
     1070       (%get-spin-lock ptr)
     1071       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
     1072         (declare (fixnum state))
     1073         (cond ((> state 0)
     1074                (unless (eql (%get-object ptr target::rwlock.writer) tcr)
     1075                  #+futex
     1076                  (%unlock-futex ptr)
     1077                  #-futex
     1078                  (setf (%get-natural ptr target::rwlock.spin) 0)
     1079                  (error :not-lock-owner :lock lock)))
     1080               ((= state 0)
     1081                #+futex (%unlock-futex ptr)
     1082                #-futex (setf (%get-natural ptr target::rwlock.spin) 0)
     1083                (error :not-locked :lock lock))
     1084               (t
     1085                (if (= state -1)
     1086                  (progn
     1087                    (setf (%get-signed-natural ptr target::rwlock.state) 1)
     1088                    (%set-object ptr target::rwlock.writer tcr)
     1089                    #+futex
     1090                    (%unlock-futex ptr)
     1091                    #-futex
     1092                    (setf (%get-natural ptr target::rwlock.spin) 0)
     1093                    (if flag
     1094                      (setf (lock-acquisition.status flag) t))
     1095                    t)
     1096                  (progn
     1097                    (%unlock-rwlock-ptr ptr lock)
     1098                    (let* ((*interrupt-level* level))
     1099                      (%write-lock-rwlock-ptr ptr flag)))))))))))
     1100                     
     1101
    6661102
    6671103(defun safe-get-ptr (p &optional dest)
  • branches/working-0711/ccl/level-0/l0-numbers.lisp

    r7354 r7624  
    17261726
    17271727
     1728#+32-bit-target
    17281729(defun random (number &optional (state *random-state*))
    17291730  (if (not (typep state 'random-state)) (report-bad-arg state 'random-state))
     
    17331734        (if (< number 65536)
    17341735          (fast-mod (%next-random-seed state) number)
    1735           (%bignum-random number state))))
     1736          (let* ((n 0)
     1737                 (nhalf (ash (+ 15 (integer-length number)) -4)))
     1738            (declare (fixnum n nhalf))
     1739            (dotimes (i nhalf (fast-mod n number))
     1740              (setq n (logior (the fixnum (ash n 16))
     1741                              (the fixnum (%next-random-seed state)))))))))
    17361742     ((and (typep number 'double-float) (> (the double-float number) 0.0))
    17371743      (%float-random number state))
     
    17421748     (t (report-bad-arg number '(or (integer (0)) (float (0.0)))))))
    17431749
     1750#+64-bit-target
     1751(defun random (number &optional (state *random-state*))
     1752  (if (not (typep state 'random-state)) (report-bad-arg state 'random-state))
     1753  (cond
     1754    ((and (fixnump number) (> (the fixnum number) 0))
     1755     (locally (declare (fixnum number))
     1756       (let* ((n 0)
     1757              (n32 (ash (+ 31 (integer-length number)) -5)))
     1758         (declare (fixnum n n32))
     1759         (dotimes (i n32 (fast-mod n number))
     1760           (setq n (logior (the fixnum (ash n 32))
     1761                           (the fixnum (%next-random-seed state))))))))
     1762    ((and (typep number 'double-float) (> (the double-float number) 0.0))
     1763     (%float-random number state))
     1764    ((and (typep number 'short-float) (> (the short-float number) 0.0s0))
     1765     (%float-random number state))
     1766    ((and (bignump number) (> number 0))
     1767     (%bignum-random number state))
     1768    (t (report-bad-arg number '(or (integer (0)) (float (0.0)))))))
     1769
    17441770
    17451771#|
     
    17841810
    17851811#+64-bit-target
    1786 (defun %next-random-pair (high low)
    1787   (declare (type (unsigned-byte 16) high low))
    1788   (let* ((n0
    1789           (%i* 48271
    1790              (the  (unsigned-byte 31)
    1791                (logior (the (unsigned-byte 31)
    1792                          (ash (ldb (byte 15 0) high) 16))
    1793                        (the (unsigned-byte 16)
    1794                          (ldb (byte 16 0) low))))))
    1795          (n (fast-mod n0 (1- (expt 2 31)))))
     1812(defun %next-random-seed (state)
     1813  (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271))))
    17961814    (declare (fixnum n))
    1797     (values (ldb (byte 15 16) n)
    1798             (ldb (byte 16 0) n))))
    1799 
     1815    (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31))))
     1816    (logand n (1- (ash 1 32)))))
     1817
     1818#+32-bit-target
    18001819(defun %next-random-seed (state)
    1801   (multiple-value-bind (high low) (%next-random-pair (%svref state 1)
    1802                                                      (%svref state 2))
     1820  (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state)
     1821                                                     (random.seed-2 state))
    18031822    (declare (type (unsigned-byte 15) high)
    18041823             (type (unsigned-byte 16) low))
    1805     (setf (%svref state 1) high
    1806           (%svref state 2) low)
     1824    (setf (random.seed-1 state) high
     1825          (random.seed-2 state) low)
    18071826    (logior high (the fixnum (logand low (ash 1 15))))))
    18081827
    1809 
     1828#+32-bit-target
    18101829(defun %bignum-random (number state)
    18111830  (let* ((bits (+ (integer-length number) 8))
     
    18361855
    18371856(defun %float-random (number state)
    1838   (if (zerop number)
    1839     number
    1840     (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum)))
    1841       (declare (dynamic-extent ratio))
    1842       (* number ratio))))
     1857  (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum)))
     1858    (declare (dynamic-extent ratio))
     1859    (* number ratio)))
    18431860
    18441861(eval-when (:compile-toplevel :execute)
  • branches/working-0711/ccl/level-0/l0-pred.lisp

    r7578 r7624  
    401401    catch-frame                         ; 4
    402402    function                            ; 5
    403     lisp-thread                         ; 6
     403    basic-stream                         ; 6
    404404    symbol                              ; 7
    405405    lock                                ; 8
     
    586586      ratio
    587587      symbol
    588       lisp-thread
     588      basic-stream
    589589      standard-instance
    590590      complex
     
    703703    package
    704704    slot-vector
    705     lisp-thread
     705    basic-stream
    706706    function-vector                                        ;8
    707707    array-header
  • branches/working-0711/ccl/level-0/l0-utils.lisp

    r6916 r7624  
    107107    (assq item list)))
    108108
     109(defun assequal (item list)
     110  (dolist (pair list)
     111    (if pair
     112      (if (equal item (car pair))
     113        (return pair)))))
     114
     115
    109116;;; (memeql item list) <=> (member item list :test #'eql :key #'identity)
    110117(defun memeql (item list)
     
    113120         ((endp l))
    114121      (when (eql (%car l) item) (return l)))
    115     (memq item list))
    116 )
     122    (memq item list)))
     123
     124(defun memequal (item list)
     125  (do* ((l list (%cdr l)))
     126       ((endp l))
     127    (when (equal (%car l) item) (return l))))
    117128
    118129
  • branches/working-0711/ccl/level-0/nfasload.lisp

    r6184 r7624  
    10451045                        *xload-startup-file*))
    10461046      (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
    1047 
     1047      (setq %system-locks% (%cons-population nil))
    10481048      ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
    10491049      ;; do SET-PACKAGE in cold load functions.
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r7463 r7624  
    18611861          (gethash lower *non-standard-lower-to-upper*) upper)))
    18621862
     1863(assert-hash-table-readonly *non-standard-upper-to-lower*)
     1864(assert-hash-table-readonly *non-standard-lower-to-upper*)
     1865
    18631866(defun %non-standard-upper-case-equivalent (char)
    18641867  (gethash char *non-standard-lower-to-upper*))
  • branches/working-0711/ccl/level-1/l1-boot-2.lisp

    r6186 r7624  
    269269      (bin-load-provide "MCL-COMPAT" "mcl-compat")
    270270      (require "LOOP")
    271       (require "HASH-CONS")
    272271      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
    273272      (l1-load-provide "VERSION" "version")
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r5944 r7624  
    17381738                             newval))))))))))
    17391739  instance)
     1740
     1741;;; Sometimes you can do a lot better at generic function dispatch than the
     1742;;; default. This supports that for the one-arg-dcode case.
     1743(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t))
     1744  nil)
     1745
     1746(defun optimize-generic-function-dispatching ()
     1747  (dolist (gf (population.data %all-gfs%))
     1748    (when (eq #'%%one-arg-dcode (%gf-dcode gf))
     1749      (let ((methods (generic-function-methods gf)))
     1750        (when (eql 1 (length methods))
     1751          (override-one-method-one-arg-dcode gf (car methods)))))))
     1752
     1753
     1754
     1755;;; dcode for a GF with a single reader method which accesses
     1756;;; a slot in a class that has no subclasses (that restriction
     1757;;; makes typechecking simpler and also ensures that the slot's
     1758;;; location is correct.)
     1759(defun singleton-reader-dcode (dt instance)
     1760  (declare (optimize (speed 3) (safety 0)))
     1761  (let* ((class (%svref dt %gf-dispatch-table-first-data))
     1762         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
     1763    (if (eq (if (eq (typecode instance) target::subtag-instance)
     1764              (%class-of-instance instance))
     1765            class)
     1766      (%slot-ref (instance.slots instance) location)
     1767      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1768
     1769;;; Dcode for a GF whose methods are all reader-methods which access a
     1770;;; slot in one or more classes which have multiple subclasses, all of
     1771;;; which (by luck or design) have the same slot-definition location.
     1772(defun reader-constant-location-dcode (dt instance)
     1773  (declare (optimize (speed 3) (safety 0)))
     1774  (let* ((classes (%svref dt %gf-dispatch-table-first-data))
     1775         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
     1776    (if (memq (if (eq (typecode instance) target::subtag-instance)
     1777              (%class-of-instance instance))
     1778            classes)
     1779      (%slot-ref (instance.slots instance) location)
     1780      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1781
     1782;;; Similar to the case above, but we use an alist to map classes
     1783;;; to their non-constant locations.
     1784(defun reader-variable-location-dcode (dt instance)
     1785  (declare (optimize (speed 3) (safety 0)))
     1786  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
     1787         (location (cdr
     1788                    (assq
     1789                     (if (eq (typecode instance) target::subtag-instance)
     1790                       (%class-of-instance instance))
     1791                     alist))))
     1792    (if location
     1793      (%slot-ref (instance.slots instance) location)
     1794      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1795
     1796(defun class-and-slot-location-alist (classes slot-name)
     1797  (let* ((alist nil))
     1798    (labels ((add-class (c)
     1799               (unless (assq c alist)
     1800                 (let* ((slots (class-slots c)))
     1801                   (unless slots
     1802                     (finalize-inheritance c)
     1803                     (setq slots (class-slots c)))
     1804                   (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist))
     1805                 (dolist (sub (class-direct-subclasses c))
     1806                   (add-class sub)))))
     1807      (dolist (class classes) (add-class class))
     1808      ;; Building the alist the way that we have should often approximate
     1809      ;; this ordering; the idea is that leaf classes are more likely to
     1810      ;; be instantiated than non-leaves.
     1811      (sort alist (lambda (c1 c2)
     1812                    (< (length (class-direct-subclasses c1))
     1813                       (length (class-direct-subclasses c2))))
     1814            :key #'car))))
     1815
     1816
     1817;;; Try to replace gf dispatch with something faster in f.
     1818(defun %snap-reader-method (f)
     1819  (when (slot-boundp f 'methods)
     1820    (let* ((methods (generic-function-methods f)))
     1821      (when (and methods
     1822                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
     1823                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
     1824                 (every (lambda (m) (null (method-qualifiers m))) methods))
     1825        (let* ((m0 (car methods))
     1826               (name (slot-definition-name (accessor-method-slot-definition m0))))
     1827          (when (every (lambda (m)
     1828                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
     1829                       (cdr methods))
     1830            ;; All methods are *STANDARD-READER-METHODS* that
     1831            ;; access the same slot name.  Build an alist of
     1832            ;; mapping all subclasses of all classes on which those
     1833            ;; methods are specialized to the effective slot's
     1834            ;; location in that subclass.
     1835            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
     1836                                    methods))
     1837                   (alist (class-and-slot-location-alist classes name))
     1838                   (loc (cdar alist))
     1839                   (dt (gf.dispatch-table f)))
     1840              ;; Only try to handle the case where all slots have
     1841              ;; :allocation :instance (and all locations - the CDRs
     1842              ;; of the alist pairs - are small, positive fixnums.
     1843              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
     1844                (clear-gf-dispatch-table dt)
     1845                (cond ((null (cdr alist))
     1846                       ;; Method is only applicable to a single class.
     1847                       (destructuring-bind (class . location) (car alist)
     1848                         (setf (%svref dt %gf-dispatch-table-first-data) class
     1849                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
     1850                               (gf.dcode f) #'singleton-reader-dcode)))
     1851                      ((dolist (other (cdr alist) t)
     1852                         (unless (eq (cdr other) loc)
     1853                           (return)))
     1854                       ;; All classes have the slot in the same location,
     1855                       ;; by luck or design.
     1856                       (setf (%svref dt %gf-dispatch-table-first-data)
     1857                             (mapcar #'car alist)
     1858                             (%svref dt (1+ %gf-dispatch-table-first-data))
     1859                             loc
     1860                             (gf.dcode f) #'reader-constant-location-dcode))
     1861                      (t
     1862                       ;; Multiple classes; the slot's location varies.
     1863                       (setf (%svref dt %gf-dispatch-table-first-data)
     1864                             alist
     1865                             
     1866                             (gf.dcode f) #'reader-variable-location-dcode)))))))))))                       
     1867
     1868
     1869;;; Iterate over all known GFs; try to optimize their dcode in cases
     1870;;; involving reader methods.
     1871
     1872(defun snap-reader-methods (&key known-sealed-world (check-conflicts t))
     1873  (declare (ignore check-conflicts))
     1874  (unless known-sealed-world
     1875    (cerror "Proceed, if it's known that no new classes or methods will be defined."
     1876            "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
     1877  (let* ((ngf 0)
     1878         (nwin 0))
     1879    (dolist (f (population.data %all-gfs%))
     1880      (incf ngf)
     1881      (when (%snap-reader-method f)
     1882        (incf nwin)))
     1883    (values ngf nwin 0)))
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r7126 r7624  
    262262             (format s "Current process ~s does not own lock ~s"
    263263                     *current-process* (slot-value c 'lock)))))
     264
     265(define-condition not-locked (lock-protocol-error)
     266  ()
     267  (:report (lambda (c s)
     268             (format s "Lock ~s isn't locked." (slot-value c 'lock)))))
     269
     270(define-condition deadlock (lock-protocol-error)
     271  ()
     272  (:report (lambda (c s)
     273             (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock)))))
    264274
    265275(define-condition package-error (error)
     
    576586  "Make an instance of a condition object using the specified initargs."
    577587  (declare (dynamic-extent init-list))
    578   (let ((class (or (and (symbolp name) (find-class name nil))
    579                    name)))
    580     (if (condition-p (class-prototype class))
    581         (apply #'make-instance class init-list)
    582         (error "~S is not a defined condition type name" name))))
     588  (if (subtypep name 'condition)
     589    (apply #'make-instance name init-list)
     590    (error "~S is not a defined condition type name" name)))
    583591
    584592(defmethod print-object ((c condition) stream)
  • branches/working-0711/ccl/level-1/l1-lisp-threads.lisp

    r7610 r7624  
    303303 
    304304         
    305 (defmacro with-self-bound-io-control-vars (&body body)
    306   `(let (; from CLtL2, table 22-7:
    307          (*package* *package*)
    308          (*print-array* *print-array*)
    309          (*print-base* *print-base*)
    310          (*print-case* *print-case*)
    311          (*print-circle* *print-circle*)
    312          (*print-escape* *print-escape*)
    313          (*print-gensym* *print-gensym*)
    314          (*print-length* *print-length*)
    315          (*print-level* *print-level*)
    316          (*print-lines* *print-lines*)
    317          (*print-miser-width* *print-miser-width*)
    318          (*print-pprint-dispatch* *print-pprint-dispatch*)
    319          (*print-pretty* *print-pretty*)
    320          (*print-radix* *print-radix*)
    321          (*print-readably* *print-readably*)
    322          (*print-right-margin* *print-right-margin*)
    323          (*read-base* *read-base*)
    324          (*read-default-float-format* *read-default-float-format*)
    325          (*read-eval* *read-eval*)
    326          (*read-suppress* *read-suppress*)
    327          (*readtable* *readtable*))
    328      ,@body))
     305
    329306
    330307
     
    964941
    965942
    966 (defvar *termination-population*
     943(defstatic *termination-population*
    967944  (%cons-terminatable-alist))
    968945
    969 (defvar *termination-population-lock* (make-lock))
     946(defstatic *termination-population-lock* (make-lock))
    970947
    971948
     
    980957or releasing of resources which needs to happen when a certain object is
    981958no longer being used."
    982   (let ((new-cell (list (cons object function)))
     959  (let ((new-cell (cons object function))
    983960        (population *termination-population*))
    984961    (without-interrupts
    985962     (with-lock-grabbed (*termination-population-lock*)
    986        (setf (cdr new-cell) (population-data population)
    987              (population-data population) new-cell)))
     963       (atomic-push-uvector-cell population population.data new-cell)))
    988964    function))
    989965
     
    992968
    993969(defun drain-termination-queue ()
    994   (let ((cell nil)
    995         (population *termination-population*))
    996     (loop
    997     (without-interrupts
    998      (with-lock-grabbed (*termination-population-lock*)
    999        (without-gcing
    1000         (let ((list (population-termination-list population)))
    1001           (unless list (return))
    1002           (setf cell (car list)
    1003                 (population-termination-list population) (cdr list))))))
    1004       (funcall (cdr cell) (car cell)))))
     970  (with-lock-grabbed (*termination-population-lock*)
     971    (let* ((population *termination-population*))
     972      (loop
     973        (multiple-value-bind (cell existed)
     974            (atomic-pop-uvector-cell population population.termination-list)
     975          (if (not existed)
     976            (return)
     977          (funcall (cdr cell) (car cell))))))))
    1005978
    1006979(defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
    1007   (let ((found-it? nil))
    1008     (flet ((test (object cell)
    1009              (and (eq object (car cell))
    1010                   (or (not function-p)
    1011                       (eq function (cdr cell)))
    1012                   (setq found-it? t))))
    1013       (declare (dynamic-extent #'test))
    1014       (without-interrupts
    1015        (with-lock-grabbed (*termination-population-lock*)
    1016          (setf (population-data *termination-population*)
    1017                (delete object (population-data *termination-population*)
    1018                        :test #'test
    1019                        :count 1))))
    1020       found-it?)))
     980  (let* ((found nil))
     981    (with-lock-grabbed (*termination-population-lock*)
     982      ;; Have to defer GCing, e.g., defer responding to a GC
     983      ;; suspend request here (that also defers interrupts)
     984      ;; We absolutely, positively can't take an exception
     985      ;; in here, so don't even bother to typecheck on
     986      ;; car/cdr etc.
     987      (with-deferred-gc
     988          (do ((spine (population-data *termination-population*) (cdr spine))
     989               (prev nil spine))
     990              ((null spine))
     991            (declare (optimize (speed 3) (safety 0)))
     992            (let* ((head (car spine))
     993                   (tail (cdr spine))
     994                   (o (car head))
     995                   (f (cdr head)))
     996              (when (and (eq o object)
     997                         (or (null function-p)
     998                             (eq function f)))
     999                (if prev
     1000                  (setf (cdr prev) tail)
     1001                  (setf (population-data *termination-population*) tail))
     1002                (setq found t)
     1003                (return)))))
     1004      found)))
     1005
    10211006
    10221007(defun termination-function (object)
  • branches/working-0711/ccl/level-1/l1-numbers.lisp

    r6027 r7624  
    421421      nil)))
    422422
     423(defun %cons-random-state (seed-1 seed-2)
     424  #+32-bit-target
     425  (gvector :istuct
     426           'random-state
     427           seed-1
     428           seed-2)
     429  #+64-bit-target
     430  (gvector :istruct
     431           'random-state
     432           (the fixnum (+ (the fixnum seed-2)
     433                          (the fixnum (ash (the fixnum seed-1) 16))))))
     434
    423435;;; random associated stuff except for the print-object method which
    424436;;; is still in "lib;numbers.lisp"
     
    428440  (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000))
    429441    (report-bad-arg seed-2 '(unsigned-byte 16)))
    430     (gvector :istruct
    431              'random-state
    432              seed-1
    433              seed-2))
    434 
    435 
    436 
    437 
     442    (%cons-random-state seed-1 seed-2))
    438443
    439444(defun make-random-state (&optional state)
     
    449454        (setq state (require-type (or state *random-state*) 'random-state))
    450455        (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state))))
    451     (gvector :istruct 'random-state seed-1 seed-2)))
     456    (%cons-random-state seed-1 seed-2)))
    452457
    453458(defun random-state-p (thing) (istruct-typep thing 'random-state))
  • branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

    r7225 r7624  
    152152    (if frame-sp
    153153      (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
     154
     155(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
     156  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     157    (when frame-sp
     158      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     159        (when (and lfun pc)
     160          (let* ((unavailable (cons nil nil)))
     161            (declare (dynamic-extent unavailable))
     162            (let* ((value (arg-value nil frame-sp lfun pc unavailable name)))
     163              (if (eq value unavailable)
     164                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
     165                (toplevel-print (list value))))))))))
     166
     167(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
     168  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     169    (when frame-sp
     170      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     171        (when (and lfun pc)
     172          (or (set-arg-value nil frame-sp lfun pc name new)
     173              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
     174   
     175
     176(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
     177binding of that symbol is used - or an integer index into the frame's set of local bindings."
     178  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     179    (when frame-sp
     180      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     181        (when (and lfun pc)
     182          (let* ((unavailable (cons nil nil)))
     183            (declare (dynamic-extent unavailable))
     184            (let* ((value (local-value nil frame-sp lfun pc unavailable name)))
     185              (if (eq value unavailable)
     186                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
     187                (toplevel-print (list value))))))))))
     188
     189(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>."
     190  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
     191    (when frame-sp
     192      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
     193        (when (and lfun pc)
     194          (or (set-local-value nil frame-sp lfun pc name new)
     195              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
     196
    154197
    155198(define-toplevel-command :break form (frame-number)
     
    272315                          (cons keyword params)
    273316                          keyword)))
    274                     (params param)))))))))))
     317                    (params (eval param))))))))))))
    275318
    276319;;; Read a form from the specified stream.
     
    349392    (dolist (x bogus-globals)
    350393      (set x (funcall (pop newvals))))
    351     (when (and *debugger-hook* *break-on-errors*)
     394    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
    352395      (let ((hook *debugger-hook*)
    353396            (*debugger-hook* nil))
     
    363406              (format s "~s" oldval))
    364407            (format s ", was reset to ~s ." (symbol-value bogusness)))))
    365       (if *break-on-errors*
     408      (if (and *break-on-errors* (not *batch-flag*))
    366409        (break-loop condition error-pointer)
    367         (abort)))))
     410        (if *batch-flag*
     411          (quit -1)
     412          (abort))))))
    368413
    369414(defun break (&optional string &rest args)
  • branches/working-0711/ccl/level-1/l1-sockets.lisp

    r6914 r7624  
    148148            "WITH-OPEN-SOCKET"))
    149149
    150 (eval-when (:compile-toplevel)
     150(eval-when (:compile-toplevel :execute)
    151151  #+linuxppc-target
    152152  (require "PPC-LINUX-SYSCALLS")
     
    168168(define-condition socket-creation-error (simple-error)
    169169  ((code :initarg :code :reader socket-creation-error-code)
    170    (identifier :initform :unknown :initarg :identifier :reader socket-creationg-error-identifier)
     170   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
    171171   (situation :initarg :situation :reader socket-creation-error-situation)))
    172172
     
    603603                    local-port local-host backlog class out-of-band-inline
    604604                    local-filename remote-filename sharing basic
    605                     external-format)
     605                    external-format (auto-close t))
    606606  "Create and return a new socket."
    607607  (declare (dynamic-extent keys))
     
    609609                   keepalive reuse-address nodelay broadcast linger
    610610                   local-port local-host backlog class out-of-band-inline
    611                    local-filename remote-filename sharing basic external-format))
     611                   local-filename remote-filename sharing basic external-format
     612                   auto-close))
    612613  (ecase address-family
    613614    ((:file) (apply #'make-file-socket keys))
     
    696697
    697698
    698 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) &allow-other-keys)
     699(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) &allow-other-keys)
    699700  (let* ((external-format (normalize-external-format :socket external-format)))
    700701    (let ((element-type (ecase format
     
    711712                      :encoding (external-format-character-encoding external-format)
    712713                      :line-termination (external-format-line-termination external-format)
    713                       :basic basic))))
    714 
    715 (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic &allow-other-keys)
     714                      :basic basic
     715                      :auto-close auto-close))))
     716
     717(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic (auto-close t) &allow-other-keys)
    716718  (let* ((external-format (normalize-external-format :socket external-format)))
    717719 
     
    729731                      :sharing sharing
    730732                      :character-p (not (eq format :binary))
    731                       :basic basic))))
     733                      :basic basic
     734                      :auto-close auto-close))))
    732735
    733736(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
     
    11041107          (pref addr :in_addr.s_addr))))))
    11051108
    1106 (defun c_socket (domain type protocol)
     1109(defun c_socket_1 (domain type protocol)
    11071110  #-linuxppc-target
    11081111  (syscall syscalls::socket domain type protocol)
     
    11131116          (paref params (:* :unsigned-long) 2) protocol)
    11141117    (syscall syscalls::socketcall 1 params)))
     1118
     1119(defun c_socket (domain type protocol)
     1120  (let* ((fd (c_socket_1 domain type protocol)))
     1121    (when (or (eql fd (- #$EMFILE))
     1122              (eql fd (- #$ENFILE)))
     1123      (gc)
     1124      (drain-termination-queue)
     1125      (setq fd (c_socket_1 domain type protocol)))
     1126    fd))
     1127     
    11151128
    11161129(defun init-unix-sockaddr (addr path)
  • branches/working-0711/ccl/level-1/l1-streams.lisp

    r7444 r7624  
    32573257
    32583258
    3259    
     3259(defun optimal-buffer-size (fd)
     3260  (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
     3261
    32603262
    32613263;;; Note that we can get "bivalent" streams by specifiying :character-p t
     
    32643266                          (direction :input)
    32653267                          (interactive t)
    3266                           (elements-per-buffer *elements-per-buffer*)
     3268                          (elements-per-buffer (optimal-buffer-size fd))
    32673269                          (element-type 'character)
    32683270                          (class 'fd-stream)
     
    32723274                          (basic nil)
    32733275                          encoding
    3274                           line-termination)
     3276                          line-termination
     3277                          auto-close)
    32753278  (when line-termination
    32763279    (setq line-termination
     
    32823285         (out-p (member direction '(:io :output)))
    32833286         (class-name (select-stream-class class in-p out-p character-p))
    3284          (class (find-class class-name)))
    3285     (make-ioblock-stream class
    3286                          :insize (if in-p elements-per-buffer)
    3287                          :outsize (if out-p elements-per-buffer)
    3288                          :device fd
    3289                          :interactive interactive
    3290                          :element-type element-type
    3291                          :advance-function (if in-p
    3292                                              (select-stream-advance-function class direction))
    3293                          :listen-function (if in-p 'fd-stream-listen)
    3294                          :eofp-function (if in-p 'fd-stream-eofp)
    3295                          :force-output-function (if out-p
    3296                                                   (select-stream-force-output-function class direction))
    3297                          :close-function 'fd-stream-close
    3298                          :sharing sharing
    3299                          :character-p character-p
    3300                          :encoding encoding
    3301                          :line-termination line-termination)))
     3287         (class (find-class class-name))
     3288         (stream
     3289          (make-ioblock-stream class
     3290                               :insize (if in-p elements-per-buffer)
     3291                               :outsize (if out-p elements-per-buffer)
     3292                               :device fd
     3293                               :interactive interactive
     3294                               :element-type element-type
     3295                               :advance-function (if in-p
     3296                                                    (select-stream-advance-function class direction))
     3297                               :listen-function (if in-p 'fd-stream-listen)
     3298                               :eofp-function (if in-p 'fd-stream-eofp)
     3299                               :force-output-function (if out-p
     3300                                                         (select-stream-force-output-function class direction))
     3301                               :close-function 'fd-stream-close
     3302                               :sharing sharing
     3303                               :character-p character-p
     3304                               :encoding encoding
     3305                               :line-termination line-termination)))
     3306    (if auto-close
     3307       (terminate-when-unreachable stream
     3308                                   (lambda (stream)
     3309                                     (close stream :abort t))))
     3310    stream))
     3311
    33023312 
    33033313;;;  Fundamental streams.
     
    35933603    s))
    35943604
    3595 (defmethod %stream-ioblock ((s basic-stream))
    3596   (basic-stream.state s))
     3605
    35973606
    35983607(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
     
    46394648
    46404649(defun stream-ioblock (stream error-if-nil)
    4641   (or (%stream-ioblock stream)
     4650  (or (if (typep stream 'basic-stream)
     4651        (basic-stream.state stream)
     4652        (%stream-ioblock stream))
    46424653      (when error-if-nil
    46434654        (stream-is-closed stream))))
     
    47494760
    47504761(defmethod stream-surrounding-characters ((stream basic-character-input-stream))
    4751     (let* ((ioblock (stream-ioblock stream nil)))
     4762    (let* ((ioblock (basic-stream.state stream)))
    47524763      (and ioblock (%ioblock-surrounding-characters ioblock))))
    47534764
     
    53615372
    53625373(defun fd-stream-close (s ioblock)
     5374  (cancel-terminate-when-unreachable s)
    53635375  (when (ioblock-dirty ioblock)
    53645376    (stream-finish-output s))
     
    57185730
    57195731(defmethod stream-external-format ((s basic-character-stream))
    5720   (%ioblock-external-format (stream-ioblock s t)))
     5732  (%ioblock-external-format (basic-stream-ioblock s)))
    57215733
    57225734(defmethod (setf stream-external-format) (new (s basic-character-stream))
    5723   (setf (%ioblock-external-format (stream-ioblock s t))
     5735  (setf (%ioblock-external-format (basic-stream-ioblock s))
    57245736        (normalize-external-format (stream-domain s) new)))
    57255737
  • branches/working-0711/ccl/level-1/l1-unicode.lisp

    r7307 r7624  
    28622862               (setf (schar string i) (or char #\Replacement_Character)))))))
    28632863    :memory-encode-function
    2864     (nfunction
    2865      utf-8-memory-encode
    2866      (lambda (string pointer idx start end)
    2867        (declare (fixnum idx))
    2868        (do* ((i start (1+ i)))
    2869             ((>= i end) idx)
    2870          (let* ((code (char-code (schar string i))))
    2871            (declare (type (mod #x110000) code))
    2872            (cond ((< code #x80)
    2873                   (setf (%get-unsigned-byte pointer idx) code)
    2874                   (incf idx))
    2875                  ((< code #x800)
    2876                   (setf (%get-unsigned-byte pointer idx)
    2877                         (logior #xc0 (the fixnum (ash code -6))))
    2878                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2879                         (logior #x80 (the fixnum (logand code #x3f))))
    2880                   (incf idx 2))
    2881                  ((< code #x10000)
    2882                   (setf (%get-unsigned-byte pointer idx)
    2883                         (logior #xe0 (the fixnum (ash code -12))))
    2884                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2885                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    2886                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
    2887                         (logior #x80 (the fixnum (logand code #x3f))))
    2888                   (incf idx 3))
    2889                  (t
    2890                   (setf (%get-unsigned-byte pointer idx)
    2891                         (logior #xf0
    2892                                 (the fixnum (logand #x7 (the fixnum (ash code -18))))))
    2893                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2894                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
    2895                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
    2896                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    2897                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
    2898                         (logand #x3f code))
    2899                   (incf idx 4)))))))
     2864    #'utf-8-memory-encode
    29002865    :memory-decode-function
    2901     (nfunction
    2902      utf-8-memory-decode
    2903      (lambda (pointer noctets idx string)
    2904        (declare (fixnum noctets idx))
    2905        (do* ((i 0 (1+ i))
    2906              (end (+ idx noctets))
    2907              (index idx (1+ index)))
    2908             ((>= index end) (if (= index end) index 0))
    2909          (let* ((1st-unit (%get-unsigned-byte pointer index)))
    2910            (declare (type (unsigned-byte 8) 1st-unit))
    2911            (let* ((char (if (< 1st-unit #x80)
    2912                           (code-char 1st-unit)
    2913                           (if (>= 1st-unit #xc2)
    2914                             (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
    2915                               (declare (type (unsigned-byte 8) 2nd-unit))
    2916                               (if (< 1st-unit #xe0)
    2917                                 (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2918                                   (code-char
    2919                                    (logior
    2920                                     (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
    2921                                     (the fixnum (logxor 2nd-unit #x80)))))
    2922                                 (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
    2923                                   (declare (type (unsigned-byte 8) 3rd-unit))
    2924                                   (if (< 1st-unit #xf0)
    2925                                     (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2926                                              (< (the fixnum (logxor 3rd-unit #x80)) #x40)
    2927                                              (or (>= 1st-unit #xe1)
    2928                                                  (>= 2nd-unit #xa0)))
    2929                                       (code-char (the fixnum
    2930                                                    (logior (the fixnum
    2931                                                              (ash (the fixnum (logand 1st-unit #xf))
    2932                                                                   12))
    2933                                                            (the fixnum
    2934                                                              (logior
    2935                                                               (the fixnum
    2936                                                                 (ash (the fixnum (logand 2nd-unit #x3f))
    2937                                                                      6))
    2938                                                               (the fixnum (logand 3rd-unit #x3f))))))))
    2939                                     (if (< 1st-unit #xf8)
    2940                                       (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
    2941                                         (declare (type (unsigned-byte 8) 4th-unit))
    2942                                         (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2943                                                  (< (the fixnum (logxor 3rd-unit #x80)) #x40)
    2944                                                  (< (the fixnum (logxor 4th-unit #x80)) #x40)
    2945                                                  (or (>= 1st-unit #xf1)
    2946                                                      (>= 2nd-unit #x90)))
    2947                                           (code-char
    2948                                            (logior
    2949                                             (the fixnum
    2950                                               (logior
    2951                                                (the fixnum
    2952                                                  (ash (the fixnum (logand 1st-unit 7)) 18))
    2953                                                (the fixnum
    2954                                                  (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
    2955                                             (the fixnum
    2956                                               (logior
    2957                                                (the fixnum
    2958                                                  (ash (the fixnum (logxor 3rd-unit #x80)) 6))
    2959                                                (the fixnum (logxor 4th-unit #x80)))))))))))))))))
    2960              (setf (schar string i) (or char #\Replacement_Character)))))))
     2866    #'utf-8-memory-decode
    29612867    :octets-in-string-function
    2962     (nfunction
    2963      utf-8-octets-in-string
    2964      (lambda (string start end)
    2965        (if (>= end start)
    2966          (do* ((noctets 0)
    2967                (i start (1+ i)))
    2968               ((= i end) noctets)
    2969            (declare (fixnum noctets))
    2970            (let* ((code (char-code (schar string i))))
    2971              (declare (type (mod #x110000) code))
    2972              (incf noctets
    2973                    (if (< code #x80)
    2974                      1
    2975                      (if (< code #x800)
    2976                        2
    2977                        (if (< code #x10000)
    2978                          3
    2979                          4))))))
    2980          0)))
     2868    #'utf-8-octets-in-string
    29812869    :length-of-vector-encoding-function
    29822870    (nfunction
     
    29992887             (setq nchars (1+ nchars) i nexti))))))
    30002888    :length-of-memory-encoding-function
    3001     (nfunction
    3002      utf-8-length-of-memory-encoding
    3003      (lambda (pointer noctets start)
    3004        (do* ((i start)
    3005              (end (+ start noctets))
    3006              (nchars 0 (1+ nchars)))
    3007             ((= i end) (values nchars i))
    3008          (let* ((code (%get-unsigned-byte pointer i))
    3009                 (nexti (+ i (cond ((< code #x80) 1)
    3010                                   ((< code #xe0) 2)
    3011                                   ((< code #xf0) 3)
    3012                                   (t 4)))))
    3013            (declare (type (unsigned-byte 8) code))
    3014            (if (> nexti end)
    3015              (return (values nchars i))
    3016              (setq i nexti))))))
     2889    #'utf-8-length-of-memory-encoding
    30172890    :decode-literal-code-unit-limit #x80
    30182891    :encode-literal-char-code-limit #x80   
     
    46514524                 data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s))))))))
    46524525     
     4526
     4527
     4528
     4529
     4530;;; This is an array of 256 integers, that (sparsely) encodes 64K bits.
     4531;;; (There might be as many as 256 significant bits in some of entries
     4532;;; in this table.)
     4533(defstatic *bmp-combining-bitmap*
     4534    #(
     4535        #x00
     4536        #x00
     4537        #x00
     4538        #xFFFF0000FFFFFFFFFFFFFFFFFFFF
     4539        #x37800000000000000000000000000000000
     4540        #x16BBFFFFFBFFFE000000000000000000000000000000000000
     4541        #x3D9FFFC00000000000000000000000010000003FF8000000000000000000
     4542        #x1FFC00000000000000000000007FFFFFF000000020000
     4543       
     4544        #x00
     4545        #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E
     4546        #x3BBFD00000000000000E0003000000003987D000000000000004
     4547        #x803DC7C0000000000000040000000000C0398FD00000000000000E
     4548        #x603DDFC00000000000000C0000000000603DDFC00000000000000E
     4549        #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C
     4550        #x3F001BF20000000000000000000000007F8007F2000000000000
     4551        #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000
     4552       
     4553        #x3C0000003C7F00000000000
     4554        #x7FFFFFF0000000000003FFFFE000000000000000000000000
     4555        #x00
     4556        #x00
     4557        #x00
     4558        #x00
     4559        #x00
     4560        #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000       
     4561       
     4562        #x2000000000000000000000000000000000000003800
     4563        #x00
     4564        #x00
     4565        #x00
     4566        #x00
     4567        #x00
     4568        #x00
     4569        #x00
     4570       
     4571        #x7FFFFFF0000000000000000000000000000000000000000000000000000
     4572        #x00
     4573        #x00
     4574        #x00
     4575        #x00
     4576        #x00
     4577        #x00
     4578        #x00
     4579       
     4580        #x00
     4581        #x00
     4582        #x00
     4583        #x00
     4584        #x00
     4585        #x00
     4586        #x00
     4587        #x00
     4588       
     4589        #x600000000000000000000000000FC0000000000
     4590        #x00
     4591        #x00
     4592        #x00
     4593        #x00
     4594        #x00
     4595        #x00
     4596        #x00
     4597       
     4598        #x00
     4599        #x00
     4600        #x00
     4601        #x00
     4602        #x00
     4603        #x00
     4604        #x00
     4605        #x00
     4606       
     4607        #x00
     4608        #x00
     4609        #x00
     4610        #x00
     4611        #x00
     4612        #x00
     4613        #x00
     4614        #x00
     4615       
     4616        #x00
     4617        #x00
     4618        #x00
     4619        #x00
     4620        #x00
     4621        #x00
     4622        #x00
     4623        #x00
     4624       
     4625        #x00
     4626        #x00
     4627        #x00
     4628        #x00
     4629        #x00
     4630        #x00
     4631        #x00
     4632        #x00
     4633       
     4634        #x00
     4635        #x00
     4636        #x00
     4637        #x00
     4638        #x00
     4639        #x00
     4640        #x00
     4641        #x00
     4642       
     4643        #x00
     4644        #x00
     4645        #x00
     4646        #x00
     4647        #x00
     4648        #x00
     4649        #x00
     4650        #x00
     4651       
     4652        #x00
     4653        #x00
     4654        #x00
     4655        #x00
     4656        #x00
     4657        #x00
     4658        #x00
     4659        #x00
     4660       
     4661        #x00
     4662        #x00
     4663        #x00
     4664        #x00
     4665        #x00
     4666        #x00
     4667        #x00
     4668        #x00
     4669       
     4670        #x00
     4671        #x00
     4672        #x00
     4673        #x00
     4674        #x00
     4675        #x00
     4676        #x00
     4677        #x00
     4678       
     4679        #x00
     4680        #x00
     4681        #x00
     4682        #x00
     4683        #x00
     4684        #x00
     4685        #x00
     4686        #x00
     4687       
     4688        #x00
     4689        #x00
     4690        #x00
     4691        #x00
     4692        #x00
     4693        #x00
     4694        #x00
     4695        #x00
     4696       
     4697        #x00
     4698        #x00
     4699        #x00
     4700        #x00
     4701        #x00
     4702        #x00
     4703        #x00
     4704        #x00
     4705       
     4706        #x00
     4707        #x00
     4708        #x00
     4709        #x00
     4710        #x00
     4711        #x00
     4712        #x00
     4713        #x00
     4714       
     4715        #x00
     4716        #x00
     4717        #x00
     4718        #x00
     4719        #x00
     4720        #x00
     4721        #x00
     4722        #x00
     4723       
     4724        #x00
     4725        #x00
     4726        #x00
     4727        #x00
     4728        #x00
     4729        #x00
     4730        #x00
     4731        #x00
     4732       
     4733        #x00
     4734        #x00
     4735        #x00
     4736        #x00
     4737        #x00
     4738        #x00
     4739        #x00
     4740        #x00
     4741       
     4742        #x00
     4743        #x00
     4744        #x00
     4745        #x00
     4746        #x00
     4747        #x00
     4748        #x00
     4749        #x00
     4750       
     4751        #x00
     4752        #x00
     4753        #x00
     4754        #x00
     4755        #x00
     4756        #x00
     4757        #x00
     4758        #x00
     4759       
     4760        #x00
     4761        #x00
     4762        #x00
     4763        #x00
     4764        #x00
     4765        #x00
     4766        #x00
     4767        #x00
     4768       
     4769        #x00
     4770        #x00
     4771        #x00
     4772        #x00
     4773        #x00
     4774        #x00
     4775        #x00
     4776        #x00
     4777       
     4778        #x00
     4779        #x00
     4780        #x00
     4781        #x00
     4782        #x00
     4783        #x00
     4784        #x00
     4785        #x00
     4786       
     4787        #x00
     4788        #x00
     4789        #x00
     4790        #x00
     4791        #x00
     4792        #x00
     4793        #x00
     4794        #x00
     4795       
     4796        #x00
     4797        #x00
     4798        #x00
     4799        #x00
     4800        #x00
     4801        #x00
     4802        #x00
     4803        #x00
     4804       
     4805        #x00
     4806        #x00
     4807        #x00
     4808        #x00
     4809        #x00
     4810        #x00
     4811        #x00
     4812        #x00
     4813       
     4814        #x00
     4815        #x00
     4816        #x00
     4817        #x40000000
     4818        #x00
     4819        #x00
     4820        #xF0000FFFF
     4821        #x00))
     4822
     4823(defun is-combinable (char)
     4824  (let* ((code (char-code char)))
     4825    (declare (type (mod #x110000) code))
     4826    (when (< code #x1000)
     4827      (logbitp (ldb (byte 8 0) code)
     4828               (svref *bmp-combining-bitmap* (ldb (byte 8 8) code))))))
     4829
     4830(defstatic *bmp-combining-chars*
     4831  #(#\Combining_Grave_Accent
     4832    #\Combining_Acute_Accent
     4833    #\Combining_Circumflex_Accent
     4834    #\Combining_Tilde
     4835    #\Combining_Macron
     4836    #\Combining_Breve
     4837    #\Combining_Dot_Above
     4838    #\Combining_Diaeresis
     4839    #\Combining_Hook_Above
     4840    #\Combining_Ring_Above
     4841    #\Combining_Double_Acute_Accent
     4842    #\Combining_Caron
     4843    #\Combining_Double_Grave_Accent
     4844    #\Combining_Inverted_Breve
     4845    #\Combining_Comma_Above
     4846    #\Combining_Reversed_Comma_Above
     4847    #\Combining_Horn
     4848    #\Combining_Dot_Below
     4849    #\Combining_Diaeresis_Below
     4850    #\Combining_Ring_Below
     4851    #\Combining_Comma_Below
     4852    #\Combining_Cedilla
     4853    #\Combining_Ogonek
     4854    #\Combining_Circumflex_Accent_Below
     4855    #\Combining_Breve_Below
     4856    #\Combining_Tilde_Below
     4857    #\Combining_Macron_Below
     4858    #\Combining_Long_Solidus_Overlay
     4859    #\Combining_Greek_Perispomeni
     4860    #\Combining_Greek_Ypogegrammeni
     4861    #\Arabic_Maddah_Above
     4862    #\Arabic_Hamza_Above
     4863    #\Arabic_Hamza_Below
     4864    #\U+093C
     4865    #\U+09BE
     4866    #\U+09D7
     4867    #\U+0B3E
     4868    #\U+0B56
     4869    #\U+0B57
     4870    #\U+0BBE
     4871    #\U+0BD7
     4872    #\U+0C56
     4873    #\U+0CC2
     4874    #\U+0CD5
     4875    #\U+0CD6
     4876    #\U+0D3E
     4877    #\U+0D57
     4878    #\U+0DCA
     4879    #\U+0DCF
     4880    #\U+0DDF
     4881    #\U+102E
     4882    #\U+3099
     4883    #\U+309A))
     4884
     4885(defstatic *bmp-combining-base-chars*
     4886  #(
     4887    ;; #\Combining_Grave_Accent
     4888
     4889    #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y
     4890      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
     4891      #\Latin_Capital_Letter_E_With_Circumflex
     4892      #\Latin_Capital_Letter_O_With_Circumflex
     4893      #\Latin_Capital_Letter_U_With_Diaeresis
     4894      #\Latin_Small_Letter_A_With_Circumflex
     4895      #\Latin_Small_Letter_E_With_Circumflex
     4896      #\Latin_Small_Letter_O_With_Circumflex
     4897      #\Latin_Small_Letter_U_With_Diaeresis
     4898      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
     4899      #\Latin_Capital_Letter_E_With_Macron
     4900      #\Latin_Small_Letter_E_With_Macron
     4901      #\Latin_Capital_Letter_O_With_Macron
     4902      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn
     4903      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
     4904      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
     4905      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
     4906      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
     4907      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
     4908      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
     4909      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
     4910      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
     4911      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
     4912      #\Greek_Small_Letter_Upsilon_With_Dialytika
     4913      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I
     4914      #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01
     4915      #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20
     4916      #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39
     4917      #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59
     4918      #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
     4919
     4920
     4921    ;; #\Combining_Acute_Accent
     4922
     4923    #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z
     4924      #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z
     4925      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
     4926      #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae
     4927      #\Latin_Capital_Letter_C_With_Cedilla
     4928      #\Latin_Capital_Letter_E_With_Circumflex
     4929      #\Latin_Capital_Letter_I_With_Diaeresis
     4930      #\Latin_Capital_Letter_O_With_Circumflex
     4931      #\Latin_Capital_Letter_O_With_Tilde
     4932      #\Latin_Capital_Letter_O_With_Stroke
     4933      #\Latin_Capital_Letter_U_With_Diaeresis
     4934      #\Latin_Small_Letter_A_With_Circumflex
     4935      #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae
     4936      #\Latin_Small_Letter_C_With_Cedilla
     4937      #\Latin_Small_Letter_E_With_Circumflex
     4938      #\Latin_Small_Letter_I_With_Diaeresis
     4939      #\Latin_Small_Letter_O_With_Circumflex
     4940      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke
     4941      #\Latin_Small_Letter_U_With_Diaeresis
     4942      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
     4943      #\Latin_Capital_Letter_E_With_Macron
     4944      #\Latin_Small_Letter_E_With_Macron
     4945      #\Latin_Capital_Letter_O_With_Macron
     4946      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde
     4947      #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn
     4948      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
     4949      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
     4950      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
     4951      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
     4952      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
     4953      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
     4954      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
     4955      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
     4956      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
     4957      #\Greek_Small_Letter_Upsilon_With_Dialytika
     4958      #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe
     4959      #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe
     4960      #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09
     4961      #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28
     4962      #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41
     4963      #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
     4964      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
     4965
     4966
     4967    ;; #\Combining_Circumflex_Accent
     4968
     4969    #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g
     4970      #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8
     4971      #\U+1EB9 #\U+1ECC #\U+1ECD)
     4972
     4973
     4974    ;; #\Combining_Tilde
     4975
     4976    #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y
     4977      #\Latin_Capital_Letter_A_With_Circumflex
     4978      #\Latin_Capital_Letter_E_With_Circumflex
     4979      #\Latin_Capital_Letter_O_With_Circumflex
     4980      #\Latin_Small_Letter_A_With_Circumflex
     4981      #\Latin_Small_Letter_E_With_Circumflex
     4982      #\Latin_Small_Letter_O_With_Circumflex
     4983      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
     4984      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
     4985      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
     4986
     4987
     4988    ;; #\Combining_Macron
     4989
     4990    #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y
     4991      #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae
     4992      #\Latin_Capital_Letter_O_With_Tilde
     4993      #\Latin_Capital_Letter_O_With_Diaeresis
     4994      #\Latin_Capital_Letter_U_With_Diaeresis
     4995      #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae
     4996      #\Latin_Small_Letter_O_With_Tilde
     4997      #\Latin_Small_Letter_O_With_Diaeresis
     4998      #\Latin_Small_Letter_U_With_Diaeresis
     4999      #\Latin_Capital_Letter_O_With_Ogonek
     5000      #\Latin_Small_Letter_O_With_Ogonek
     5001      #\Latin_Capital_Letter_A_With_Dot_Above
     5002      #\Latin_Small_Letter_A_With_Dot_Above
     5003      #\Latin_Capital_Letter_O_With_Dot_Above
     5004      #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha
     5005      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
     5006      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
     5007      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I
     5008      #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I
     5009      #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B)
     5010
     5011
     5012    ;; #\Combining_Breve
     5013
     5014    #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u
     5015      #\Latin_Capital_Letter_E_With_Cedilla
     5016      #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha
     5017      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
     5018      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
     5019      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A
     5020      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe
     5021      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U
     5022      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
     5023      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I
     5024      #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1)
     5025
     5026
     5027    ;; #\Combining_Dot_Above
     5028
     5029    #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W
     5030      #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s
     5031      #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute
     5032      #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron
     5033      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62
     5034      #\U+1E63)
     5035
     5036
     5037    ;; #\Combining_Diaeresis
     5038
     5039    #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w
     5040      #\x #\y #\Latin_Capital_Letter_O_With_Tilde
     5041      #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron
     5042      #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota
     5043      #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota
     5044      #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol
     5045      #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I
     5046      #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie
     5047      #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze
     5048      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O
     5049      #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che
     5050      #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E
     5051      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
     5052      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze
     5053      #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O
     5054      #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che
     5055      #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E
     5056      #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I
     5057      #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa
     5058      #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O)
     5059
     5060
     5061    ;; #\Combining_Hook_Above
     5062
     5063    #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y
     5064      #\Latin_Capital_Letter_A_With_Circumflex
     5065      #\Latin_Capital_Letter_E_With_Circumflex
     5066      #\Latin_Capital_Letter_O_With_Circumflex
     5067      #\Latin_Small_Letter_A_With_Circumflex
     5068      #\Latin_Small_Letter_E_With_Circumflex
     5069      #\Latin_Small_Letter_O_With_Circumflex
     5070      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
     5071      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
     5072      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
     5073
     5074
     5075    ;; #\Combining_Ring_Above
     5076
     5077    #(#\A #\U #\a #\u #\w #\y)
     5078
     5079
     5080    ;; #\Combining_Double_Acute_Accent
     5081
     5082    #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U
     5083      #\Cyrillic_Small_Letter_U)
     5084
     5085
     5086    ;; #\Combining_Caron
     5087
     5088    #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a
     5089      #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z
     5090      #\Latin_Capital_Letter_U_With_Diaeresis
     5091      #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh
     5092      #\Latin_Small_Letter_Ezh)
     5093
     5094
     5095    ;; #\Combining_Double_Grave_Accent
     5096
     5097    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u
     5098      #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa)
     5099
     5100
     5101    ;; #\Combining_Inverted_Breve
     5102
     5103    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u)
     5104
     5105
     5106    ;; #\Combining_Comma_Above
     5107
     5108    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
     5109      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
     5110      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega
     5111      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
     5112      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
     5113      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
     5114      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
     5115
     5116
     5117    ;; #\Combining_Reversed_Comma_Above
     5118
     5119    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
     5120      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
     5121      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho
     5122      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
     5123      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
     5124      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
     5125      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
     5126      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
     5127
     5128
     5129    ;; #\Combining_Horn
     5130
     5131    #(#\O #\U #\o #\u)
     5132
     5133
     5134    ;; #\Combining_Dot_Below
     5135
     5136    #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W
     5137      #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u
     5138      #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn
     5139      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
     5140      #\Latin_Small_Letter_U_With_Horn)
     5141
     5142
     5143    ;; #\Combining_Diaeresis_Below
     5144
     5145    #(#\U #\u)
     5146
     5147
     5148    ;; #\Combining_Ring_Below
     5149
     5150    #(#\A #\a)
     5151
     5152
     5153    ;; #\Combining_Comma_Below
     5154
     5155    #(#\S #\T #\s #\t)
     5156
     5157
     5158    ;; #\Combining_Cedilla
     5159
     5160    #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k
     5161      #\l #\n #\r #\s #\t)
     5162
     5163
     5164    ;; #\Combining_Ogonek
     5165
     5166    #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u)
     5167
     5168
     5169    ;; #\Combining_Circumflex_Accent_Below
     5170
     5171    #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u)
     5172
     5173
     5174    ;; #\Combining_Breve_Below
     5175
     5176    #(#\H #\h)
     5177
     5178
     5179    ;; #\Combining_Tilde_Below
     5180
     5181    #(#\E #\I #\U #\e #\i #\u)
     5182
     5183
     5184    ;; #\Combining_Macron_Below
     5185
     5186    #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z)
     5187
     5188
     5189    ;; #\Combining_Long_Solidus_Overlay
     5190
     5191    #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4
     5192      #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243
     5193      #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272
     5194      #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D
     5195      #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2
     5196      #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5)
     5197
     5198
     5199    ;; #\Combining_Greek_Perispomeni
     5200
     5201    #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta
     5202      #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon
     5203      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
     5204      #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08
     5205      #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31
     5206      #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
     5207      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
     5208
     5209
     5210    ;; #\Combining_Greek_Ypogegrammeni
     5211
     5212    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta
     5213      #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos
     5214      #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha
     5215      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega
     5216      #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02
     5217      #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09
     5218      #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20
     5219      #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27
     5220      #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E
     5221      #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65
     5222      #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C
     5223      #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6
     5224      #\U+1FC6 #\U+1FF6)
     5225
     5226
     5227    ;; #\Arabic_Maddah_Above
     5228
     5229    #(#\Arabic_Letter_Alef)
     5230
     5231
     5232    ;; #\Arabic_Hamza_Above
     5233
     5234    #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh
     5235      #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree
     5236      #\Arabic_Letter_Ae)
     5237
     5238
     5239    ;; #\Arabic_Hamza_Below
     5240
     5241    #(#\Arabic_Letter_Alef)
     5242
     5243
     5244    ;; #\U+093C
     5245
     5246    #(#\U+0928 #\U+0930 #\U+0933)
     5247
     5248
     5249    ;; #\U+09BE
     5250
     5251    #(#\U+09C7)
     5252
     5253
     5254    ;; #\U+09D7
     5255
     5256    #(#\U+09C7)
     5257
     5258
     5259    ;; #\U+0B3E
     5260
     5261    #(#\U+0B47)
     5262
     5263
     5264    ;; #\U+0B56
     5265
     5266    #(#\U+0B47)
     5267
     5268
     5269    ;; #\U+0B57
     5270
     5271    #(#\U+0B47)
     5272
     5273
     5274    ;; #\U+0BBE
     5275
     5276    #(#\U+0BC6 #\U+0BC7)
     5277
     5278
     5279    ;; #\U+0BD7
     5280
     5281    #(#\U+0B92 #\U+0BC6)
     5282
     5283
     5284    ;; #\U+0C56
     5285
     5286    #(#\U+0C46)
     5287
     5288
     5289    ;; #\U+0CC2
     5290
     5291    #(#\U+0CC6)
     5292
     5293
     5294    ;; #\U+0CD5
     5295
     5296    #(#\U+0CBF #\U+0CC6 #\U+0CCA)
     5297
     5298
     5299    ;; #\U+0CD6
     5300
     5301    #(#\U+0CC6)
     5302
     5303
     5304    ;; #\U+0D3E
     5305
     5306    #(#\U+0D46 #\U+0D47)
     5307
     5308
     5309    ;; #\U+0D57
     5310
     5311    #(#\U+0D46)
     5312
     5313
     5314    ;; #\U+0DCA
     5315
     5316    #(#\U+0DD9 #\U+0DDC)
     5317
     5318
     5319    ;; #\U+0DCF
     5320
     5321    #(#\U+0DD9)
     5322
     5323
     5324    ;; #\U+0DDF
     5325
     5326    #(#\U+0DD9)
     5327
     5328
     5329    ;; #\U+102E
     5330
     5331    #(#\U+1025)
     5332
     5333
     5334    ;; #\U+3099
     5335
     5336    #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055
     5337      #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064
     5338      #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B
     5339      #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3
     5340      #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1
     5341      #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8
     5342      #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD)
     5343
     5344
     5345    ;; #\U+309A
     5346
     5347    #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2
     5348      #\U+30D5 #\U+30D8 #\U+30DB)
     5349    ))
     5350
     5351(defstatic *bmp-precombined-chars*
     5352  #(
     5353
     5354    ;; #\Combining_Grave_Accent
     5355
     5356    #(#\Latin_Capital_Letter_A_With_Grave
     5357      #\Latin_Capital_Letter_E_With_Grave
     5358      #\Latin_Capital_Letter_I_With_Grave
     5359      #\Latin_Capital_Letter_N_With_Grave
     5360      #\Latin_Capital_Letter_O_With_Grave
     5361      #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2
     5362      #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave
     5363      #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave
     5364      #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave
     5365      #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2
     5366      #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1
     5367      #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0
     5368      #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD
     5369      #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8
     5370      #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78
     5371      #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2
     5372      #\Cyrillic_Capital_Letter_Ie_With_Grave
     5373      #\Cyrillic_Capital_Letter_I_With_Grave
     5374      #\Cyrillic_Small_Letter_Ie_With_Grave
     5375      #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A
     5376      #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23
     5377      #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42
     5378      #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62
     5379      #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD)
     5380
     5381
     5382    ;; #\Combining_Acute_Accent
     5383
     5384    #(#\Latin_Capital_Letter_A_With_Acute
     5385      #\Latin_Capital_Letter_C_With_Acute
     5386      #\Latin_Capital_Letter_E_With_Acute
     5387      #\Latin_Capital_Letter_G_With_Acute
     5388      #\Latin_Capital_Letter_I_With_Acute #\U+1E30
     5389      #\Latin_Capital_Letter_L_With_Acute #\U+1E3E
     5390      #\Latin_Capital_Letter_N_With_Acute
     5391      #\Latin_Capital_Letter_O_With_Acute #\U+1E54
     5392      #\Latin_Capital_Letter_R_With_Acute
     5393      #\Latin_Capital_Letter_S_With_Acute
     5394      #\Latin_Capital_Letter_U_With_Acute #\U+1E82
     5395      #\Latin_Capital_Letter_Y_With_Acute
     5396      #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute
     5397      #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute
     5398      #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute
     5399      #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F
     5400      #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute
     5401      #\U+1E55 #\Latin_Small_Letter_R_With_Acute
     5402      #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute
     5403      #\U+1E83 #\Latin_Small_Letter_Y_With_Acute
     5404      #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4
     5405      #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute
     5406      #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E
     5407      #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute
     5408      #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5
     5409      #\Latin_Small_Letter_A_With_Ring_Above_And_Acute
     5410      #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1
     5411      #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute
     5412      #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF
     5413      #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA
     5414      #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos
     5415      #\Greek_Capital_Letter_Epsilon_With_Tonos
     5416      #\Greek_Capital_Letter_Eta_With_Tonos
     5417      #\Greek_Capital_Letter_Iota_With_Tonos
     5418      #\Greek_Capital_Letter_Omicron_With_Tonos
     5419      #\Greek_Capital_Letter_Upsilon_With_Tonos
     5420      #\Greek_Capital_Letter_Omega_With_Tonos
     5421      #\Greek_Small_Letter_Alpha_With_Tonos
     5422      #\Greek_Small_Letter_Epsilon_With_Tonos
     5423      #\Greek_Small_Letter_Eta_With_Tonos
     5424      #\Greek_Small_Letter_Iota_With_Tonos
     5425      #\Greek_Small_Letter_Omicron_With_Tonos
     5426      #\Greek_Small_Letter_Upsilon_With_Tonos
     5427      #\Greek_Small_Letter_Omega_With_Tonos
     5428      #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos
     5429      #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos
     5430      #\Greek_Upsilon_With_Acute_And_Hook_Symbol
     5431      #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje
     5432      #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04
     5433      #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D
     5434      #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C
     5435      #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55
     5436      #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE)
     5437
     5438
     5439    ;; #\Combining_Circumflex_Accent
     5440
     5441    #(#\Latin_Capital_Letter_A_With_Circumflex
     5442      #\Latin_Capital_Letter_C_With_Circumflex
     5443      #\Latin_Capital_Letter_E_With_Circumflex
     5444      #\Latin_Capital_Letter_G_With_Circumflex
     5445      #\Latin_Capital_Letter_H_With_Circumflex
     5446      #\Latin_Capital_Letter_I_With_Circumflex
     5447      #\Latin_Capital_Letter_J_With_Circumflex
     5448      #\Latin_Capital_Letter_O_With_Circumflex
     5449      #\Latin_Capital_Letter_S_With_Circumflex
     5450      #\Latin_Capital_Letter_U_With_Circumflex
     5451      #\Latin_Capital_Letter_W_With_Circumflex
     5452      #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90
     5453      #\Latin_Small_Letter_A_With_Circumflex
     5454      #\Latin_Small_Letter_C_With_Circumflex
     5455      #\Latin_Small_Letter_E_With_Circumflex
     5456      #\Latin_Small_Letter_G_With_Circumflex
     5457      #\Latin_Small_Letter_H_With_Circumflex
     5458      #\Latin_Small_Letter_I_With_Circumflex
     5459      #\Latin_Small_Letter_J_With_Circumflex
     5460      #\Latin_Small_Letter_O_With_Circumflex
     5461      #\Latin_Small_Letter_S_With_Circumflex
     5462      #\Latin_Small_Letter_U_With_Circumflex
     5463      #\Latin_Small_Letter_W_With_Circumflex
     5464      #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD
     5465      #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9)
     5466
     5467
     5468    ;; #\Combining_Tilde
     5469
     5470    #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC
     5471      #\Latin_Capital_Letter_I_With_Tilde
     5472      #\Latin_Capital_Letter_N_With_Tilde
     5473      #\Latin_Capital_Letter_O_With_Tilde
     5474      #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8
     5475      #\Latin_Small_Letter_A_With_Tilde #\U+1EBD
     5476      #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde
     5477      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde
     5478      #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5
     5479      #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF)
     5480
     5481
     5482    ;; #\Combining_Macron
     5483
     5484    #(#\Latin_Capital_Letter_A_With_Macron
     5485      #\Latin_Capital_Letter_E_With_Macron #\U+1E20
     5486      #\Latin_Capital_Letter_I_With_Macron
     5487      #\Latin_Capital_Letter_O_With_Macron
     5488      #\Latin_Capital_Letter_U_With_Macron
     5489      #\Latin_Capital_Letter_Y_With_Macron
     5490      #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron
     5491      #\U+1E21 #\Latin_Small_Letter_I_With_Macron
     5492      #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron
     5493      #\Latin_Small_Letter_Y_With_Macron
     5494      #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron
     5495      #\Latin_Capital_Letter_Ae_With_Macron
     5496      #\Latin_Capital_Letter_O_With_Tilde_And_Macron
     5497      #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron
     5498      #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron
     5499      #\Latin_Small_Letter_A_With_Diaeresis_And_Macron
     5500      #\Latin_Small_Letter_Ae_With_Macron
     5501      #\Latin_Small_Letter_O_With_Tilde_And_Macron
     5502      #\Latin_Small_Letter_O_With_Diaeresis_And_Macron
     5503      #\Latin_Small_Letter_U_With_Diaeresis_And_Macron
     5504      #\Latin_Capital_Letter_O_With_Ogonek_And_Macron
     5505      #\Latin_Small_Letter_O_With_Ogonek_And_Macron
     5506      #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron
     5507      #\Latin_Small_Letter_A_With_Dot_Above_And_Macron
     5508      #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron
     5509      #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9
     5510      #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1
     5511      #\Cyrillic_Capital_Letter_I_With_Macron
     5512      #\Cyrillic_Capital_Letter_U_With_Macron
     5513      #\Cyrillic_Small_Letter_I_With_Macron
     5514      #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C
     5515      #\U+1E5D)
     5516
     5517
     5518    ;; #\Combining_Breve
     5519
     5520    #(#\Latin_Capital_Letter_A_With_Breve
     5521      #\Latin_Capital_Letter_E_With_Breve
     5522      #\Latin_Capital_Letter_G_With_Breve
     5523      #\Latin_Capital_Letter_I_With_Breve
     5524      #\Latin_Capital_Letter_O_With_Breve
     5525      #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve
     5526      #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve
     5527      #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve
     5528      #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8
     5529      #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0
     5530      #\Cyrillic_Capital_Letter_A_With_Breve
     5531      #\Cyrillic_Capital_Letter_Ie_With_Breve
     5532      #\Cyrillic_Capital_Letter_Zhe_With_Breve
     5533      #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U
     5534      #\Cyrillic_Small_Letter_A_With_Breve
     5535      #\Cyrillic_Small_Letter_Ie_With_Breve
     5536      #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I
     5537      #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7)
     5538
     5539
     5540    ;; #\Combining_Dot_Above
     5541
     5542    #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02
     5543      #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A
     5544      #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E
     5545      #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22
     5546      #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44
     5547      #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60
     5548      #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E
     5549      #\Latin_Capital_Letter_Z_With_Dot_Above
     5550      #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03
     5551      #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B
     5552      #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F
     5553      #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45
     5554      #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61
     5555      #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F
     5556      #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66
     5557      #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69)
     5558
     5559
     5560    ;; #\Combining_Diaeresis
     5561
     5562    #(#\Latin_Capital_Letter_A_With_Diaeresis
     5563      #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26
     5564      #\Latin_Capital_Letter_I_With_Diaeresis
     5565      #\Latin_Capital_Letter_O_With_Diaeresis
     5566      #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C
     5567      #\Latin_Capital_Letter_Y_With_Diaeresis
     5568      #\Latin_Small_Letter_A_With_Diaeresis
     5569      #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27
     5570      #\Latin_Small_Letter_I_With_Diaeresis
     5571      #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97
     5572      #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D
     5573      #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A
     5574      #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika
     5575      #\Greek_Capital_Letter_Upsilon_With_Dialytika
     5576      #\Greek_Small_Letter_Iota_With_Dialytika
     5577      #\Greek_Small_Letter_Upsilon_With_Dialytika
     5578      #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol
     5579      #\Cyrillic_Capital_Letter_Yi
     5580      #\Cyrillic_Capital_Letter_A_With_Diaeresis
     5581      #\Cyrillic_Capital_Letter_Io
     5582      #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis
     5583      #\Cyrillic_Capital_Letter_Ze_With_Diaeresis
     5584      #\Cyrillic_Capital_Letter_I_With_Diaeresis
     5585      #\Cyrillic_Capital_Letter_O_With_Diaeresis
     5586      #\Cyrillic_Capital_Letter_U_With_Diaeresis
     5587      #\Cyrillic_Capital_Letter_Che_With_Diaeresis
     5588      #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis
     5589      #\Cyrillic_Capital_Letter_E_With_Diaeresis
     5590      #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io
     5591      #\Cyrillic_Small_Letter_Zhe_With_Diaeresis
     5592      #\Cyrillic_Small_Letter_Ze_With_Diaeresis
     5593      #\Cyrillic_Small_Letter_I_With_Diaeresis
     5594      #\Cyrillic_Small_Letter_O_With_Diaeresis
     5595      #\Cyrillic_Small_Letter_U_With_Diaeresis
     5596      #\Cyrillic_Small_Letter_Che_With_Diaeresis
     5597      #\Cyrillic_Small_Letter_Yeru_With_Diaeresis
     5598      #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi
     5599      #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis
     5600      #\Cyrillic_Small_Letter_Schwa_With_Diaeresis
     5601      #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis
     5602      #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis)
     5603
     5604
     5605    ;; #\Combining_Hook_Above
     5606
     5607    #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3
     5608      #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2
     5609      #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE
     5610      #\U+1EDF #\U+1EEC #\U+1EED)
     5611
     5612
     5613    ;; #\Combining_Ring_Above
     5614
     5615    #(#\Latin_Capital_Letter_A_With_Ring_Above
     5616      #\Latin_Capital_Letter_U_With_Ring_Above
     5617      #\Latin_Small_Letter_A_With_Ring_Above
     5618      #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99)
     5619
     5620
     5621    ;; #\Combining_Double_Acute_Accent
     5622
     5623    #(#\Latin_Capital_Letter_O_With_Double_Acute
     5624      #\Latin_Capital_Letter_U_With_Double_Acute
     5625      #\Latin_Small_Letter_O_With_Double_Acute
     5626      #\Latin_Small_Letter_U_With_Double_Acute
     5627      #\Cyrillic_Capital_Letter_U_With_Double_Acute
     5628      #\Cyrillic_Small_Letter_U_With_Double_Acute)
     5629
     5630
     5631    ;; #\Combining_Caron
     5632
     5633    #(#\Latin_Capital_Letter_A_With_Caron
     5634      #\Latin_Capital_Letter_C_With_Caron
     5635      #\Latin_Capital_Letter_D_With_Caron
     5636      #\Latin_Capital_Letter_E_With_Caron
     5637      #\Latin_Capital_Letter_G_With_Caron
     5638      #\Latin_Capital_Letter_H_With_Caron
     5639      #\Latin_Capital_Letter_I_With_Caron
     5640      #\Latin_Capital_Letter_K_With_Caron
     5641      #\Latin_Capital_Letter_L_With_Caron
     5642      #\Latin_Capital_Letter_N_With_Caron
     5643      #\Latin_Capital_Letter_O_With_Caron
     5644      #\Latin_Capital_Letter_R_With_Caron
     5645      #\Latin_Capital_Letter_S_With_Caron
     5646      #\Latin_Capital_Letter_T_With_Caron
     5647      #\Latin_Capital_Letter_U_With_Caron
     5648      #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron
     5649      #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron
     5650      #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron
     5651      #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron
     5652      #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron
     5653      #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron
     5654      #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron
     5655      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron
     5656      #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron
     5657      #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron
     5658      #\Latin_Small_Letter_U_With_Diaeresis_And_Caron
     5659      #\Latin_Capital_Letter_Ezh_With_Caron
     5660      #\Latin_Small_Letter_Ezh_With_Caron)
     5661
     5662
     5663    ;; #\Combining_Double_Grave_Accent
     5664
     5665    #(#\Latin_Capital_Letter_A_With_Double_Grave
     5666      #\Latin_Capital_Letter_E_With_Double_Grave
     5667      #\Latin_Capital_Letter_I_With_Double_Grave
     5668      #\Latin_Capital_Letter_O_With_Double_Grave
     5669      #\Latin_Capital_Letter_R_With_Double_Grave
     5670      #\Latin_Capital_Letter_U_With_Double_Grave
     5671      #\Latin_Small_Letter_A_With_Double_Grave
     5672      #\Latin_Small_Letter_E_With_Double_Grave
     5673      #\Latin_Small_Letter_I_With_Double_Grave
     5674      #\Latin_Small_Letter_O_With_Double_Grave
     5675      #\Latin_Small_Letter_R_With_Double_Grave
     5676      #\Latin_Small_Letter_U_With_Double_Grave
     5677      #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent
     5678      #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent)
     5679
     5680
     5681    ;; #\Combining_Inverted_Breve
     5682
     5683    #(#\Latin_Capital_Letter_A_With_Inverted_Breve
     5684      #\Latin_Capital_Letter_E_With_Inverted_Breve
     5685      #\Latin_Capital_Letter_I_With_Inverted_Breve
     5686      #\Latin_Capital_Letter_O_With_Inverted_Breve
     5687      #\Latin_Capital_Letter_R_With_Inverted_Breve
     5688      #\Latin_Capital_Letter_U_With_Inverted_Breve
     5689      #\Latin_Small_Letter_A_With_Inverted_Breve
     5690      #\Latin_Small_Letter_E_With_Inverted_Breve
     5691      #\Latin_Small_Letter_I_With_Inverted_Breve
     5692      #\Latin_Small_Letter_O_With_Inverted_Breve
     5693      #\Latin_Small_Letter_R_With_Inverted_Breve
     5694      #\Latin_Small_Letter_U_With_Inverted_Breve)
     5695
     5696
     5697    ;; #\Combining_Comma_Above
     5698
     5699    #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00
     5700      #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60)
     5701
     5702
     5703    ;; #\Combining_Reversed_Comma_Above
     5704
     5705    #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59
     5706      #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5
     5707      #\U+1F51 #\U+1F61)
     5708
     5709
     5710    ;; #\Combining_Horn
     5711
     5712    #(#\Latin_Capital_Letter_O_With_Horn
     5713      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn
     5714      #\Latin_Small_Letter_U_With_Horn)
     5715
     5716
     5717    ;; #\Combining_Dot_Below
     5718
     5719    #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32
     5720      #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C
     5721      #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05
     5722      #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43
     5723      #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F
     5724      #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1)
     5725
     5726
     5727    ;; #\Combining_Diaeresis_Below
     5728
     5729    #(#\U+1E72 #\U+1E73)
     5730
     5731
     5732    ;; #\Combining_Ring_Below
     5733
     5734    #(#\U+1E00 #\U+1E01)
     5735
     5736
     5737    ;; #\Combining_Comma_Below
     5738
     5739    #(#\Latin_Capital_Letter_S_With_Comma_Below
     5740      #\Latin_Capital_Letter_T_With_Comma_Below
     5741      #\Latin_Small_Letter_S_With_Comma_Below
     5742      #\Latin_Small_Letter_T_With_Comma_Below)
     5743
     5744
     5745    ;; #\Combining_Cedilla
     5746
     5747    #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10
     5748      #\Latin_Capital_Letter_E_With_Cedilla
     5749      #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28
     5750      #\Latin_Capital_Letter_K_With_Cedilla
     5751      #\Latin_Capital_Letter_L_With_Cedilla
     5752      #\Latin_Capital_Letter_N_With_Cedilla
     5753      #\Latin_Capital_Letter_R_With_Cedilla
     5754      #\Latin_Capital_Letter_S_With_Cedilla
     5755      #\Latin_Capital_Letter_T_With_Cedilla
     5756      #\Latin_Small_Letter_C_With_Cedilla #\U+1E11
     5757      #\Latin_Small_Letter_E_With_Cedilla
     5758      #\Latin_Small_Letter_G_With_Cedilla #\U+1E29
     5759      #\Latin_Small_Letter_K_With_Cedilla
     5760      #\Latin_Small_Letter_L_With_Cedilla
     5761      #\Latin_Small_Letter_N_With_Cedilla
     5762      #\Latin_Small_Letter_R_With_Cedilla
     5763      #\Latin_Small_Letter_S_With_Cedilla
     5764      #\Latin_Small_Letter_T_With_Cedilla)
     5765
     5766
     5767    ;; #\Combining_Ogonek
     5768
     5769    #(#\Latin_Capital_Letter_A_With_Ogonek
     5770      #\Latin_Capital_Letter_E_With_Ogonek
     5771      #\Latin_Capital_Letter_I_With_Ogonek
     5772      #\Latin_Capital_Letter_O_With_Ogonek
     5773      #\Latin_Capital_Letter_U_With_Ogonek
     5774      #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek
     5775      #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek
     5776      #\Latin_Small_Letter_U_With_Ogonek)
     5777
     5778
     5779    ;; #\Combining_Circumflex_Accent_Below
     5780
     5781    #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13
     5782      #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77)
     5783
     5784
     5785    ;; #\Combining_Breve_Below
     5786
     5787    #(#\U+1E2A #\U+1E2B)
     5788
     5789
     5790    ;; #\Combining_Tilde_Below
     5791
     5792    #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75)
     5793
     5794
     5795    ;; #\Combining_Macron_Below
     5796
     5797    #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E
     5798      #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49
     5799      #\U+1E5F #\U+1E6F #\U+1E95)
     5800
     5801
     5802    ;; #\Combining_Long_Solidus_Overlay
     5803
     5804    #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD
     5805      #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226
     5806      #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270
     5807      #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281
     5808      #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2
     5809      #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB
     5810      #\U+22EC #\U+22ED)
     5811
     5812
     5813    ;; #\Combining_Greek_Perispomeni
     5814
     5815    #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7
     5816      #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27
     5817      #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56
     5818      #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF
     5819      #\U+1FDF)
     5820
     5821
     5822    ;; #\Combining_Greek_Ypogegrammeni
     5823
     5824    #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3
     5825      #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84
     5826      #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B
     5827      #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92
     5828      #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99
     5829      #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0
     5830      #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7
     5831      #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE
     5832      #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7)
     5833
     5834
     5835    ;; #\Arabic_Maddah_Above
     5836
     5837    #(#\Arabic_Letter_Alef_With_Madda_Above)
     5838
     5839
     5840    ;; #\Arabic_Hamza_Above
     5841
     5842    #(#\Arabic_Letter_Alef_With_Hamza_Above
     5843      #\Arabic_Letter_Waw_With_Hamza_Above
     5844      #\Arabic_Letter_Yeh_With_Hamza_Above
     5845      #\Arabic_Letter_Heh_Goal_With_Hamza_Above
     5846      #\Arabic_Letter_Yeh_Barree_With_Hamza_Above
     5847      #\Arabic_Letter_Heh_With_Yeh_Above)
     5848
     5849
     5850    ;; #\Arabic_Hamza_Below
     5851
     5852    #(#\Arabic_Letter_Alef_With_Hamza_Below)
     5853
     5854
     5855    ;; #\U+093C
     5856
     5857    #(#\U+0929 #\U+0931 #\U+0934)
     5858
     5859
     5860    ;; #\U+09BE
     5861
     5862    #(#\U+09CB)
     5863
     5864
     5865    ;; #\U+09D7
     5866
     5867    #(#\U+09CC)
     5868
     5869
     5870    ;; #\U+0B3E
     5871
     5872    #(#\U+0B4B)
     5873
     5874
     5875    ;; #\U+0B56
     5876
     5877    #(#\U+0B48)
     5878
     5879
     5880    ;; #\U+0B57
     5881
     5882    #(#\U+0B4C)
     5883
     5884
     5885    ;; #\U+0BBE
     5886
     5887    #(#\U+0BCA #\U+0BCB)
     5888
     5889
     5890    ;; #\U+0BD7
     5891
     5892    #(#\U+0B94 #\U+0BCC)
     5893
     5894
     5895    ;; #\U+0C56
     5896
     5897    #(#\U+0C48)
     5898
     5899
     5900    ;; #\U+0CC2
     5901
     5902    #(#\U+0CCA)
     5903
     5904
     5905    ;; #\U+0CD5
     5906
     5907    #(#\U+0CC0 #\U+0CC7 #\U+0CCB)
     5908
     5909
     5910    ;; #\U+0CD6
     5911
     5912    #(#\U+0CC8)
     5913
     5914
     5915    ;; #\U+0D3E
     5916
     5917    #(#\U+0D4A #\U+0D4B)
     5918
     5919
     5920    ;; #\U+0D57
     5921
     5922    #(#\U+0D4C)
     5923
     5924
     5925    ;; #\U+0DCA
     5926
     5927    #(#\U+0DDA #\U+0DDD)
     5928
     5929
     5930    ;; #\U+0DCF
     5931
     5932    #(#\U+0DDC)
     5933
     5934
     5935    ;; #\U+0DDF
     5936
     5937    #(#\U+0DDE)
     5938
     5939
     5940    ;; #\U+102E
     5941
     5942    #(#\U+1026)
     5943
     5944
     5945    ;; #\U+3099
     5946
     5947    #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056
     5948      #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065
     5949      #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C
     5950      #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4
     5951      #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2
     5952      #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9
     5953      #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE)
     5954
     5955
     5956    ;; #\U+309A
     5957
     5958    #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4
     5959      #\U+30D7 #\U+30DA #\U+30DD)
     5960    ))
     5961
     5962(defun search-char-vector (vector char)
     5963  ;; vector is a SIMPLE-VECTOR of chars sorted by char-code.
     5964  ;; return the index of char in vector or NIL if not found
     5965  (let* ((left 0)
     5966         (right (1- (length vector))))
     5967    (declare (fixnum left right))
     5968    (if (and (char>= char (svref vector left))
     5969             (char<= char (svref vector right)))
     5970      (do* ()
     5971           ((> left right))
     5972        (let* ((mid (ash (the fixnum (+ left right)) -1))
     5973               (midch (svref vector mid)))
     5974          (declare (fixnum mid))
     5975          (if (eql char midch)
     5976            (return mid)
     5977            (if (char< char midch)
     5978              (setq right (1- mid))
     5979              (setq left (1+ mid)))))))))
     5980
     5981
     5982(defconstant HANGUL-SBASE #xAC00)
     5983(defconstant HANGUL-LBASE #x1100)
     5984(defconstant HANGUL-VBASE #x1161)
     5985(defconstant HANGUL-TBASE #x11A7)
     5986
     5987(defconstant HANGUL-SCOUNT 11172)
     5988(defconstant HANGUL-LCOUNT 19)
     5989(defconstant HANGUL-VCOUNT 21)
     5990(defconstant HANGUL-TCOUNT 28)
     5991(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT))
     5992
     5993(defun combine-bmp-chars (base combiner)
     5994  (if (and (char>= combiner (code-char hangul-vbase))
     5995           (char< combiner (code-char (+ hangul-tbase hangul-tcount))))
     5996    (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount)))
     5997             (char>= base (code-char hangul-lbase))
     5998             (char< base (code-char (+ hangul-lbase hangul-lcount))))
     5999      (return-from combine-bmp-chars
     6000        (code-char (+ hangul-lbase
     6001                      (* hangul-ncount (- (char-code base) hangul-lbase))
     6002                      (* hangul-tcount (- (char-code combiner) hangul-vbase))))))
     6003    (if (and (char> combiner (code-char hangul-tbase))
     6004             (char>= base (code-char hangul-sbase))
     6005             (char< base (code-char (+ hangul-sbase hangul-scount))))
     6006      (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount))))
     6007        (return-from combine-bmp-chars nil)
     6008        (return-from combine-bmp-chars
     6009          (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase)))))))
     6010   
     6011  (let* ((idx (search-char-vector *bmp-combining-chars* combiner))
     6012         (base-table (if idx (svref *bmp-combining-base-chars* idx))))
     6013    (if base-table
     6014      (let* ((combined-idx (search-char-vector base-table base)))
     6015        (if combined-idx
     6016          (svref (svref *bmp-precombined-chars* idx) combined-idx))))))
     6017
     6018(defun precompose-simple-string (s)
     6019  (let* ((n (length s)))
     6020    (or (dotimes (i n s)
     6021          (when (is-combinable (schar s i))
     6022            (return nil)))
     6023        (let* ((new (make-string n)))
     6024          (declare (dynamic-extent new))
     6025          (do* ((i 0 (1+ i))
     6026                (nout -1)
     6027                (lastch nil))
     6028               ((= i n) (subseq new 0 (1+ nout)))
     6029            (declare (fixnum nout i))
     6030            (let* ((ch (schar s i)))
     6031              (if (or (not lastch)
     6032                      (not (is-combinable ch)))
     6033                (setf lastch ch
     6034                      (schar new (incf nout)) ch)
     6035                (let* ((combined (combine-bmp-chars lastch ch)))
     6036                  (if combined
     6037                    (setf (schar new nout) (setq lastch combined))
     6038                    (setf lastch ch
     6039                      (schar new (incf nout)) ch))))))))))
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r7517 r7624  
    3030  )
    3131
     32
     33(defun get-foreign-namestring (pointer)
     34  ;; On Darwin, foreign namestrings are encoded in UTF-8 and
     35  ;; are canonically decomposed (NFD).  Use PRECOMPOSE-SIMPLE-STRING
     36  ;; to ensure that the string is "precomposed" (NFC), like the
     37  ;; rest of the world and most sane people would expect.
     38  #+darwin-target
     39  (precompose-simple-string (%get-utf-8-cstring pointer))
     40  ;; On some other platforms, the namestring is assumed to
     41  ;; be encoded according to the current locale's character
     42  ;; encoding (though FreeBSD seems to be moving towards
     43  ;; precomposed UTF-8.).
     44  ;; In any case, the use if %GET-CSTRING here is wrong ...
     45  #-darwin-target
     46  (%get-cstring pointer))
    3247
    3348(defun nanoseconds (n)
     
    156171                     ((< len bufsize)
    157172                      (setf (%get-unsigned-byte buf len) 0)
    158                       (values (%get-cstring buf) len))
     173                      (values (get-foreign-namestring buf) len))
    159174                     (t (values nil len)))))))
    160175    (do* ((string nil)
     
    176191
    177192(defun %chdir (dirname)
    178   (with-cstrs ((dirname dirname))
     193  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname))
    179194    (syscall syscalls::chdir dirname)))
    180195
    181196(defun %mkdir (name mode)
    182   (let* ((last (1- (length name))))
    183     (with-cstrs ((name name))
    184       (when (and (>= last 0)
    185                  (eql (%get-byte name last) (char-code #\/)))
    186         (setf (%get-byte name last) 0))
    187     (syscall syscalls::mkdir name mode))))
     197  (let* ((name name)
     198         (len (length name)))
     199    (when (and (> len 0) (eql (char name (1- len)) #\/))
     200      (setq name (subseq name 0 (1- len))))
     201    (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name))
     202      (syscall syscalls::mkdir name mode))))
    188203
    189204(defun %rmdir (name)
    190205  (let* ((last (1- (length name))))
    191     (with-cstrs ((name name))
     206    (#+darwin-target with-utf8-cstrs #-darwin-target with-cstrs ((name name))
    192207      (when (and (>= last 0)
    193208                 (eql (%get-byte name last) (char-code #\/)))
    194209        (setf (%get-byte name last) 0))
    195210    (syscall syscalls::rmdir name))))
     211
    196212
    197213(defun getenv (key)
     
    247263
    248264(defun %%stat (name stat)
    249   (with-cstrs ((cname name))
     265  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
    250266    (%stat-values
    251267     #+linux-target
     
    264280
    265281(defun %%lstat (name stat)
    266   (with-cstrs ((cname name))
     282  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
    267283    (%stat-values
    268284     #+linux-target
     
    377393    (setq namestring (current-directory-name)))
    378394  (%stack-block ((resultbuf #$PATH_MAX))
    379     (with-cstrs ((name (tilde-expand namestring)))
     395    (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#))
    380396      (let* ((result (#_realpath name resultbuf)))
    381397        (declare (dynamic-extent result))
    382398        (unless (%null-ptr-p result)
    383           (%get-cstring result))))))
     399          (get-foreign-namestring result))))))
    384400
    385401;;; Return fully resolved pathname & file kind, or (values nil nil)
     
    436452
    437453(defun %utimes (namestring)
    438   (with-cstrs ((cnamestring namestring))
     454  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring))
    439455    (let* ((err (#_utimes cnamestring (%null-ptr))))
    440456      (declare (fixnum err))
     
    454470
    455471(defun %open-dir (namestring)
    456   (with-cstrs ((name namestring))
     472  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring))
    457473    (let* ((DIR (#_opendir name)))
    458474      (unless (%null-ptr-p DIR)
     
    464480(defun %read-dir (dir)
    465481  (let* ((res (#_readdir dir)))
    466     (unless (%null-ptr-p res)       
    467       (%get-cstring (pref res :dirent.d_name)))))
     482    (unless (%null-ptr-p res)
     483      (get-foreign-namestring (pref res :dirent.d_name)))))
    468484
    469485(defun tcgetpgrp (fd)
     
    489505        (let* ((err (#_getpwuid_r userid pwd buf buflen result)))
    490506          (if (eql 0 err)
    491             (return (%get-cstring (pref pwd :passwd.pw_dir)))
     507            (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
    492508            (unless (eql err #$ERANGE)
    493509              (return nil))))))))
     
    634650
    635651
    636 #+linux-target
    637 (defun pipe ()
    638   (%stack-block ((pipes 8))
    639     (let* ((status (syscall syscalls::pipe pipes)))
    640       (if (= 0 status)
    641         (values (%get-long pipes 0) (%get-long pipes 4))
    642         (%errno-disp status)))))
     652
    643653
    644654
    645655;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
    646656;;; Use libc's interface.
    647 #+(or darwin-target freebsd-target)
    648657(defun pipe ()
     658  ;;  (rlet ((filedes (:array :int 2)))
    649659  (%stack-block ((filedes 8))
    650     (let* ((status (#_pipe filedes)))
     660    (let* ((status (#_pipe filedes))
     661           (errno (if (eql status 0) 0 (%get-errno))))
     662      (unless (zerop status)
     663        (when (or (eql errno (- #$EMFILE))
     664                  (eql errno (- #$ENFILE)))
     665          (gc)
     666          (drain-termination-queue)
     667          (setq status (#_pipe filedes)
     668                errno (if (zerop status) 0 (%get-errno)))))
    651669      (if (zerop status)
    652670        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
    653         (%errno-disp (%get-errno))))))
     671        (%errno-disp errno)))))
    654672
    655673
     
    707725                                  :element-type element-type
    708726                                  :interactive nil
    709                                   :basic t)
     727                                  :basic t
     728                                  :auto-close t)
    710729                  (cons read-pipe close-in-parent)
    711730                  (cons write-pipe close-on-error)))
     
    716735                                  :element-type element-type
    717736                                  :interactive nil
    718                                   :basic t)
     737                                  :basic t
     738                                  :auto-close t)
    719739                  (cons write-pipe close-in-parent)
    720740                  (cons read-pipe close-on-error)))
     
    11911211  (if (eql 1 (cpu-count))
    11921212    (%defglobal '*spin-lock-tries* 1)
    1193     (%defglobal '*spin-lock-tries* 1024)))
     1213    (%defglobal '*spin-lock-tries* 1024))
     1214  (%defglobal '*spin-lock-timeouts* 0))
    11941215
    11951216(defun yield ()
  • branches/working-0711/ccl/level-1/sysutils.lisp

    r7247 r7624  
    310310    (%kernel-restart $xwrongtype arg type)))
    311311
    312 ; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
     312;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
    313313(defun %require-type (arg predsym)
    314     (if (funcall predsym arg)
     314  (if (funcall predsym arg)
    315315    arg
    316     (%kernel-restart $xwrongtype arg `(satisfies ,predsym))))
     316    (%kernel-restart $xwrongtype arg (type-for-predicate predsym))))
    317317
    318318(defun %require-type-builtin (arg type-cell) 
     
    323323
    324324
     325;;; In lieu of an inverted mapping, at least try to find cases involving
     326;;; builtin numeric types and predicates associated with them.
     327(defun type-for-predicate (pred)
     328  (or (block find
     329        (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype)
     330                                                   (eq (numeric-ctype-predicate ctype)
     331                                                       pred))
     332                                          (return-from find type)))
     333                 *builtin-type-info*))
     334      `(satisfies ,pred)))
    325335
    326336
  • branches/working-0711/ccl/lib/backtrace.lisp

    r7594 r7624  
    239239              value)))))))
    240240
     241;;; Returns non-nil on success (not newval)
     242(defun set-map-entry-value (context cfp lfun pc idx newval)
     243  (declare (fixnum pc idx))
     244  (let* ((unavailable (cons nil nil))
     245         (value (map-entry-value context cfp lfun pc idx unavailable)))
     246    (if (eq value unavailable)
     247      nil
     248      (if (typep value 'value-cell)
     249        (progn (setf (uvref value 0) newval) t)
     250
     251        (let* ((addrs (cdr (function-symbol-map lfun)))
     252               (addr (svref addrs (the fixnum (* 3 idx)))))
     253          (declare (fixnum  addr))
     254          (if (= #o77 (ldb (byte 6 0) addr))
     255            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
     256            (set-register-argument-value context cfp addr newval))
     257          t)))))
     258
     259         
    241260(defun argument-value (context cfp lfun pc name &optional (quote t))
    242261  (declare (fixnum pc))
     
    274293(defun raw-frame-ref (cfp context index bad)
    275294  (%raw-frame-ref cfp context index bad))
     295
     296(defun raw-frame-set (cfp context index new)
     297  (%raw-frame-set cfp context index new))
    276298 
    277299(defun find-register-argument-value (context cfp regval bad)
    278300  (%find-register-argument-value context cfp regval bad))
     301
     302(defun set-register-argument-value (context cfp regval newval)
     303  (%set-register-argument-value context cfp regval newval))
     304
    279305   
    280306
     
    390416                  (push i indices)
    391417                  (push (svref names i) vars))))))))))
     418
     419
     420(defun arg-value (context cfp lfun pc unavailable name)
     421  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     422    (multiple-value-bind (valid req opt rest keys)
     423        (arg-names-from-map lfun pc)
     424      (if valid
     425        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     426               (pos (position name vars)))
     427          (if (and pos (< pos nargs))
     428            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
     429            unavailable))
     430        unavailable))))
     431
     432(defun local-value (context cfp lfun pc unavailable name)
     433  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     434    (multiple-value-bind (valid req opt rest keys)
     435        (arg-names-from-map lfun pc)
     436      (if valid
     437        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     438               (names (nthcdr nargs vars))
     439               (indices (nthcdr nargs map-indices))
     440               (pos (if (typep name 'unsigned-byte)
     441                      name
     442                      (position name names :from-end t))))
     443          (if (and pos (< pos nargs))
     444            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
     445            unavailable))
     446        unavailable))))
     447
     448(defun set-arg-value (context cfp lfun pc name new)
     449  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     450    (multiple-value-bind (valid req opt rest keys)
     451        (arg-names-from-map lfun pc)
     452      (if valid
     453        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     454               (pos (position name vars)))
     455          (when (and pos (< pos nargs))
     456            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
     457
     458(defun set-local-value (context cfp lfun pc name new)
     459  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
     460    (multiple-value-bind (valid req opt rest keys)
     461        (arg-names-from-map lfun pc)
     462      (if valid
     463        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     464               (names (nthcdr nargs vars))
     465               (indices (nthcdr nargs map-indices))
     466               (pos (if (typep name 'unsigned-byte)
     467                      name
     468                      (position name names :from-end t))))
     469          (if (and pos (< pos nargs))
     470            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
     471
    392472
    393473(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
     
    465545      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
    466546        (setq oldest db)))))
     547
     548(defun (setf oldest-binding-frame-value) (new context frame)
     549  (let* ((oldest nil)
     550         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
     551    (do* ((db (db-link context) (%fixnum-ref db 0)))
     552         ((eq frame db)
     553          (if oldest
     554            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
     555            (let* ((symbol (binding-index-symbol binding-index)))
     556              (if context
     557                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
     558                (%set-sym-value symbol new)))))
     559      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
     560        (setq oldest db)))))
    467561   
    468562
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r7330 r7624  
    143143     ensure-class-using-class
    144144     ensure-generic-function-using-class
     145     eql-specializer
    145146     eql-specializer-object
    146147     extract-lambda-list
     
    221222     specializer-direct-generic-functions
    222223     copy-instance
     224
     225     override-one-method-one-arg-dcode
     226     optimize-generic-function-dispatching
    223227
    224228     ;; Not MOP
     
    651655   "ENSURE-CLASS-USING-CLASS"
    652656   "ENSURE-GENERIC-FUNCTION-USING-CLASS"
     657   "EQL-SPECIALIZER"
    653658   "EQL-SPECIALIZER-OBJECT"
    654659   "EXTRACT-LAMBDA-LIST"
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r6979 r7624  
    193193        arglist
    194194        edit-callers
    195         hash-cons
    196195        describe
    197196        asdf
  • branches/working-0711/ccl/lib/describe.lisp

    r7554 r7624  
    15461546                                     *backtrace-internal-functions*))
    15471547   (break-condition :accessor break-condition
    1548                     :initarg :break-condition)))
     1548                    :initarg :break-condition)
     1549   (unavailable-value-marker :initform (cons nil nil)
     1550                             :accessor unavailable-value-marker)))
    15491551 
    15501552
     
    15611563(defmethod compute-frame-info ((f error-frame) n)
    15621564  (let* ((frame (svref (addresses f) n))
    1563          (context (context f)))
     1565         (context (context f))
     1566         (marker (unavailable-value-marker f)))
     1567   
    15641568    (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame)
    1565       (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc)
     1569      (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker)
    15661570        (list (ccl::arglist-from-map lfun) args locals)))))
    15671571
  • branches/working-0711/ccl/lib/foreign-types.lisp

    r6503 r7624  
    17001700      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
    17011701      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
     1702      (canonicalize-foreign-type-ordinal '(:array :int 2))
    17021703      )))
    17031704
  • branches/working-0711/ccl/lib/hash.lisp

    r2584 r7624  
    159159            ':test (hash-table-test table)
    160160            (hash-table-count table)
    161             (hash-table-size table))))
     161            (hash-table-size table))
     162    (when (readonly-hash-table-p table)
     163      (format stream " (Readonly)"))))
    162164
    163165
     
    209211
    210212(defun start-hash-table-iterator (hash state)
    211   (let (vector)
     213  (let (vector locked)
    212214    (unless (hash-table-p hash)
    213215      (setf (hti.hash-table state) nil)         ; for finish-hash-table-iterator
     
    216218    (without-interrupts
    217219     (setf (hti.hash-table state) hash)
    218      (lock-hash-table hash)
    219      (%lock-gc-lock)
     220     (setf (hti.lock state) (setq locked (not (eq :readonly (lock-hash-table-for-map hash)))))
     221     (when locked (%lock-gc-lock))
    220222     (setq vector (nhash.vector hash))
    221223     (setf (hti.vector state) vector)
     
    254256(defun finish-hash-table-iterator (state)
    255257  (without-interrupts
    256    (let ((hash (hti.hash-table state)))
     258   (let ((hash (hti.hash-table state))
     259         (locked (hti.lock state)))
    257260     (when hash
    258261       (setf (hti.hash-table state) nil)
    259        (unlock-hash-table hash)
    260        (%unlock-gc-lock)
     262       (when locked
     263         (unlock-hash-table hash nil)
     264         (%unlock-gc-lock))
    261265       (when (eq state (nhash.iterator hash))
    262266         (setf (nhash.iterator hash) (hti.prev-iterator state)))
  • branches/working-0711/ccl/lib/macros.lisp

    r7449 r7624  
    14931493       ,@body)))
    14941494
     1495(defmacro with-self-bound-io-control-vars (&body body)
     1496  `(let (
     1497         (*print-array* *print-array*)
     1498         (*print-base* *print-base*)
     1499         (*print-case* *print-case*)
     1500         (*print-circle* *print-circle*)
     1501         (*print-escape* *print-escape*)
     1502         (*print-gensym* *print-gensym*)
     1503         (*print-length* *print-length*)
     1504         (*print-level* *print-level*)
     1505         (*print-lines* *print-lines*)
     1506         (*print-miser-width* *print-miser-width*)
     1507         (*print-pprint-dispatch* *print-pprint-dispatch*)
     1508         (*print-pretty* *print-pretty*)
     1509         (*print-radix* *print-radix*)
     1510         (*print-readably* *print-readably*)
     1511         (*print-right-margin* *print-right-margin*)
     1512         (*read-base* *read-base*)
     1513         (*read-default-float-format* *read-default-float-format*)
     1514         (*read-eval* *read-eval*)
     1515         (*read-suppress* *read-suppress*)
     1516         (*readtable* *readtable*))
     1517     ,@body))
     1518
    14951519(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms)
    14961520  "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
     
    15801604                `(%cstr-pointer ,strname ,sym))
    15811605             ,@body))))))
     1606
     1607(defmacro with-utf-8-cstr ((sym str) &body body)
     1608  (let* ((data (gensym))
     1609         (offset (gensym))
     1610         (string (gensym))
     1611         (len (gensym))
     1612         (noctets (gensym))
     1613         (end (gensym)))
     1614    `(let* ((,string ,str)
     1615            (,len (length ,string)))
     1616      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
     1617        (let* ((,end (+ ,offset ,len))
     1618               (,noctets (utf-8-octets-in-string ,data ,offset ,end)))
     1619          (%stack-block ((,sym (1+ ,noctets)))
     1620            (utf-8-memory-encode ,data ,sym 0 ,offset ,end)
     1621            (setf (%get-unsigned-byte ,sym ,noctets) 0)
     1622            ,@body))))))
    15821623
    15831624
     
    29072948        (setf (,accessor ,dst ,i) (,accessor ,src ,i))))))
    29082949
    2909      
     2950(defmacro assert-pointer-type (pointer type)
     2951  "Assert that the pointer points to an instance of the specified foreign type.
     2952Return the pointer."
     2953  (let* ((ptr (gensym)))
     2954    `(let* ((,ptr ,pointer))
     2955      (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type))))
     2956      ,ptr)))
     2957
    29102958   
    29112959
     
    29883036      ,@body)
    29893037    (%unlock-gc-lock)))
     3038
     3039(defmacro with-deferred-gc (&body body)
     3040  "Execute BODY without responding to the signal used to suspend
     3041threads for GC.  BODY must be very careful not to do anything which
     3042could cause an exception (note that attempting to allocate lisp memory
     3043may cause an exception.)"
     3044  `(let* ((*interrupt-level* -2))
     3045    ,@body))
     3046
     3047(defmacro allowing-deferred-gc (&body body)
     3048  "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC."
     3049  `(let* ((*interrupt-level* -1))
     3050    (%check-deferred-gc)
     3051    ,@body))
     3052 
     3053
    29903054
    29913055(defmacro with-pointer-to-ivector ((ptr ivector) &body body)
  • branches/working-0711/ccl/lib/misc.lisp

    r7278 r7624  
    712712            (when (and line (parse-integer line :junk-allowed t) )
    713713              (return-from local-svn-revision line)))))))))
     714
     715
     716;;; Scan the heap, collecting infomation on the primitive object types
     717;;; found.  Report that information.
     718
     719(defun heap-utilization (&key (stream *debug-io*)
     720                              (gc-first t))
     721  (let* ((nconses 0)
     722         (nvectors (make-array 256))
     723         (vector-sizes (make-array 256))
     724         (array-size-function (arch::target-array-data-size-function
     725                               (backend-target-arch *host-backend*))))
     726    (declare (type (simple-vector 256) nvectors vector-sizes)
     727             (dynamic-extent nvectors vector-sizes))
     728    (when gc-first (gc))
     729    (%map-areas (lambda (thing)
     730                  (if (consp thing)
     731                    (incf nconses)
     732                    (let* ((typecode (typecode thing)))
     733                      (incf (aref nvectors typecode))
     734                      (incf (aref vector-sizes typecode)
     735                            (funcall array-size-function typecode (uvsize thing)))))))
     736    (report-heap-utilization stream nconses nvectors vector-sizes)
     737    (values)))
     738
     739#+x8664-target
     740(progn
     741  (defvar *x8664-vector-type-names*
     742    (let* ((a (make-array 256)))
     743      (dotimes (i 256 a)
     744        (let* ((fulltag (logand i x8664::fulltagmask))
     745               (names-vector
     746                (cond ((= fulltag x8664::fulltag-nodeheader-0)
     747                       *nodeheader-0-types*)
     748                      ((= fulltag x8664::fulltag-nodeheader-1)
     749                       *nodeheader-1-types*)
     750                      ((= fulltag x8664::fulltag-immheader-0)
     751                       *immheader-0-types*)
     752                      ((= fulltag x8664::fulltag-immheader-1)
     753                       *immheader-1-types*)
     754                      ((= fulltag x8664::fulltag-immheader-2)
     755                       *immheader-2-types*)))
     756               (name (if names-vector
     757                       (aref names-vector (ash i -4)))))
     758          ;; Special-case a few things ...
     759          (if (eq name 'symbol-vector)
     760            (setq name 'symbol)
     761            (if (eq name 'function-vector)
     762              (setq name 'function)))
     763          (setf (aref a i) name)))))
     764       
     765   
     766(defun report-heap-utilization (out nconses nvectors vector-sizes)
     767  (format out "~&Object type~42tCount~50tTotal Size in Bytes")
     768  (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size))
     769  (dotimes (i (length nvectors))
     770    (let* ((count (aref nvectors i))
     771           (sizes (aref vector-sizes i)))
     772      (unless (zerop count)
     773        (format out "~&~a~36t~12d~48t~16d" (aref *x8664-vector-type-names* i)  count sizes)))))
     774                           
     775)
     776
     777#-x8664-target
     778(eval-when (:compile-toplevel)
     779  (warn "Need PPC versions of REPORT-HEAP-UTILIZATION"))
     780
  • branches/working-0711/ccl/lib/numbers.lisp

    r6012 r7624  
    350350(defparameter a-short-float 1.0s0)
    351351
    352 
     352#+32-bit-target
    353353(defmethod print-object ((rs random-state) stream)
    354354  (format stream "#.(~S ~S ~S)"         ;>> #.GAG!!!
    355355          'ccl::initialize-random-state
    356           (%svref rs 1)
    357           (%svref rs 2)))
     356          (random.seed-1 rs)
     357          (random.seed-2 rs)))
     358
     359#+64-bit-target
     360(defmethod print-object ((rs random-state) stream)
     361  (let* ((s1 (random.seed-1 rs)))
     362    (format stream "#.(~S ~S ~S)"       ;>> #.GAG!!!
     363            'ccl::initialize-random-state
     364            (ldb (byte 16 16) s1)
     365            (ldb (byte 16 0) s1))))
    358366
    359367
  • branches/working-0711/ccl/lib/ppc-backtrace.lisp

    r6925 r7624  
    250250    (get-register-value nil last-catch index)))
    251251
     252(defun %set-register-argument-value (context cfp regval new)
     253  (let* ((last-catch (last-catch-since cfp context))
     254         (index (register-number->saved-register-index regval)))
     255    (do* ((frame cfp
     256                 (child-frame frame context))
     257          (first t))
     258         ((null frame))
     259      (if (fake-stack-frame-p frame)
     260        (return-from %set-register-argument-value
     261          (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new))
     262        (if first
     263          (setq first nil)
     264          (multiple-value-bind (lfun pc)
     265              (cfp-lfun frame)
     266            (when lfun
     267              (multiple-value-bind (mask where)
     268                  (registers-used-by lfun pc)
     269                (when (if mask (logbitp index mask))
     270                  (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
     271                  (return-from
     272                   %set-register-argument-value
     273                    (raw-frame-set frame context where new)))))))))
     274    (set-register-value new nil last-catch index)))
     275
    252276(defun %raw-frame-ref (cfp context idx bad)
    253277  (declare (fixnum idx))
     
    273297        bad))))
    274298
     299(defun %raw-frame-set (cfp context idx new)
     300  (declare (fixnum idx))
     301  (multiple-value-bind (frame base)
     302      (vsp-limits cfp context)
     303    (let* ((raw-size (- base frame)))
     304      (declare (fixnum frame base raw-size))
     305      (if (and (>= idx 0)
     306               (< idx raw-size))
     307        (let* ((addr (- (the fixnum (1- base))
     308                        idx)))
     309          (multiple-value-bind (db-count first-db last-db)
     310              (count-db-links-in-frame frame base context)
     311            (let* ((is-db-link
     312                    (unless (zerop db-count)
     313                      (do* ((last last-db (previous-db-link last first-db)))
     314                           ((null last))
     315                        (when (= addr last)
     316                          (return t))))))
     317              (if is-db-link
     318                (setf (oldest-binding-frame-value context addr) new)
     319                (setf (%fixnum-ref addr) new))))
     320          t)))))
     321
    275322;;; Used for printing only.
    276323(defun index->address (p)
  • branches/working-0711/ccl/lib/systems.lisp

    r5738 r7624  
    181181
    182182    (edit-callers          "ccl:bin;edit-callers"   ("ccl:lib;edit-callers.lisp"))
    183     (hash-cons        "ccl:library;hash-cons"    ("ccl:library;hash-cons.lisp"))
    184 ; (step             "ccl:bin;step"           ("ccl:lib;step.lisp"))
     183    ;; (hash-cons        "ccl:library;hash-cons"    ("ccl:library;hash-cons.lisp"))
     184    ;; (step             "ccl:bin;step"           ("ccl:lib;step.lisp"))
    185185    (ccl-export-syms  "ccl:bin;ccl-export-syms"  ("ccl:lib;ccl-export-syms.lisp"))
    186186    (systems          "ccl:bin;systems"        ("ccl:lib;systems.lisp"))
  • branches/working-0711/ccl/lib/x86-backtrace.lisp

    r7224 r7624  
    9595      bad)))
    9696
     97(defun %raw-frame-set (frame context idx new)
     98  (declare (fixnum frame idx))
     99  (let* ((base (parent-frame frame context))
     100         (raw-size (- base frame)))
     101    (declare (fixnum base raw-size))
     102    (if (and (>= idx 0)
     103             (< idx raw-size))
     104      (let* ((addr (- (the fixnum (1- base))
     105                      idx)))
     106        (multiple-value-bind (db-count first-db last-db)
     107            (count-db-links-in-frame frame base context)
     108          (let* ((is-db-link
     109                  (unless (zerop db-count)
     110                    (do* ((last last-db (previous-db-link last first-db)))
     111                         ((null last))
     112                      (when (= addr last)
     113                        (return t))))))
     114            (if is-db-link
     115              (setf (oldest-binding-frame-value context addr) new)
     116              (setf (%fixnum-ref addr) new))))))))
     117
    97118(defun %stack< (index1 index2 &optional context)
    98119  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     
    153174    (get-register-value nil last-catch index)))
    154175
     176(defun %set-register-argument-value (context cfp regval new)
     177  (let* ((last-catch (last-catch-since cfp context))
     178         (index (register-number->saved-register-index regval)))
     179    (do* ((frame cfp (child-frame frame context))
     180          (first t))
     181         ((null frame))
     182      (if (xcf-p frame)
     183        (with-macptrs (xp)
     184          (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp))
     185          (return-from %set-register-argument-value
     186            (setf (encoded-gpr-lisp xp regval) new)))
     187        (progn
     188          (unless first
     189            (multiple-value-bind (lfun pc)
     190                (cfp-lfun frame)
     191              (when lfun
     192                (multiple-value-bind (mask where)
     193                    (registers-used-by lfun pc)
     194                  (when (if mask (logbitp index mask))
     195                    (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index))))))
     196
     197                    (return-from %set-register-argument-value
     198                      (raw-frame-set frame context where new)))))))
     199          (setq first nil))))
     200    (set-register-value new nil last-catch index)))
     201
    155202;;; Used for printing only.
    156203(defun index->address (p)
  • branches/working-0711/ccl/library/lispequ.lisp

    r6913 r7624  
    12231223    nhash.find                          ; function: find vector-index
    12241224    nhash.find-new                      ; function: find vector-index on put
     1225    nhash.read-only                     ; boolean: true when read-only
    12251226    )
    12261227
  • branches/working-0711/ccl/library/x8664-linux-syscalls.lisp

    r4052 r7624  
    150150
    151151
     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 )
    152153
    153154#+notdefinedyet
  • branches/working-0711/ccl/lisp-kernel/Threads.h

    r6260 r7624  
    4747#include "gc.h"
    4848
     49#ifdef USE_FUTEX
     50#include <linux/futex.h>
     51#include <sys/syscall.h>
     52#endif
     53
     54#include <syslog.h>
     55
    4956Boolean extern threads_initialized;
     57Boolean extern log_tcr_info;
     58
     59#define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr)
     60#define RELEASE_SPINLOCK(x) (x)=0
    5061
    5162#define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS))
     
    5667#define SEM_WAIT(s) sem_wait((SEMAPHORE)s)
    5768#define SEM_RAISE(s) sem_post((SEMAPHORE)s)
     69#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0)
    5870#define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t)
    5971#endif
     
    6375#define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s)
    6476#define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s)
     77#define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s)
    6578#define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t)
    6679#endif
     
    121134Boolean resume_tcr(TCR *);
    122135
    123 typedef struct _rwquentry
    124 {
    125   struct _rwquentry *prev;
    126   struct _rwquentry *next;
    127   TCR *tcr;
    128   int count;
    129 } rwquentry;
    130 
    131136typedef struct
    132137{
    133   rwquentry head;
    134   int state;                    /* sum of all counts on queue */
    135   pthread_mutex_t *lock;        /* lock access to this data structure */
    136   pthread_cond_t *reader_signal;
    137   pthread_cond_t *writer_signal;
    138   int write_wait_count;
    139   int read_wait_count;
    140   int dying;
    141   rwquentry freelist;
     138  signed_natural spin; /* need spin lock to change fields */
     139  signed_natural state; /* 0 = free, positive if writer, negative if readers; */
     140  natural blocked_writers;
     141  natural blocked_readers;
     142  TCR  *writer;
     143#ifdef USE_FUTEX
     144  natural reader_signal;
     145  natural writer_signal;
     146#else
     147  void * reader_signal;
     148  void * writer_signal;
     149#endif
     150  void *malloced_ptr;
    142151} rwlock;
    143152
    144 #define RWLOCK_WRITER(rw) rw->head.tcr
    145 #define RWLOCK_WRITE_COUNT(rw) rw->head.count
    146153
    147154rwlock * rwlock_new(void);
    148 int rwlock_destroy(rwlock *);
     155void rwlock_destroy(rwlock *);
    149156int rwlock_rlock(rwlock *, TCR *, struct timespec *);
    150157int rwlock_wlock(rwlock *, TCR *, struct timespec *);
    151158int rwlock_try_wlock(rwlock *, TCR *);
     159int rwlock_try_rlock(rwlock *, TCR *);
    152160int rwlock_unlock(rwlock *, TCR *);
    153161
  • branches/working-0711/ccl/lisp-kernel/errors.s

    r6899 r7624  
    2525error_excised_function_call = 6
    2626error_too_many_values = 7
     27error_propagate_suspend = 10   
    2728error_cant_call = 17
    2829       
  • branches/working-0711/ccl/lisp-kernel/gc.h

    r7137 r7624  
    118118#define GC_TRAP_FUNCTION_EGC_CONTROL 32
    119119#define GC_TRAP_FUNCTION_CONFIGURE_EGC 64
    120 #define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128
     120#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 /* deprecated */
     121#define GC_TRAP_FUNCTION_FREEZE 129
     122#define GC_TRAP_FUNCTION_THAW 130
     123
    121124#endif                          /* __GC_H__ */
  • branches/working-0711/ccl/lisp-kernel/image.c

    r6215 r7624  
    211211
    212212    a->static_dnodes = sect->static_dnodes;
    213     if (a->static_dnodes) {
    214       natural pages_size = (align_to_power_of_2((align_to_power_of_2(a->static_dnodes,
    215                                                                      log2_nbits_in_word)>>3),
    216                                                 log2_page_size));
    217       lseek(fd,pos+mem_size, SEEK_SET);
    218       pos = seek_to_next_page(fd);
    219       addr = mmap(NULL,
    220                   pages_size,
    221                   PROT_READ | PROT_WRITE,
    222                   MAP_PRIVATE,
    223                   fd,
    224                   pos);
    225       if (addr == MAP_FAILED) {
    226         return;
    227       }
    228       a->static_used = addr;
    229       advance = pages_size;
    230     }
    231213    sect->area = a;
    232214    break;
     
    420402#endif
    421403
    422   areas[0] = readonly_area;
    423   areas[1] = nilreg_area;
    424   areas[2] = active_dynamic_area;
     404  areas[0] = nilreg_area;
     405  areas[1] = active_dynamic_area;
     406  areas[2] = readonly_area;
    425407  areas[3] = managed_static_area;
    426408  for (i = 0; i < NUM_IMAGE_SECTIONS; i++) {
     
    477459    case FWDNUM:
    478460    case GC_NUM:
    479     case DELETED_STATIC_PAIRS:
     461    case STATIC_CONSES:
    480462      break;
    481463    default:
     
    503485        return errno;
    504486      }
    505       if (nstatic) {
    506         /* Need to write the static_used bitmap */
    507         natural static_used_size_in_bytes =
    508           (align_to_power_of_2((align_to_power_of_2(nstatic, log2_nbits_in_word)>>3),
    509                                log2_page_size));
    510         seek_to_next_page(fd);
    511         if (write(fd, tenured_area->static_used, static_used_size_in_bytes)
    512             != static_used_size_in_bytes) {
    513           return errno;
    514         }
    515       }
    516487    }
    517488  }
  • branches/working-0711/ccl/lisp-kernel/lisp-errors.h

    r5529 r7624  
    1818#define __ERRORS_X 1
    1919
    20 /*
    21 10/22/96 bill error_too_many_values
    22 --- 4.0 ---
    23 05/12/96  gb  conditionalize on __ERRORS_X to avoid conflict with <errors.h>
    24 --- 3.9 ---
    25 04/10/96  gb  error_memory_full
    26 04/09/96  gb  error_excised_function_call
    27 03/01/96  gb  FPU exceptions
    28 01/22/96  gb  add/rename error_alloc_failed, error_stack_overflow
    29 12/13/95  gb  add error_alloc_fail, error_throw_tag_missing.
    30 11/09/95  gb  in synch with %type-error-types%.
    31 */
    3220
    3321#define error_reg_regnum 0
     
    3927#define error_excised_function_call 6
    4028#define error_too_many_values 7
     29#define error_propagate_suspend 10
    4130#define error_cant_call 17
    4231
  • branches/working-0711/ccl/lisp-kernel/lisp_globals.h

    r6901 r7624  
    3333#define TCR_AREA_LOCK (-11)       /* all_areas/tcr queue lock */
    3434#define EXCEPTION_LOCK (-12)    /* serialize exception handling */
    35 #define DELETED_STATIC_PAIRS (-13) /* for hash-consing */
     35#define STATIC_CONSES (-13)
    3636#define DEFAULT_ALLOCATION_QUANTUM (-14)
    3737#define INTFLAG (-15)
  • branches/working-0711/ccl/lisp-kernel/ppc-constants.h

    r3493 r7624  
    6868#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4)
    6969#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)
    7072
    7173#define TCR_STATE_FOREIGN (1)
  • branches/working-0711/ccl/lisp-kernel/ppc-constants32.s

    r5783 r7624  
    607607TCR_FLAG_BIT_FOREIGN = fixnum_shift
    608608TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
     609TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2)
     610TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3)
     611TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4)
     612TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5)
     613TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6)
     614TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7)       
    609615       
    610616r0 = 0
  • branches/working-0711/ccl/lisp-kernel/ppc-constants64.s

    r5783 r7624  
    577577
    578578TCR_FLAG_BIT_FOREIGN = fixnum_shift
    579 TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
     579TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1)
     580TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2)
     581TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3)
     582TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4)
     583TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5)
     584TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6)
     585TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7)       
    580586
    581587
  • branches/working-0711/ccl/lisp-kernel/ppc-exceptions.c

    r7137 r7624  
    13271327
    13281328  case UUO_INTERR:
    1329     status = handle_error(xp, errnum, rb, 0,  where);
     1329    if (errnum == error_propagate_suspend) {
     1330      status = 0;
     1331    } else {
     1332      status = handle_error(xp, errnum, rb, 0,  where);
     1333    }
    13301334    break;
    13311335
     
    17591763    old_valence = prepare_to_wait_for_exception_lock(tcr, context);
    17601764  }
     1765
     1766  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
     1767    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
     1768    pthread_kill(pthread_self(), thread_suspend_signal);
     1769  }
     1770
    17611771 
    17621772  wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
  • branches/working-0711/ccl/lisp-kernel/ppc-gc.c

    r7137 r7624  
    15971597
    15981598        case xmacptr_flag_rwlock:
     1599          rwlock_destroy((rwlock *)ptr_from_lispobj(ptr));
    15991600          break;
    16001601
  • branches/working-0711/ccl/lisp-kernel/ppc-macros.s

    r6515 r7624  
    826826define([aligned_bignum_size],[((~(dnode_size-1)&(node_size+(dnode_size-1)+(4*$1))))])
    827827
    828 
    829                
     828define([suspend_now],[
     829        uuo_interr(error_propagate_suspend,rzero)
     830])
  • branches/working-0711/ccl/lisp-kernel/ppc-spentry.s

    r6903 r7624  
    66826682/* any interrupt polling  */
    66836683       
    6684 _spentry(unbind_interrupt_level)       
    6685         __(ldr(imm2,tcr.tlb_pointer(rcontext)))   
     6684_spentry(unbind_interrupt_level)
     6685        __(ldr(imm0,tcr.flags(rcontext)))
     6686        __(ldr(imm2,tcr.tlb_pointer(rcontext)))
     6687        __(andi. imm0,imm0,1<<TCR_FLAG_BIT_PENDING_SUSPEND)
    66866688        __(ldr(imm1,tcr.db_link(rcontext)))
    66876689        __(ldr(temp1,INTERRUPT_LEVEL_BINDING_INDEX(imm2)))
    6688         __(cmpri(cr1,temp1,0))
     6690        __(bne 5f)
     66910:      __(cmpri(cr1,temp1,0))
    66896692        __(ldr(temp1,binding.val(imm1)))
    66906693        __(ldr(imm1,binding.link(imm1)))
     
    66986701        __(mr nargs,imm2)
    66996702        __(blr)
     67035:       /* Missed a suspend request; force suspend now if we're restoring
     6704          interrupt level to -1 or greater */
     6705        __(cmpri(temp1,-2<<fixnumshift))
     6706        __(bne 0b)
     6707        __(ldr(imm0,binding.val(imm1)))
     6708        __(cmpr(imm0,temp1))
     6709        __(beq 0b)
     6710        __(li imm0,1<<fixnumshift)
     6711        __(str(imm0,INTERRUPT_LEVEL_BINDING_INDEX(imm2)))
     6712        __(suspend_now())
     6713        __(b 0b)
     6714
    67006715
    67016716/* arg_x = array, arg_y = i, arg_z = j. Typecheck everything.
  • branches/working-0711/ccl/lisp-kernel/thread_manager.c

    <
    r6904 r7624  
    4444atomic_swap(signed_natural*, signed_natural);
    4545
     46#ifdef USE_FUTEX
     47#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val)
     48#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n)
     49#define FUTEX_AVAIL (0)
     50#define FUTEX_LOCKED (1)
     51#define FUTEX_CONTENDED (2)
     52#endif
    4653
    4754int
     
    8794
    8895
     96#ifndef USE_FUTEX
    8997int spin_lock_tries = 1;
    9098
     
    103111  }
    104112}
    105 
    106 
     113#endif
     114
     115#ifndef USE_FUTEX
    107116int
    108117lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
     
    117126  }
    118127  while (1) {
    119     get_spin_lock(&(m->spinlock),tcr);
     128    LOCK_SPINLOCK(m->spinlock,tcr);
    120129    ++m->avail;
    121130    if (m->avail == 1) {
    122131      m->owner = tcr;
    123132      m->count = 1;
    124       m->spinlock = 0;
     133      RELEASE_SPINLOCK(m->spinlock);
    125134      break;
    126135    }
    127     m->spinlock = 0;
     136    RELEASE_SPINLOCK(m->spinlock);
    128137    SEM_WAIT_FOREVER(m->signal);
    129138  }
     
    131140}
    132141
    133  
     142#else /* USE_FUTEX */
     143
     144static void inline
     145lock_futex(natural *p)
     146{
     147 
     148  while (1) {
     149    if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) {
     150      return;
     151    }
     152    while (1) {
     153      if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) {
     154        return;
     155      }
     156      futex_wait(p,FUTEX_CONTENDED);
     157    }
     158  }
     159}
     160
     161static void inline
     162unlock_futex(natural *p)
     163{
     164  if (atomic_decf(p) != FUTEX_AVAIL) {
     165    *p = FUTEX_AVAIL;
     166    futex_wake(p,INT_MAX);
     167  }
     168}
     169   
     170int
     171lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
     172{
     173  natural val;
     174  if (tcr == NULL) {
     175    tcr = get_tcr(true);
     176  }
     177  if (m->owner == tcr) {
     178    m->count++;
     179    return 0;
     180  }
     181  lock_futex(&m->avail);
     182  m->owner = tcr;
     183  m->count = 1;
     184  return 0;
     185}
     186#endif /* USE_FUTEX */
     187
     188
     189#ifndef USE_FUTEX 
    134190int
    135191unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
     
    144200    --m->count;
    145201    if (m->count == 0) {
    146       get_spin_lock(&(m->spinlock),tcr);
     202      LOCK_SPINLOCK(m->spinlock,tcr);
    147203      m->owner = NULL;
    148204      pending = m->avail-1 + m->waiting;     /* Don't count us */
     
    154210        m->waiting = 0;
    155211      }
    156       m->spinlock = 0;
     212      RELEASE_SPINLOCK(m->spinlock);
    157213      if (pending >= 0) {
    158214        SEM_RAISE(m->signal);
     
    163219  return ret;
    164220}
     221#else /* USE_FUTEX */